2015-08-04: added hoist-in-loop example

added hoist-in-loop example

diff --git a/examples/hoist-in-loop.w b/examples/hoist-in-loop.w
new file mode 100644
--- /dev/null
+++ b/examples/hoist-in-loop.w
@@ -0,0 +1,105 @@
+;; This is partial example code taken from the loop optimization Guile code at
+;; http://git.savannah.gnu.org/gitweb/?p=guile.git;a=blob;f=module/language/cps/licm.scm;h=3b343a66bd8ed4a591a9e97edbf1179a4d3a78a8;hb=HEAD
+
+; I chose this example because this code felt very dense when I first
+; read it, so I wanted to check whether this improves with wisp
+; syntax.
+
+; but first the copyright information from the header of the file:
+
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+define : hoist-in-loop cps entry body-labels succs preds effects
+  let* 
+       : 
+         interior-succs 
+             intmap-map 
+                 lambda : label succs
+                          intset-intersect succs body-labels
+                 . succs
+         sorted-labels : compute-reverse-post-order interior-succs entry
+         header-label : fresh-label
+         header-cont : intmap-ref cps entry
+         loop-vars 
+             match header-cont
+                   : $ $kargs names vars
+                     list->intset vars
+         loop-effects
+             persistent-intmap
+                       intset-fold
+                        lambda : label loop-effects
+                           let 
+                             : 
+                               abel*
+                                 if : eqv? label entry
+                                      . header-label
+                                      . label
+                               fx : intmap-ref effects label
+                             intmap-add! loop-effects label* fx
+                        body-labels empty-intmap
+         pre-header-label entry
+         pre-header-cont 
+             match header-cont
+               : $ $kargs names vars term
+                 let : : vars* : map (lambda (_) (fresh-var)) vars
+                     build-cont
+                      $kargs names vars*
+                        $continue header-label #f
+                          $values vars*
+         cps : intmap-add! cps header-label header-cont
+         cps : intmap-replace! cps pre-header-label pre-header-cont
+         to-visit 
+             match sorted-labels
+                     : head . tail
+                       unless : eqv? head entry
+                                error "what?"
+                       cons header-label tail
+    define : rename-back-edges cont
+      define : rename label
+               if : eqv? label entry
+                    . header-label
+                    . label
+      rewrite-cont cont
+        : $ $kargs names vars : $ $continue kf src : $ $branch kt exp
+            $kargs names vars
+              $continue (rename kf) src : $branch (rename kt) ,exp
+        : $ $kargs names vars : $ $continue k src exp
+            $kargs names vars
+              $continue (rename k) src ,exp
+        : $ $kreceive ($ $arity req () rest) k
+            $kreceive req rest (rename k)
+      let lp 
+        : cps cps
+          to-visit to-visit
+          loop-vars loop-vars
+          loop-effects loop-effects
+          pre-header-label pre-header-label
+          always-reached? #t
+        match to-visit
+          () cps
+          : label . to-visit
+            call-with-values
+               lambda :
+                 hoist-one cps label (intmap-ref cps label) preds
+                           . loop-vars loop-effects
+                           . pre-header-label always-reached?
+               lambda : cps cont loop-vars loop-effects pre-header-label always-reached?
+                  lp : intmap-replace! cps label : rename-back-edges cont
+                     . to-visit
+                     . loop-vars loop-effects pre-header-label always-reached?