Merge remote-tracking branch 'origin/master'

CHANGELOG.md

@@ -2,6 +2,17 @@
 
 ## 0.9.4 - TBD
 
+Compiler Optimizations
+
+- Optimize recursive functions by expressing the recursive calls using C iteration. This optimization is more effective when combined with the others listed below as they collectively increase the chances that a higher-level Scheme loop may be compiled down to a single C function which can then be "called" repeatedly using a `while` loop which is more efficient at a low level than repeated calls to C functions.
+- Combine lambda functions that are only called for side effects.
+- Improve inlining of primitives that work with immutable objects.
+- Eliminate functions that are only used to define local variables.
+
+Features
+
+- Added a new feature `program` to `cond-expand` that is only defined when compiling a program. This allows, for example, a `.scm` file to contain a section of code that can be used to run unit tests when the file is compiled as a program. The same file can then be used in production to import code into a library. This is similar to using the `__main__` scope in a python program.
+
 Bug Fixes
 
 - Prevent GC segmentation fault on ARM platforms (Raspberry Pi 2).

Makefile

@@ -224,6 +224,7 @@ bootstrap : icyc libs
 	cp tests/unit-tests.scm $(BOOTSTRAP_DIR)
 	cp scheme/cyclone/ast.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/cps-optimizations.c $(BOOTSTRAP_DIR)/scheme/cyclone
+	cp scheme/cyclone/cps-opt-local-var-redux.scm $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/libraries.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/macros.c $(BOOTSTRAP_DIR)/scheme/cyclone
 	cp scheme/cyclone/match.c $(BOOTSTRAP_DIR)/scheme/cyclone

Makefile.config

@@ -7,6 +7,9 @@
 CYC_PROFILING ?= 
 #CYC_PROFILING ?= -pg
 
+CYC_GCC_OPT_FLAGS ?= -O2
+#CYC_GCC_OPT_FLAGS ?= -g
+
 OS ?= $(shell uname)
 CC ?= cc
 
@@ -17,8 +20,8 @@ LIBS += -ldl
 endif
 
 # Compiler options
-CFLAGS       ?= $(CYC_PROFILING) -O2 -fPIC -Wall -Iinclude
+CFLAGS       ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Iinclude
-COMP_CFLAGS  ?= $(CYC_PROFILING) -O2 -fPIC -Wall -I$(PREFIX)/include -L$(PREFIX)/lib
+COMP_CFLAGS  ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -I$(PREFIX)/include -L$(PREFIX)/lib
 # Use these lines instead for debugging or profiling
 #CFLAGS = -g -Wall
 #CFLAGS = -g -pg -Wall

cyclone.scm

@@ -424,6 +424,10 @@
         (trace:info (ast:ast->pp-sexp input-program))
       )
     
+      (set! input-program (opt:local-var-reduction input-program))
+      (trace:info "---------------- after local variable reduction")
+      (trace:info (ast:ast->pp-sexp input-program))
+
       ;; TODO: could do this, but it seems like a bit of a band-aid...
       (set! input-program (opt:renumber-lambdas! input-program))
       (trace:info "---------------- after renumber lambdas")
@@ -545,10 +549,13 @@
          (in-prog-raw (read-file in-file))
          (program? (not (library? (car in-prog-raw))))
          (in-prog
-          (if program? 
+          (cond
-              in-prog-raw
+            (program? 
+              (Cyc-add-feature! 'program) ;; Load special feature
+              in-prog-raw)
+            (else
               ;; Account for any cond-expand declarations in the library
-              (list (lib:cond-expand (car in-prog-raw) expander))))
+              (list (lib:cond-expand (car in-prog-raw) expander)))))
    ;; TODO: expand in-prog, if a library, using lib:cond-expand. (OK, this works now)
    ;; TODO: will also need to do below in lib:get-all-import-deps, after reading each library
          (program:imports/code (if program? (import-reduction in-prog expander) '()))

docs/api/srfi/18.md

@@ -4,12 +4,6 @@ The `(srfi 18)` library provides multithreading support.
 
 See the [Multithreading support SRFI documentation](http://srfi.schemers.org/srfi-18/srfi-18.html) for more information.
 
-## Limitations
-
-Currently, ``thread-join!`` is not provided. While this is not an essential
-primitive and can be worked around, code that relies on ``thread-join!`` being
-present in this implementation will fail to compile.
-
 - [`thread?`](#thread)
 - [`make-thread`](#make-thread)
 - [`thread-name`](#thread-name)

gc.c

@@ -864,10 +864,11 @@ char *gc_copy_obj(object dest, char *obj, gc_thread_data * thd)
       bignum_type *hp = dest;
       mark(hp) = thd->gc_alloc_color;
       type_of(hp) = bignum_tag;
-      ((bignum_type *)hp)->bn.used = ((bignum_type *)obj)->bn.used;
+      // Bignums are always heap-allocated so there is nothing to copy
-      ((bignum_type *)hp)->bn.alloc = ((bignum_type *)obj)->bn.alloc;
+      //((bignum_type *)hp)->bn.used = ((bignum_type *)obj)->bn.used;
-      ((bignum_type *)hp)->bn.sign = ((bignum_type *)obj)->bn.sign;
+      //((bignum_type *)hp)->bn.alloc = ((bignum_type *)obj)->bn.alloc;
-      ((bignum_type *)hp)->bn.dp = ((bignum_type *)obj)->bn.dp;
+      //((bignum_type *)hp)->bn.sign = ((bignum_type *)obj)->bn.sign;
+      //((bignum_type *)hp)->bn.dp = ((bignum_type *)obj)->bn.dp;
       return (char *)hp;
     }
   case cvar_tag:{
@@ -1282,8 +1283,9 @@ void *gc_alloc_bignum(gc_thread_data *data)
   int heap_grown, result;
   bignum_type *bn;
   bignum_type tmp;
-  tmp.hdr.mark = gc_color_red;
+  // No need to do this since tmp is always local
-  tmp.hdr.grayed = 0;
+  //tmp.hdr.mark = gc_color_red;
+  //tmp.hdr.grayed = 0;
   tmp.tag = bignum_tag;
   bn = gc_alloc(((gc_thread_data *)data)->heap, sizeof(bignum_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown);
 

include/cyclone/types.h

@@ -748,6 +748,13 @@ typedef struct {
   n.tag = complex_num_tag; \
   n.value = (r + (i * I));
 
+#define alloca_complex_num(n,r,i) \
+  complex_num_type *n = alloca(sizeof(complex_num_type)); \
+  n->hdr.mark = gc_color_red; \
+  n->hdr.grayed = 0; \
+  n->tag = complex_num_tag; \
+  n->value = (r + (i * I));
+
 /** Assign given complex value to the given complex number object pointer */
 #define assign_complex_num(pobj,v) \
   ((complex_num_type *)pobj)->hdr.mark = gc_color_red; \
@@ -772,6 +779,13 @@ typedef struct {
   n.tag = double_tag; \
   n.value = v;
 
+#define alloca_double(n,v) \
+  double_type *n = alloca(sizeof(double_type)); \
+  n->hdr.mark = gc_color_red; \
+  n->hdr.grayed = 0; \
+  n->tag = double_tag; \
+  n->value = v;
+
 /** Assign given double value to the given double object pointer */
 #define assign_double(pobj,v) \
   ((double_type *)pobj)->hdr.mark = gc_color_red; \
@@ -1044,6 +1058,14 @@ typedef vector_type *vector;
   v.num_elements = 0; \
   v.elements = NULL;
 
+#define alloca_empty_vector(v) \
+  vector_type *v = alloca(sizeof(vector_type)); \
+  v->hdr.mark = gc_color_red; \
+  v->hdr.grayed = 0; \
+  v->tag = vector_tag; \
+  v->num_elements = 0; \
+  v->elements = NULL;
+
 /**
  * @brief Bytevector type 
  *
@@ -1067,6 +1089,14 @@ typedef bytevector_type *bytevector;
   v.len = 0; \
   v.data = NULL;
 
+#define alloca_empty_bytevector(v) \
+  bytevector_type *v = alloca(sizeof(bytevector_type)); \
+  v->hdr.mark = gc_color_red; \
+  v->hdr.grayed = 0; \
+  v->tag = bytevector_tag; \
+  v->len = 0; \
+  v->data = NULL;
+
 /**
  * @brief The pair (cons) type.
  *
@@ -1128,11 +1158,30 @@ typedef pair_type *pair;
   make_pair(l##__2, a2, &l##__3); \
   make_pair(l, a1, &l##__2);
 
+#define alloca_list_1(l, a1) \
+  alloca_pair(l, a1, NULL);
+
+#define alloca_list_2(l, a1, a2) \
+  alloca_pair(l##__2, a2, NULL); \
+  alloca_pair(l, a1, l##__2);
+
+#define alloca_list_3(l, a1, a2, a3) \
+  alloca_pair(l##__3, a3, NULL); \
+  alloca_pair(l##__2, a2, l##__3); \
+  alloca_pair(l, a1, l##__2);
+
+#define alloca_list_4(l, a1, a2, a3, a4) \
+  alloca_pair(l##__4, a4, NULL); \
+  alloca_pair(l##__3, a3, l##__4); \
+  alloca_pair(l##__2, a2, l##__3); \
+  alloca_pair(l, a1, l##__2);
+
 /**
  * Create a pair with a single value. 
  * This is useful to create an object that can be modified.
  */
 #define make_cell(n,a) make_pair(n,a,NULL);
+#define alloca_cell(n,a) alloca_pair(n,a,NULL);
 
 /**
  * \defgroup objects_unsafe_cxr Unsafe pair access macros

scheme/base.sld

@@ -148,6 +148,7 @@
     open-input-bytevector
     open-output-bytevector
     features
+    Cyc-add-feature!
     Cyc-version
     any
     every
@@ -237,10 +238,17 @@
         (cons
           (string->symbol 
             (string-append "version-" *version-number*))
-          '(r7rs 
+          *other-features*)))
-            ieee-float
+
-            full-unicode
+    (define *other-features* 
-            posix))))
+            '(r7rs 
+              ieee-float
+              full-unicode
+              posix))
+
+    ;; Designed for internal use only, don't call this in user code!!
+    (define (Cyc-add-feature! sym)
+      (set! *other-features* (cons sym *other-features*)))
 
     (define (Cyc-version) *version-number*)
 

scheme/cyclone/cgen.sld

@@ -31,6 +31,8 @@
     emits
     emits*
     emit-newline
+    ;; Helpers
+    self-closure-call?
   )
   (inline
     global-not-lambda?
@@ -127,6 +129,7 @@
            (vector-ref *c-call-arity* arity))
        (emit (c-macro-closcall arity))
        (emit (c-macro-return-closcall arity))
+       (emit (c-macro-continue-or-gc arity))
        (emit (c-macro-return-direct arity))
        (emit (c-macro-return-direct-with-closure arity))
        (when *optimize-well-known-lambdas*
@@ -154,6 +157,25 @@
       " } \\\n"
       "}\n")))
 
+;; Generate macros invoke a GC if necessary, otherwise do nothing.
+;; This will be used to support C iteration.
+(define (c-macro-continue-or-gc num-args)
+  (let ((args (c-macro-n-prefix num-args ",a"))
+        (n (number->string num-args))
+        (arry-assign (c-macro-array-assign num-args "buf" "a")))
+    (string-append
+      ;"/* Check for GC, then call given continuation closure */\n"
+      "#define continue_or_gc" n "(td, clo" args ") { \\\n"
+      " char *top = alloca(sizeof(char)); \\\n" ;; TODO: consider speeding up by passing in a var already allocated
+      " if (stack_overflow(top, (((gc_thread_data *)data)->stack_limit))) { \\\n"
+      "     object buf[" n "]; " arry-assign "\\\n"
+      "     GC(td, clo, buf, " n "); \\\n"
+      "     return; \\\n"
+      " } else {\\\n"
+      "     continue;\\\n"
+      " } \\\n"
+      "}\n")))
+
 ;; Generate macros to directly call a lambda function
 (define (c-macro-return-direct num-args)
   (let ((args (c-macro-n-prefix num-args ",a"))
@@ -367,12 +389,12 @@
        trace 
        cps?))
     ; Core forms:
-    ((const? exp)       (c-compile-const exp))
+    ((const? exp)       (c-compile-const exp (alloca? ast-id)))
     ((prim?  exp)       
      ;; TODO: this needs to be more refined, probably w/a lookup table
      (c-code (string-append "primitive_" (mangle exp))))
     ((ref?   exp)       (c-compile-ref exp))
-    ((quote? exp)       (c-compile-quote exp))
+    ((quote? exp)       (c-compile-quote exp (alloca? ast-id)))
     ((if? exp)          (c-compile-if exp append-preamble cont ast-id trace cps?))
 
     ; IR (2):
@@ -388,17 +410,20 @@
     ((app? exp)         (c-compile-app exp append-preamble cont ast-id trace cps?))
     (else               (error "unknown exp in c-compile-exp: " exp))))
 
-(define (c-compile-quote qexp)
+(define (c-compile-quote qexp use-alloca)
   (let ((exp (cadr qexp)))
-    (c-compile-scalars exp)))
+    (c-compile-scalars exp use-alloca)))
 
-(define (c-compile-scalars args)
+(define (c-compile-scalars args use-alloca)
   (letrec (
+    (addr-op (if use-alloca "" "&"))
+    ;(deref-op (if use-alloca "->" "."))
+    (c-make-macro (if use-alloca "alloca_pair" "make_pair"))
     (num-args 0)
     (create-cons
       (lambda (cvar a b)
         (c-code/vars
-          (string-append "make_pair(" cvar "," (c:body a) "," (c:body b) ");")
+          (string-append c-make-macro "(" cvar "," (c:body a) "," (c:body b) ");")
           (append (c:allocs a) (c:allocs b))))
     )
     (_c-compile-scalars 
@@ -407,16 +432,16 @@
         ((null? args)
            (c-code "NULL"))
         ((not (pair? args))
-         (c-compile-const args))
+         (c-compile-const args use-alloca))
         (else
            (let* ((cvar-name (mangle (gensym 'c)))
                   (cell (create-cons
                           cvar-name
-                          (c-compile-const (car args)) 
+                          (c-compile-const (car args) use-alloca) 
                           (_c-compile-scalars (cdr args)))))
              (set! num-args (+ 1 num-args))
              (c-code/vars
-                (string-append "&" cvar-name)
+                (string-append addr-op cvar-name)
                 (append
                   (c:allocs cell)
                   (list (c:body cell))))))))))
@@ -424,15 +449,18 @@
     (_c-compile-scalars args) 
     num-args)))
 
-(define (c-compile-vector exp)
+(define (c-compile-vector exp use-alloca)
   (letrec ((cvar-name (mangle (gensym 'vec)))
            (len (vector-length exp))
+           (addr-op (if use-alloca "" "&"))
+           (deref-op (if use-alloca "->" "."))
+           (c-make-macro (if use-alloca "alloca_empty_vector" "make_empty_vector"))
            ;; Generate code for each member of the vector 
            (loop 
             (lambda (i code)
               (if (= i len)
                 code
-                (let ((idx-code (c-compile-const (vector-ref exp i))))
+                (let ((idx-code (c-compile-const (vector-ref exp i) use-alloca)))
                   (loop 
                     (+ i 1)
                     (c-code/vars
@@ -444,32 +472,35 @@
                         (c:allocs idx-code) ;; Member alloc at index i
                         (list ;; Assign this member to vector
                           (string-append 
-                            cvar-name ".elements[" (number->string i) "] = "
+                            cvar-name deref-op "elements[" (number->string i) "] = "
                             (c:body idx-code)
                             ";")))))))))
           )
     (cond
       ((zero? len)
         (c-code/vars
-            (string-append "&" cvar-name) ; Code is just the variable name
+            (string-append addr-op cvar-name) ; Code is just the variable name
             (list ; Allocate empty vector
               (string-append 
-                "make_empty_vector(" cvar-name ");"))))
+                c-make-macro "(" cvar-name ");"))))
       (else
         (let ((code
                 (c-code/vars
-                  (string-append "&" cvar-name) ; Code body is just var name
+                  (string-append addr-op cvar-name) ; Code body is just var name
                   (list ; Allocate the vector
                     (string-append 
-                      "make_empty_vector(" cvar-name ");"
+                      c-make-macro "(" cvar-name ");"
-                      cvar-name ".num_elements = " (number->string len) ";"
+                      cvar-name deref-op "num_elements = " (number->string len) ";"
-                      cvar-name ".elements = (object *)alloca(sizeof(object) * " 
+                      cvar-name deref-op "elements = (object *)alloca(sizeof(object) * " 
                                          (number->string len) ");")))))
         (loop 0 code))))))
 
-(define (c-compile-bytevector exp)
+(define (c-compile-bytevector exp use-alloca)
   (letrec ((cvar-name (mangle (gensym 'vec)))
            (len (bytevector-length exp))
+           (addr-op (if use-alloca "" "&"))
+           (deref-op (if use-alloca "->" "."))
+           (c-make-macro (if use-alloca "alloca_empty_bytevector" "make_empty_bytevector"))
            ;; Generate code for each member of the vector 
            (loop 
             (lambda (i code)
@@ -486,7 +517,7 @@
                         (c:allocs code) ;; Vector alloc
                         (list ;; Assign this member to vector
                           (string-append 
-                            cvar-name ".data[" (number->string i) "] = (unsigned char)"
+                            cvar-name deref-op "data[" (number->string i) "] = (unsigned char)"
                             byte-val
                             ";"))))
                     ))))
@@ -495,37 +526,77 @@
     (cond
       ((zero? len)
         (c-code/vars
-            (string-append "&" cvar-name) ; Code is just the variable name
+            (string-append addr-op cvar-name) ; Code is just the variable name
             (list ; Allocate empty vector
               (string-append 
-                "make_empty_bytevector(" cvar-name ");"))))
+                c-make-macro "(" cvar-name ");"))))
       (else
         (let ((code
                 (c-code/vars
-                  (string-append "&" cvar-name) ; Code body is just var name
+                  (string-append addr-op cvar-name) ; Code body is just var name
                   (list ; Allocate the vector
                     (string-append 
-                      "make_empty_bytevector(" cvar-name ");"
+                      c-make-macro "(" cvar-name ");"
-                      cvar-name ".len = " (number->string len) ";"
+                      cvar-name deref-op "len = " (number->string len) ";"
-                      cvar-name ".data = alloca(sizeof(char) * " 
+                      cvar-name deref-op "data = alloca(sizeof(char) * " 
                                          (number->string len) ");")))))
         (loop 0 code))))))
 
+(define (c-compile-string exp use-alloca)
+  (let ((cvar-name (mangle (gensym 'c))))
+    (cond
+      (use-alloca
+       (let ((tmp-name (mangle (gensym 'tmp)))
+             (blen (number->string (string-byte-length exp)))
+            )
+        (c-code/vars
+          (string-append "" cvar-name) ; Code is just the variable name
+          (list     ; Allocate integer on the C stack
+            (string-append 
+              "object " cvar-name ";\n "
+              "alloc_string(data," 
+              cvar-name 
+              ", " 
+              blen
+              ", " 
+              (number->string (string-length exp))
+              ");\n"
+              "char " tmp-name "[] = "
+              (->cstr exp) 
+              ";\n"
+              "memcpy(((string_type *)" cvar-name ")->str, " tmp-name "," blen ");\n"
+              "((string_type *)" cvar-name ")->str[" blen "] = '\\0';"
+            )))))
+      (else
+        (c-code/vars
+          (string-append "&" cvar-name) ; Code is just the variable name
+          (list     ; Allocate integer on the C stack
+            (string-append 
+              "make_utf8_string_with_len(" 
+              cvar-name 
+              ", " 
+              (->cstr exp) 
+              ", " 
+              (number->string (string-byte-length exp))
+              ", " 
+              (number->string (string-length exp))
+              ");")))))))
+
 ;; c-compile-const : const-exp -> c-pair
 ;;
 ;; Typically this function is used to compile constant values such as
 ;; a single number, boolean, etc. However, it can be passed a quoted
 ;; item such as a list, to compile as a literal.
-(define (c-compile-const exp)
+(define (c-compile-const exp use-alloca)
   (cond
     ((null? exp)
      (c-code "NULL"))
     ((pair? exp)
-     (c-compile-scalars exp))
+     (c-compile-scalars exp use-alloca))
     ((vector? exp)
-     (c-compile-vector exp))
+     (c-compile-vector exp use-alloca))
     ((bytevector? exp)
-     (c-compile-bytevector exp))
+     (c-compile-bytevector exp use-alloca))
     ((bignum? exp)
       (let ((cvar-name (mangle (gensym 'c)))
             (num2str (cond
@@ -551,19 +622,15 @@
                             (number->string n)))))
              (rnum (num2str (real-part exp)))
              (inum (num2str (imag-part exp)))
+             (addr-op (if use-alloca "" "&"))
+             (c-make-macro (if use-alloca "alloca_complex_num" "make_complex_num"))
             )
         (c-code/vars
-            (string-append "&" cvar-name) ; Code is just the variable name
+            (string-append addr-op cvar-name) ; Code is just the variable name
             (list     ; Allocate on the C stack
               (string-append 
-                "make_complex_num(" cvar-name ", " rnum ", " inum ");")))))
+                c-make-macro "(" cvar-name ", " rnum ", " inum ");")))))
     ((integer? exp) 
-;     (let ((cvar-name (mangle (gensym 'c))))
-;        (c-code/vars
-;            (string-append "&" cvar-name) ; Code is just the variable name
-;            (list     ; Allocate integer on the C stack
-;              (string-append 
-;                "make_int(" cvar-name ", " (number->string exp) ");")))))
      (c-code (string-append "obj_int2obj(" 
                (number->string exp) ")")))
     ((real? exp)
@@ -574,12 +641,15 @@
                        ((nan? exp) "(0./0.)")
                        ((infinite? exp) "(1./0.)")
                        (else
-                         (number->string exp)))))
+                         (number->string exp))))
+            (addr-op (if use-alloca "" "&"))
+            (c-make-macro (if use-alloca "alloca_double" "make_double"))
+           )
         (c-code/vars
-            (string-append "&" cvar-name) ; Code is just the variable name
+            (string-append addr-op cvar-name) ; Code is just the variable name
             (list     ; Allocate on the C stack
               (string-append 
-                "make_double(" cvar-name ", " num2str ");")))))
+                c-make-macro "(" cvar-name ", " num2str ");")))))
     ((boolean? exp) 
       (c-code (string-append
                 (if exp "boolean_t" "boolean_f"))))
@@ -587,20 +657,7 @@
      (c-code (string-append "obj_char2obj(" 
                (number->string (char->integer exp)) ")")))
     ((string? exp)
-      (let ((cvar-name (mangle (gensym 'c))))
+     (c-compile-string exp use-alloca))
-        (c-code/vars
-            (string-append "&" cvar-name) ; Code is just the variable name
-            (list     ; Allocate integer on the C stack
-              (string-append 
-                "make_utf8_string_with_len(" 
-                cvar-name 
-                ", " 
-                (->cstr exp) 
-                ", " 
-                (number->string (string-byte-length exp))
-                ", " 
-                (number->string (string-length exp))
-                ");")))))
 ;TODO: not good enough, need to store new symbols in a table so they can
 ;be inserted into the C program
     ((symbol? exp)
@@ -629,16 +686,29 @@
     (and (> len 0)
          (equal? end (substring str (- len 1) len)))))
 
+(define *use-alloca* #f)
+
+(define (set-use-alloca! v)
+  (set! *use-alloca* v))
+
+;; Use alloca() for stack allocations?
+(define (alloca? ast-id)
+  (or *use-alloca*
+      (let ((adbf:fnc (adb:get/default ast-id #f)))
+        (and adbf:fnc 
+             (adbf:calls-self? adbf:fnc)))))
+
 ;; c-compile-prim : prim-exp -> string -> string
-(define (c-compile-prim p cont)
+(define (c-compile-prim p cont ast-id)
-  (let* ((c-func 
+  (let* ((use-alloca? (alloca? ast-id))
+         (c-func 
            (if (prim:udf? p)
                (string-append
                  "((inline_function_type)
                    ((closure)"
                     (cgen:mangle-global p)
                  ")->fn)")
-               (prim->c-func p)))
+               (prim->c-func p use-alloca?)))
          ;; Following closure defs are only used for prim:cont? to
          ;; create a new closure for the continuation, if needed.
          ;;
@@ -661,12 +731,17 @@
                  (else "")))
          (tdata-comma (if (> (string-length tdata) 0) "," ""))
          (tptr-type (prim/c-var-pointer p))
-         (tptr-comma (if tptr-type ",&" ""))
+         (tptr-comma 
+          (cond
+           ((and tptr-type use-alloca?) ",")
+           (tptr-type ",&")
+           (else "")))
          (tptr (cond
                 (tptr-type (mangle (gensym 'local)))
                 (else "")))
          (tptr-decl
           (cond 
+            ((and tptr-type use-alloca?) (string-append "object " tptr " = alloca(sizeof(" tptr-type ")); "))
             (tptr-type (string-append tptr-type " " tptr "; "))
             (else "")))
          (c-var-assign 
@@ -676,7 +751,9 @@
                   (string-append 
                     (if (or (prim:cont? p) 
                             (equal? (prim/c-var-assign p) "object")
-                            (prim/c-var-pointer p)) ;; Assume returns object
+                            (prim/c-var-pointer p) ;; Assume returns object
+                            (prim->c-func-uses-alloca? p use-alloca?)
+                        )
                         "" 
                         "&")
                     cv-name)
@@ -719,7 +796,8 @@
         ;;
         (let ((cv-name (mangle (gensym 'c))))
            (c-code/vars
-            (if (prim:allocates-object? p)
+            (if (or (prim:allocates-object? p use-alloca?)
+                    (prim->c-func-uses-alloca? p use-alloca?))
                 cv-name ;; Already a pointer
                 (string-append "&" cv-name)) ;; Point to data
             (list
@@ -730,6 +808,29 @@
 ;; END primitives
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;; self-closure-call? :: sexp -> symbol -> integer -> boolean
+;;
+;; Determine whether we have a closure call of the form:
+;;  (%closure-ref
+;;     (cell-get (%closure-ref self$249 1))
+;;     0)
+;;
+;; Parameters:
+;; ast - S-expression to analyze
+;; self - Identifier for the function's "self" closure
+;; closure-index - Index of the function's "self" closure in outer closure
+(define (self-closure-call? ast self closure-index)
+  ;(trace:error `(JAE self-closure-call? ,ast ,self ,closure-index))
+  (and-let* (((tagged-list? '%closure-ref ast))
+             ((tagged-list? 'cell-get (cadr ast)))
+             (inner-cref (cadadr ast))
+             ((tagged-list? '%closure-ref inner-cref))
+             (equal? self (cadr inner-cref))
+             ((equal? 0 (caddr ast)))
+             ((equal? closure-index (caddr inner-cref)))
+            )
+    #t))
+
 ; c-compile-ref : ref-exp -> string
 (define (c-compile-ref exp)
   (c-code 
@@ -740,6 +841,7 @@
 ; c-compile-args : list[exp] (string -> void) -> string
 (define (c-compile-args args append-preamble prefix cont ast-id trace cps?)
   (letrec ((num-args 0)
+           (cp-lis '())
          (_c-compile-args 
           (lambda (args append-preamble prefix cont)
             (cond
@@ -747,17 +849,26 @@
               (c-code ""))
              (else
               ;(trace:debug `(c-compile-args ,(car args)))
-              (set! num-args (+ 1 num-args))
+              (let ((cp (c-compile-exp (car args) 
-              (c:append/prefix
+                          append-preamble cont ast-id trace cps?)))
-                prefix 
+                (set! num-args (+ 1 num-args))
-                (c-compile-exp (car args) 
+                (set! cp-lis (cons cp cp-lis))
-                  append-preamble cont ast-id trace cps?)
+                (c:append/prefix
-                (_c-compile-args (cdr args) 
+                  prefix 
-                  append-preamble ", " cont)))))))
+                  cp
-  (c:tuple/args
+                  (_c-compile-args (cdr args) 
-    (_c-compile-args args 
+                    append-preamble ", " cont))))))))
-      append-preamble prefix cont)
+  ;; Pass back a container with:
-    num-args)))
+  ;; - Appened body (string)
+  ;; - Appended allocs (string)
+  ;; - Number of args (numeric)
+  ;; - Remaining args - Actual CP objects (lists of body/alloc) from above
+  (append
+    (c:tuple/args
+      (_c-compile-args args 
+        append-preamble prefix cont)
+      num-args)
+    (reverse cp-lis))))
 
 ;; c-compile-app : app-exp (string -> void) -> string
 (define (c-compile-app exp append-preamble cont ast-id trace cps?)
@@ -839,12 +950,12 @@
                "\n"
                cgen-body ;; TODO: (c:body cgen) ;; TODO: re-assign function args, longer-term using temp variables
                "\n"
-               "goto loop;")))
+               "continue;")))
         )
          
         ((prim? fun)
          (let* ((c-fun 
-                 (c-compile-prim fun cont))
+                 (c-compile-prim fun cont ast-id))
                 (c-args
                  (c-compile-args args append-preamble "" "" ast-id trace cps?))
                 (num-args (length args))
@@ -904,6 +1015,7 @@
          (let* ((cfun (c-compile-args (list (car args)) append-preamble "  " cont ast-id trace cps?))
                 (this-cont (c:body cfun))
                 (cargs (c-compile-args (cdr args) append-preamble "  " this-cont ast-id trace cps?))
+                (raw-cargs (cdddr cargs)) ;; Same as above but with lists instead of appended strings
                 (num-cargs (c:num-args cargs)))
            (cond
              ((not cps?)
@@ -919,8 +1031,52 @@
               (set-c-call-arity! (c:num-args cargs))
               (let* ((wkf (well-known-lambda (car args)))
                      (fnc (if wkf (adb:get/default (ast:lambda-id wkf) #f) #f))
+                     (adbf:fnc (adb:get/default ast-id #f))
                     )
                 (cond
+                  ;; Handle recursive calls via iteration, if possible
+                  ((and adbf:fnc
+                        ;#f ;; TODO: temporarily disabled
+                        (adbf:calls-self? adbf:fnc)
+                        (self-closure-call? 
+                          fun 
+                          (car (adbf:all-params adbf:fnc))
+                          (adbf:self-closure-index adbf:fnc)
+                        )
+                    )
+                    (let* ((params (map mangle (cdr (adbf:all-params adbf:fnc))))
+                           (args (map car raw-cargs))
+                           (reassignments 
+                             ;; TODO: may need to detect cases where an arg is reassigned before
+                             ;; another one is assigned to that arg's old value, for example:
+                             ;;   a = 1, b = 2, c = a
+                             ;; In this case the code would need to assign to a temporary variable
+                             (apply string-append
+                              (map
+                                (lambda (param arg)
+                                  (cond
+                                    ((equal? param arg) "") ;; No need to reassign
+                                    (else
+                                      (string-append
+                                        param " = " arg ";\n"))))
+                                params
+                                args))))
+;(trace:error `(JAE ,fun ,ast-id ,params ,args (c:num-args cargs)))
+                    (c-code 
+                      (string-append
+                        (c:allocs->str (c:allocs cfun) "\n")
+                        (c:allocs->str (c:allocs cargs) "\n")
+                        reassignments
+                        ;; TODO: consider passing in a "top" instead of always calling alloca in macro below:
+                        "continue_or_gc" (number->string (c:num-args cargs))
+                        "(data,"
+                        (mangle (car (adbf:all-params adbf:fnc))) ;; Call back into self after GC
+                        (if (> (c:num-args cargs) 0) "," "")
+                        (string-join params ", ")
+                        ");"
+                      )))
+                  )
+                        
                   ((and wkf fnc
                         *optimize-well-known-lambdas*
                         (adbf:well-known fnc) ;; not really needed
@@ -1068,6 +1224,40 @@
                        (c-code "")
                        args)))
           exps))
+        ((equal? 'Cyc-local-set! fun)
+         ;:(trace:error `(JAE DEBUG Cyc-local-set ,exp))
+         (let ((val-exp (c-compile-exp (caddr exp) append-preamble cont ast-id trace cps?)))
+           (c-code/vars
+             (string-append (mangle (cadr exp)) " = " (c:body val-exp) ";")
+             (c:allocs val-exp)))
+           ;(c-code (string-append (mangle (cadr exp)) " = " (mangle (caddr exp)) ";"))
+        )
+        ((equal? 'let fun)
+         (let* ((vars/vals (cadr exp))
+                (body (caddr exp))
+                (vexps (foldr
+                        (lambda (var/val acc)
+                          (set-use-alloca! #t) ;; Force alloca to ensure safe c stack allocs
+                          ;; Join expressions; based on c:append 
+                          (let ((cp1 (c-compile-exp (cadr var/val) append-preamble cont ast-id trace cps?))
+                                (cp2 acc))
+                            (set-use-alloca! #f) ;; Revert flag
+                            (c-code/vars 
+                              (let ((cp1-body (c:body cp1)))
+                                (string-append cp1-body ";" (c:body cp2)))
+                              (append 
+                                (list (string-append "object " (mangle (car var/val)) ";"))
+                                (c:allocs cp1) 
+                                (c:allocs cp2)))))
+                        (c-code "")
+                        vars/vals))
+               (body-exp (c-compile-exp 
+                           body append-preamble cont ast-id trace cps?))
+              )
+          ;;(trace:error `(JAE DEBUG body ,body ,vars/vals ,exp))
+          (c:append vexps body-exp)
+         )
+        )
         (else
          (error `(Unsupported function application ,exp)))))))
 
@@ -1321,7 +1511,7 @@
 ;; Compile a reference to an element of a closure.
 (define (c-compile-closure-element-ref ast-id var idx)
   (with-fnc ast-id (lambda (fnc)
-    (trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc))
+    ;(trace:info `(c-compile-closure-element-ref ,ast-id ,var ,idx ,fnc))
     (cond
       ((and *optimize-well-known-lambdas*
             (adbf:well-known fnc)
@@ -1332,6 +1522,29 @@
         (string-append 
           "((closureN)" (mangle var) ")->elements[" idx "]"))))))
 
+;; Analyze closure members and assign index of the function's "self" closure, if found
+;; Parameters:
+;;   ast-fnc - Function to check for, in AST lambda form
+;;   closure-args - Members of the closure to scan
+(define (find-closure-assigned-var-index! ast-fnc closure-args)
+  (let ((index 0)
+        (fnc (adb:get/default (ast:lambda-id ast-fnc) #f)))
+    ;(trace:info `(find-closure-assigned-var-index! ,ast-fnc ,fnc ,closure-args))
+    (cond
+      ((and fnc 
+            (pair? (adbf:assigned-to-var fnc)))
+       (for-each
+        (lambda (arg)
+          (when (and (ref? arg) (member arg (adbf:assigned-to-var fnc)))
+            ;(trace:error `(JAE closure for ,(ast:lambda-id ast-fnc) self ref is index ,index))
+            (adbf:set-self-closure-index! fnc index)
+            (adb:set! (ast:lambda-id ast-fnc) fnc)
+          )
+          (set! index (+ index 1))
+        )
+        closure-args)
+      )
+      (else #f))))
 
 ;; c-compile-closure : closure-exp (string -> void) -> string
 ;;
@@ -1348,7 +1561,9 @@
 ;;    to one with the corresponding index so `lambda` can use them.
 ;;
 (define (c-compile-closure exp append-preamble cont ast-id trace cps?)
+  (find-closure-assigned-var-index! (closure->lam exp) (cdr exp))
   (let* ((lam (closure->lam exp))
+         (use-alloca? (alloca? ast-id))
          (free-vars
            (map
              (lambda (free-var)
@@ -1384,26 +1599,31 @@
              (car free-vars)
              (list))))
          (create-nclosure (lambda ()
-           (string-append
+           (let ((decl (if use-alloca?
-             "closureN_type " cv-name ";\n"
+                           (string-append "closureN_type * " cv-name " = alloca(sizeof(closureN_type));\n")
-             ;; Not ideal, but one more special case to type check call/cc
+                           (string-append "closureN_type " cv-name ";\n")))
-             (if call/cc?  "Cyc_check_proc(data, f);\n" "")
+                 (sep (if use-alloca? "->" "."))
-             cv-name ".hdr.mark = gc_color_red;\n "
+                )
-             cv-name ".hdr.grayed = 0;\n"
+             (string-append
-             cv-name ".tag = closureN_tag;\n "
+               decl
-             cv-name ".fn = (function_type)__lambda_" (number->string lid) ";\n"
+               ;; Not ideal, but one more special case to type check call/cc
-             cv-name ".num_args = " num-args-str ";\n"
+               (if call/cc?  "Cyc_check_proc(data, f);\n" "")
-             cv-name ".num_elements = " (number->string (length free-vars)) ";\n"
+               cv-name sep "hdr.mark = gc_color_red;\n "
-             cv-name ".elements = (object *)alloca(sizeof(object) * " 
+               cv-name sep "hdr.grayed = 0;\n"
-                     (number->string (length free-vars)) ");\n"
+               cv-name sep "tag = closureN_tag;\n "
-             (let loop ((i 0) 
+               cv-name sep "fn = (function_type)__lambda_" (number->string lid) ";\n"
-                        (vars free-vars))
+               cv-name sep "num_args = " num-args-str ";\n"
-               (if  (null? vars)
+               cv-name sep "num_elements = " (number->string (length free-vars)) ";\n"
-                 ""
+               cv-name sep "elements = (object *)alloca(sizeof(object) * " 
-                 (string-append 
+                       (number->string (length free-vars)) ");\n"
-                   cv-name ".elements[" (number->string i) "] = " 
+               (let loop ((i 0) 
-                           (car vars) ";\n"
+                          (vars free-vars))
-                   (loop (+ i 1) (cdr vars))))))))
+                 (if  (null? vars)
+                   ""
+                   (string-append 
+                     cv-name sep "elements[" (number->string i) "] = " 
+                             (car vars) ";\n"
+                     (loop (+ i 1) (cdr vars)))))))))
          (create-mclosure (lambda () 
            (let ((prefix 
                     (if macro?
@@ -1430,7 +1650,10 @@
       (create-object))
     (else
       (c-code/vars
-        (string-append "&" cv-name)
+        (if (and use-alloca?
+                 (> (length free-vars) 0))
+            cv-name
+            (string-append "&" cv-name))
         (list 
           (if (> (length free-vars) 0)
             (create-nclosure)
@@ -1484,10 +1707,15 @@
                (> (string-length tmp-ident) 3)
                (equal? "self" (substring tmp-ident 0 4))))
            (has-loop?
-             (and (not has-closure?) ;; Only top-level functions for now
+             (or
-                  (pair? trace)
+               (adbf:calls-self? (adb:get/default (ast:lambda-id exp) (adb:make-fnc)))
-                  (not (null? (cdr trace)))
+               ;; Older direct recursive logic
-                  (adbv:direct-rec-call? (adb:get (cdr trace)))))
+               (and (not has-closure?) ;; Only top-level functions for now
+                    (pair? trace)
+                    (not (null? (cdr trace)))
+                    (adbv:direct-rec-call? (adb:get (cdr trace))))
+             )
+           )
            (formals*
              (string-append
                 (if has-closure? 
@@ -1532,12 +1760,13 @@
                            (c-code 
                              ;; Only trace when entering initial defined function
                              (cond
-                               (has-closure? "")
+                               (has-closure?
+                                (if has-loop? "\n while(1) {\n" "")
+                               )
                                (else
                                  (string-append
                                    (st:->code trace)
-                                   ;; TODO: probably needs brackets afterwards...
+                                   (if has-loop? "\n while(1) {\n" "")
-                                   (if has-loop? "\nloop: {\n" "")
                                  ))))
                            body)
                          "  ")

scheme/cyclone/cps-opt-local-var-redux.scm

@@ -0,0 +1,415 @@
+;;;; Cyclone Scheme
+;;;; https://github.com/justinethier/cyclone
+;;;;
+;;;; Copyright (c) 2014-2018, Justin Ethier
+;;;; All rights reserved.
+;;;;
+;;;; This file is part of the cps-optimizations module.
+;;;;
+
+(cond-expand 
+  (program
+    (import (scheme base) 
+            (scheme write) 
+            (scheme cyclone ast) 
+            (scheme cyclone util) 
+            (scheme cyclone pretty-print))))
+
+;; Local variable reduction:
+;; Reduce given sexp by replacing certain lambda calls with a let containing
+;; local variables. Based on the way cyclone transforms code, this will
+;; typically be limited to if expressions embedded in other expressions.
+(define (opt:local-var-reduction sexp)
+  (define (scan exp)
+    ;(write `(DEBUG scan ,exp)) (newline)
+    (cond
+     ((ast:lambda? exp)
+      (ast:%make-lambda
+        (ast:lambda-id exp)
+        (ast:lambda-args exp)
+        (map scan (ast:lambda-body exp))
+        (ast:lambda-has-cont exp)))
+     ((quote? exp) exp)
+     ((const? exp) exp)
+     ((ref? exp) exp)
+     ((define? exp) 
+      `(define
+        ,(define->var exp)
+        ,@(map scan (define->exp exp))))
+     ((set!? exp)
+      `(set!
+         ,(scan (set!->var exp))
+         ,(scan (set!->exp exp))))
+     ((if? exp)       
+      `(if ,(scan (if->condition exp))
+           ,(scan (if->then exp))
+           ,(scan (if->else exp))))
+     ((app? exp)
+      (cond
+        ((and
+          (list? exp)
+          (ast:lambda? (car exp))
+          (equal? (length exp) 2)
+          (ast:lambda? (cadr exp))
+          (equal? 1 (length (ast:lambda-args (cadr exp))))
+          (lvr:local-tail-call-only? 
+            (ast:lambda-body (car exp)) 
+            (car (ast:lambda-args (car exp))))
+          ;(tagged-list? 'Cyc-seq (car (ast:lambda-body (cadr exp)))) ;; TODO: DEBUG line, remove this once it works!
+         )
+         ;;(write `(tail-call-only? passed for ,exp)) (newline)
+         ;;(write `(replace with ,(lvr:tail-calls->values 
+         ;;                         (car (ast:lambda-body (car exp)))
+         ;;                         (car (ast:lambda-args (car exp))))))
+         ;;(newline)
+;TODO: need to revisit this, may need to replace values with assignments to the "let" variable.
+;would need to be able to carry that through to cgen and assign properly over there...
+         (let* ((value (lvr:tail-calls->values
+                         (car (ast:lambda-body (car exp)))
+                         (car (ast:lambda-args (car exp)))
+                         (car (ast:lambda-args (cadr exp)))
+                       ))
+                (var (car (ast:lambda-args (cadr exp))))
+                (body (ast:lambda-body (cadr exp)))
+                (av (adb:get/default var #f)) ;; Set to #f if unit testing
+                (ref-count
+                  (if av
+                      (adbv:ref-count av)
+                      1)) ;; Dummy value
+                )
+            (if (and (> ref-count 0)  ;; 0 ==> local var is never used
+                     value)
+                `(let ((,var ,value))
+                  ,@body)
+                (map scan exp)) ;; failsafe
+        ))
+        (else
+          (map scan exp))))
+     (else (error "unknown expression type: " exp))
+  ))
+  (scan sexp))
+
+;; Local variable reduction helper:
+;; Scan sexp to determine if sym is only called in a tail-call position
+(define (lvr:local-tail-call-only? sexp sym)
+  (call/cc
+    (lambda (return)
+      (define (scan exp fail?)
+        ;;(write `(DEBUG lvr:local-tail-call-only? scan ,exp)) (newline)
+        (cond
+         ((ast:lambda? exp)
+          (return #f)) ;; Could be OK if not ref'd...
+         ((quote? exp) exp)
+         ((const? exp) exp)
+         ((ref? exp) 
+          (if (equal? exp sym)
+              (return #f))) ;; Assume not a tail call
+         ((define? exp) 
+          (return #f)) ;; Fail fast
+         ((set!? exp)
+          (return #f)) ;; Fail fast
+         ((if? exp)       
+          (scan (if->condition exp) #t) ;; fail if found under here
+          (scan (if->then exp) fail?)
+          (scan (if->else exp) fail?))
+         ((app? exp)
+          (cond
+;;; TODO: may need to check for prim:cont? and abort accordingly
+;; check out code generated for scheme/cyclone/util.sld WRT symbol->string
+;; cannot proceed with this since by definition these functions require CPS
+            ((and (prim? (car exp))
+                  (prim:cont? (car exp)))
+             (return #f))
+            ((and (equal? (car exp) sym)
+                  (not fail?))
+             (map (lambda (e) (scan e fail?)) (cdr exp))) ;; Sym is OK, skip
+            (else
+             (map (lambda (e) (scan e fail?)) exp))))
+         (else exp)))
+      (scan sexp #f)
+      (return #t))))
+
+;; Local variable reduction helper:
+;; Transform all tail calls of sym in the sexp to just the value passed
+(define (lvr:tail-calls->values sexp sym assign-sym)
+  (call/cc
+    (lambda (return)
+      (define (scan exp)
+        ;;(write `(DEBUG scan ,exp)) (newline)
+        (cond
+         ((ast:lambda? exp)
+          (return #f)) ;; Could be OK if not ref'd...
+         ((quote? exp) exp)
+         ((const? exp) exp)
+         ((ref? exp) 
+          (if (equal? exp sym)
+              (return #f))) ;; Assume not a tail call
+         ((define? exp) 
+          (return #f)) ;; Fail fast
+         ((set!? exp)
+          (return #f)) ;; Fail fast
+         ((if? exp)       
+          `(if ,(if->condition exp) 
+               ,(scan (if->then exp))
+               ,(scan (if->else exp))))
+         ((app? exp)
+          (cond
+            ((and (equal? (car exp) sym)
+                  (= (length exp) 2)
+             )
+             `(Cyc-local-set! ,assign-sym ,(cadr exp)))
+            (else
+             ;; TODO: can we be smarter? Consider example from match.scm match-gen-or-step
+             (return #f))))
+         (else exp)))
+      (cond
+        ;((or (quote? sexp) 
+        ;     (const? sexp))
+        ; ;; Special case, set the value directly
+        ; ;; TODO: this is a bit of a hack, may way to re-think how this
+        ; ;; whole module works at some point, but for now this works.
+        ; (return 
+        ;   `(Cyc-local-set! ,assign-sym ,sexp)))
+        (else
+          (return
+            (scan sexp)))))))
+
+(cond-expand
+  (program
+    (define sexp
+'(
+ (define zunda
+   ((lambda
+      (k$1057 first-row-perm$61$668 mat$62$669)
+      (first-row-perm$61$668
+        (lambda
+          (first-row$65$670)
+          ((lambda
+             (number-of-cols$68$671)
+             ((lambda
+                (make-row->func$71$672)
+                (first-row-perm$61$668
+                  (lambda
+                    (r$1062)
+                    (make-row->func$71$672
+                      (lambda
+                        (r$1063)
+                        (make-row->func$71$672
+                          (lambda
+                            (r$1064)
+                            (zebra k$1057
+                                   r$1062
+                                   r$1063
+                                   r$1064
+                                   (cdr mat$62$669)
+                                   number-of-cols$68$671))
+                          -1
+                          1))
+                      1
+                      -1))
+                  'child))
+              (lambda
+                (k$1066 if-equal$76$674 if-different$77$675)
+                (k$1066
+                  (lambda
+                    (k$1067 row$78$676)
+                    ((lambda
+                       (vec$79$677)
+                       ((lambda
+                          (first$85$679 row$86$680)
+                          ((lambda
+                             (lp$80$87$681)
+                             ((lambda
+                                (lp$80$87$681)
+                                (Cyc-seq
+                                  (set!
+                                    lp$80$87$681
+                                    (lambda
+                                      (k$1073 i$88$682 first$89$683 row$90$684)
+                                      (if (Cyc-fast-eq
+                                            i$88$682
+                                            number-of-cols$68$671)
+                                        (k$1073
+                                          (Cyc-fast-eq
+                                            i$88$682
+                                            number-of-cols$68$671))
+                                        ((lambda
+                                           (k$1080)
+                                           (if (Cyc-fast-eq
+
+                                                 (car first$89$683)
+                                                 (car row$90$684))
+                                             (k$1080 if-equal$76$674)
+                                             (k$1080 if-different$77$675)))
+                                         (lambda
+                                           (r$1079)
+                                           (Cyc-seq
+                                             (vector-set!
+                                               vec$79$677
+                                               i$88$682
+                                               r$1079)
+                                             ((cell-get lp$80$87$681)
+                                              k$1073
+                                              (Cyc-fast-plus i$88$682 1)
+                                              (cdr first$89$683)
+                                              (cdr row$90$684))))))))
+                                  ((cell-get lp$80$87$681)
+                                   (lambda
+                                     (r$1069)
+                                     (k$1067
+                                       (lambda
+                                         (k$1070 i$92$686)
+                                         (k$1070
+                                           (vector-ref vec$79$677 i$92$686)))))
+                                   0
+                                   first$85$679
+                                   row$86$680)))
+                              (cell lp$80$87$681)))
+                           #f))
+                        first-row$65$670
+                        row$78$676))
+                     (make-vector number-of-cols$68$671)))))))
+           (length first-row$65$670)))
+        'now))))
+  (define *num-passed* 0) 
+ (define write-to-string
+   (lambda
+     (k$3086 x$892$1775)
+     (call-with-output-string
+       k$3086
+       (lambda
+         (k$3088 out$893$1776)
+         ((lambda
+            (x$895$1777)
+            ((lambda
+               (wr$896$1778)
+               (Cyc-seq
+                 (set! wr$896$1778
+                   (lambda
+                     (k$3091 x$897$1779)
+                     (if (pair? x$897$1779)
+                       ((lambda
+                          (k$3112)
+                          (if (symbol? (car x$897$1779))
+                            (if (pair? (cdr x$897$1779))
+                              (if (null? (cddr x$897$1779))
+                                (k$3112
+                                  (assq (car x$897$1779)
+                                        '((quote . "'")
+                                          (quasiquote . "`")
+                                          (unquote . ",")
+                                          (unquote-splicing . ",@"))))
+                                (k$3112 #f))
+                              (k$3112 #f))
+                            (k$3112 #f)))
+                        (lambda
+                          (tmp$900$902$1780)
+                          (if tmp$900$902$1780
+                            ((lambda
+                               (s$903$1781)
+                               (display
+                                 (lambda
+                                   (r$3094)
+                                   (wr$896$1778 k$3091 (cadr x$897$1779)))
+                                 (cdr s$903$1781)
+                                 out$893$1776))
+                             tmp$900$902$1780)
+                            (display
+                              (lambda
+                                (r$3097)
+                                (wr$896$1778
+                                  (lambda
+                                    (r$3098)
+                                    ((lambda
+                                       (lp$907$1783)
+                                       (Cyc-seq
+                                         (set! lp$907$1783
+                                           (lambda
+                                             (k$3103 ls$908$1784)
+                                             (if (pair? ls$908$1784)
+                                               (display
+                                                 (lambda
+                                                   (r$3105)
+                                                   (wr$896$1778
+                                                     (lambda
+                                                       (r$3106)
+                                                       (lp$907$1783
+                                                         k$3103
+                                                         (cdr ls$908$1784)))
+                                                     (car ls$908$1784)))
+                                                 " "
+                                                 out$893$1776)
+                                               (if (null? ls$908$1784)
+                                                 (k$3103 #f)
+                                                 (display
+                                                   (lambda
+                                                     (r$3110)
+                                                     (write k$3103
+                                                            ls$908$1784
+                                                            out$893$1776))
+                                                   " . "
+                                                   out$893$1776)))))
+                                         (lp$907$1783
+                                           (lambda
+                                             (r$3099)
+                                             (display k$3091 ")" out$893$1776))
+                                           (cdr x$897$1779))))
+                                     #f))
+                                  (car x$897$1779)))
+                              "("
+                              out$893$1776))))
+                       (write k$3091 x$897$1779 out$893$1776))))
+                 (wr$896$1778 k$3088 x$895$1777)))
+             #f))
+          x$892$1775)))))
+ (define match-gen-or-step
+   (lambda
+     (k$14021
+       expr$3499$3540$3621$9398
+       rename$3500$3541$3622$9399
+       compare$3501$3542$3623$9400)
+     ((lambda
+        (v.1$3507$3599$3659$9436)
+        ((lambda
+           (k$14141)
+           (if (pair? v.1$3507$3599$3659$9436)
+             (Cyc-seq
+               (car v.1$3507$3599$3659$9436)
+               (if (pair? (cdr v.1$3507$3599$3659$9436))
+                 (if (null? (car (cdr v.1$3507$3599$3659$9436)))
+                   (if (pair? (cdr (cdr v.1$3507$3599$3659$9436)))
+                     (Cyc-seq
+                       (car (cdr (cdr v.1$3507$3599$3659$9436)))
+                       (if (pair? (cdr (cdr (cdr v.1$3507$3599$3659$9436))))
+                         (Cyc-seq
+                           (car (cdr (cdr (cdr v.1$3507$3599$3659$9436))))
+                           (if (pair? (cdr (cdr (cdr (cdr v.1$3507$3599$3659$9436)))))
+                             (Cyc-seq
+                               (cdr (cdr (cdr (cdr (cdr v.1$3507$3599$3659$9436)))))
+                               (k$14141
+                                 (cons (car (cdr (cdr (cdr (cdr v.1$3507$3599$3659$9436)))))
+                                       #f)))
+                             (k$14141 #f)))
+                         (k$14141 #f)))
+                     (k$14141 #f))
+                   (k$14141 #f))
+                 (k$14141 #f)))
+             (k$14141 #f)))
+         (lambda
+           (tmp$3544$3546$3624$9401)
+           (list
+            (lambda (r$14022) (k$14021 (car r$14022)))))))
+      (cdr expr$3499$3540$3621$9398))))
+ )
+
+)
+
+    ;(pretty-print
+    ;  (ast:ast->pp-sexp
+    ;    (ast:sexp->ast sexp)))
+    
+    (pretty-print
+      (ast:ast->pp-sexp
+        (opt:local-var-reduction (ast:sexp->ast sexp)))
+    )
+    ))

scheme/cyclone/cps-optimizations.sld

@@ -34,6 +34,7 @@
       opt:contract
       opt:inline-prims
       opt:beta-expand
+      opt:local-var-reduction
       adb:clear!
       adb:get
       adb:get/default
@@ -54,6 +55,8 @@
       adbv:set-global!
       adbv:defined-by 
       adbv:set-defined-by!
+      adbv:mutated-by-set? 
+      adbv:set-mutated-by-set!
       adbv:reassigned? 
       adbv:set-reassigned!
       adbv:assigned-value
@@ -83,13 +86,17 @@
       adbf:simple adbf:set-simple!
       adbf:all-params adbf:set-all-params!
       adbf:unused-params adbf:set-unused-params!
+      adbf:assigned-to-var adbf:set-assigned-to-var!
       adbf:side-effects adbf:set-side-effects!
       adbf:well-known adbf:set-well-known!
       adbf:cgen-id adbf:set-cgen-id!
       adbf:closure-size adbf:set-closure-size!
+      adbf:self-closure-index adbf:set-self-closure-index!
+      adbf:calls-self? adbf:set-calls-self!
       with-fnc
       with-fnc!
   )
+  (include "cps-opt-local-var-redux.scm")
   (begin
     ;; The following two defines allow non-CPS functions to still be considered
     ;; for certain inlining optimizations.
@@ -128,6 +135,7 @@
         defines-lambda-id
         const const-value  
         ref-count ref-by
+        mutated-by-set
         reassigned assigned-value 
         app-fnc-count app-arg-count
         inlinable mutated-indirectly
@@ -145,6 +153,7 @@
       (const-value adbv:const-value adbv:set-const-value!)
       (ref-count adbv:ref-count adbv:set-ref-count!)
       (ref-by adbv:ref-by adbv:set-ref-by!)
+      (mutated-by-set adbv:mutated-by-set? adbv:set-mutated-by-set!)
       ;; TODO: need to set reassigned flag if variable is SET, however there is at least
       ;; one exception for local define's, which are initialized to #f and then assigned
       ;; a single time via set
@@ -202,6 +211,7 @@
         #f  ; const-value  
         0   ; ref-count 
         '() ; ref-by             
+        #f  ; mutated-by-set
         #f  ; reassigned 
         #f  ; assigned-value 
         0   ; app-fnc-count 
@@ -224,6 +234,9 @@
        side-effects
        well-known
        cgen-id
+       closure-size
+       self-closure-index
+       calls-self
       )
       adb:function?
       (simple adbf:simple adbf:set-simple!)
@@ -241,6 +254,10 @@
       (cgen-id adbf:cgen-id adbf:set-cgen-id!)
       ;; Number of elements in the function's closure
       (closure-size adbf:closure-size adbf:set-closure-size!)
+      ;; Index of the function in its closure, if applicable
+      (self-closure-index adbf:self-closure-index adbf:set-self-closure-index!)
+      ;; Does this function call itself?
+      (calls-self adbf:calls-self? adbf:set-calls-self!)
     )
     (define (adb:make-fnc)
       (%adb:make-fnc 
@@ -252,6 +269,8 @@
        #f   ;; well-known
        #f   ;; cgen-id
        -1   ;; closure-size
+       -1   ;; self-closure-index
+       #f   ;; calls-self
       ))
 
     ;; A constant value that cannot be mutated
@@ -341,7 +360,8 @@
                (lambda-body (lambda->exp define-body))
                (fv (filter 
                      (lambda (v)
-                       (not (prim? v)))
+                       (and (not (equal? 'Cyc-seq v))
+                            (not (prim? v))))
                      (free-vars expr)))
               )
 ;(trace:error `(JAE DEBUG ,(define->var expr) ,fv))
@@ -543,6 +563,7 @@
          (with-var! (set!->var exp) (lambda (var)
            (if (adbv:assigned-value var)
                (adbv:set-reassigned! var #t))
+           (adbv:set-mutated-by-set! var #t)
            (adbv-set-assigned-value-helper! (set!->var exp) var (set!->exp exp))
            (adbv:set-ref-count! var (+ 1 (adbv:ref-count var)))
            (adbv:set-ref-by! var (cons lid (adbv:ref-by var)))
@@ -568,7 +589,10 @@
          ;; Identify indirect mutations. That is, the result of a function call
          ;; is what is mutated
          (cond
-          ((and (prim:mutates? (car exp)))
+          ((and (prim:mutates? (car exp))
+                ;; loop3-dev WIP step #1 - do not immediately reject these prims
+                ;(not (member (car exp) '(vector-set!))) ;; TODO: experimental
+           )
            (let ((e (cadr exp)))
             (when (ref? e)
               (with-var e (lambda (var)
@@ -973,11 +997,7 @@
                     (cdr exp)
                     (ast:lambda-formals->list (car exp)))
                   (or
-                    ; Issue #172 - Cannot assume that just because a primitive 
+                    (prim-calls-inlinable? (cdr exp))
-                    ; deals with immutable objects that it is safe to inline.
-                    ; A (set!) could still mutate variables the primitive is
-                    ; using, causing invalid behavior.
-                    ;(prim-calls-inlinable? (cdr exp))
 
                     ;; Testing - every arg only used once
                     ;(and
@@ -1070,6 +1090,25 @@
                   ;; Could not inline
                   (map (lambda (e) (opt:inline-prims e scope-sym refs)) exp)))
             )) ;;
+            ;; Lambda with a parameter that is never used; sequence code instead to avoid lambda
+            ((and (ast:lambda? (car exp))
+                  (every
+                    (lambda (arg)
+                      (or (not (prim-call? arg))
+                          (not (prim:cont? (car arg)))))
+                    (cdr exp))
+                  (every
+                    (lambda (param)
+                      (with-var param (lambda (var)
+                        (null? (adbv:ref-by var)))))
+                    (ast:lambda-formals->list (car exp)))
+             )
+             (opt:inline-prims 
+               `(Cyc-seq 
+                  ,@(cdr exp)
+                  ,@(ast:lambda-body (car exp))) 
+               scope-sym 
+               refs))
             (else
               (map (lambda (e) (opt:inline-prims e scope-sym refs)) exp))))
           (else 
@@ -1131,7 +1170,21 @@
     (define (prim-calls-inlinable? prim-calls)
       (every
         (lambda (prim-call)
-          (prim:immutable-args/result? (car prim-call)))
+          (and 
+            (prim:immutable-args/result? (car prim-call))
+            ; Issue #172 - Cannot assume that just because a primitive 
+            ; deals with immutable objects that it is safe to inline.
+            ; A (set!) could still mutate variables the primitive is
+            ; using, causing invalid behavior.
+            ;
+            ; So, make sure none of the args is mutated via (set!)
+            (every
+              (lambda (arg)
+                (or (not (ref? arg))
+                    (with-var arg (lambda (var)
+                      (not (adbv:mutated-by-set? var))))))
+              (cdr prim-call)))
+          )
         prim-calls))
 
     ;; Check each pair of primitive call / corresponding lambda arg,
@@ -1209,7 +1262,7 @@
           ((member exp args)
            (set-car! arg-used #t))
           ((member exp ivars)
-           ;;(trace:error `(inline-ok? return #f ,exp ,ivars ,args))
+           ;(trace:error `(inline-ok? return #f ,exp ,ivars ,args))
            (return #f))
           (else 
            #t)))
@@ -1245,7 +1298,16 @@
               (if (not (ref? e))
                   (inline-ok? e ivars args arg-used return)))
             (reverse (cdr exp))))
-          (else
+          ;; loop3-dev WIP step #2 - some args can be safely ignored
+          ;((and (prim? (car exp))
+          ;      (prim:mutates? (car exp))
+          ;      (member (car exp) '(vector-set!))
+          ; )
+          ; ;; with vector-set, only arg 1 (the vector) is actually mutated
+          ; ;; TODO: is this always true? do we have problems with self-recursive vecs??
+          ; (inline-ok? (cadr exp) ivars args arg-used return) 
+          ;)
+         (else
            (for-each
             (lambda (e)
               (inline-ok? e ivars args arg-used return))
@@ -1568,6 +1630,7 @@
       (analyze exp -1 -1) ;; Top-level is lambda ID -1
       (analyze2 exp) ;; Second pass
       (analyze:find-inlinable-vars exp '()) ;; Identify variables safe to inline
+      (analyze:find-recursive-calls2 exp)
     )
 
     ;; NOTES:
@@ -1632,6 +1695,9 @@
           (else 
             (loop (cdr lst) (+ i 1))))))
 
+(define (let->vars exp)
+  (map car (cadr exp)))
+
 (define (closure-convert exp globals . opts)
  (let ((optimization-level 2))
    (if (pair? opts)
@@ -1652,7 +1718,7 @@
             (body  (ast:lambda-body exp))
             (new-free-vars 
               (difference 
-                (difference (free-vars body) (ast:lambda-formals->list exp))
+                (difference (free-vars body) (cons 'Cyc-seq (cons 'Cyc-local-set! (ast:lambda-formals->list exp))))
                 globals))
             (formals (list->lambda-formals
                        (cons new-self-var (ast:lambda-formals->list exp))
@@ -1688,6 +1754,22 @@
           ,@(map cc (cdr exp)))) ;; TODO: need to splice?
     ((set!? exp)  `(set! ,(set!->var exp)
                          ,(cc (set!->exp exp))))
+    ;; Special case now with local var redux
+    ((tagged-list? 'let exp) 
+     `(let 
+        ,(map 
+          (lambda (var/val)
+            (let ((var (car var/val))
+                  (val (cadr var/val)))
+            `(,var ,(cc val))))
+          (cadr exp))
+        ,(convert
+            (caddr exp) 
+            self-var 
+            ;; Do not closure convert the let's variables because
+            ;; the previous code guarantees they are locals
+            (filter (lambda (v) (not (member v (let->vars exp)))) free-var-lst)))
+    )
     ((lambda? exp)   (error `(Unexpected lambda in closure-convert ,exp)))
     ((if? exp)  `(if ,@(map cc (cdr exp))))
     ((cell? exp)       `(cell ,(cc (cell->value exp))))
@@ -1698,6 +1780,15 @@
      (let ((fn (car exp))
            (args (map cc (cdr exp))))
        (cond
+         ;TODO: what about application of cyc-seq? does this only occur as a nested form? can we combine here or earlier??
+         ;      I think that is what is causing cc printing to explode exponentially!
+         ;((tagged-list? 'Cyc-seq fnc)
+        ; (foldl (lambda (sexp acc) (cons sexp acc)) '() (reverse '(a b c (cyc-seq 1) (cyc-seq 2 ((cyc-seq 3))))))
+        ; TODO: maybe just call a function to 'flatten' seq's
+         ((equal? 'Cyc-seq fn)
+          `(Cyc-seq ,@args))
+         ((equal? 'Cyc-local-set! fn)
+          `(Cyc-local-set! ,@args))
          ((ast:lambda? fn)
           (cond
             ;; If the lambda argument is not used, flag so the C code is 
@@ -1725,7 +1816,7 @@
               (let* ((body  (ast:lambda-body fn))
                      (new-free-vars 
                        (difference
-                         (difference (free-vars body) (ast:lambda-formals->list fn))
+                         (difference (free-vars body) (cons 'Cyc-seq (cons 'Cyc-local-set! (ast:lambda-formals->list fn))))
                          globals))
                      (new-free-vars? (> (length new-free-vars) 0)))
                   (if new-free-vars?
@@ -1992,6 +2083,98 @@
           exp))
 )
 
+;; Does given symbol refer to a recursive call to given lambda ID?
+(define (rec-call? sym lid)
+  (cond
+   ((ref? sym)
+    (let ((var (adb:get/default sym #f)))
+      ;(trace:info 
+      ;  `(rec-call? ,sym ,lid
+      ;       ;; TODO: crap, these are not set yet!!!
+      ;       ;; may need to consider keeping out original version of find-recursive-calls and
+      ;       ;; adding a new version that does a deeper analysis
+      ;       ,(if var (not (adbv:reassigned? var)) #f)
+      ;       ,(if var (adbv:assigned-value var) #f)
+      ;       ;,((ast:lambda? var-lam))
+      ;       ,(adb:get/default lid #f)
+      ;       )
+      ;     )
+      (and-let* (
+                 ((not (equal? var #f)))
+                 ((not (adbv:reassigned? var)))
+                 (var-lam (adbv:assigned-value var))
+                 ((ast:lambda? var-lam))
+                 (fnc (adb:get/default lid #f))
+                )
+        ;(trace:info `(equal? ,lid ,(ast:lambda-id var-lam)))
+        (equal? lid (ast:lambda-id var-lam)))))
+   (else
+    #f)))
+
+;; Same as the original function, but this one is called at the end of analysis and 
+;; uses data that was previously not available.
+;;
+;; The reason for having two versions of this is that the original is necessary for
+;; beta expansion (and must remain, at least for now) and this one will provide useful
+;; data for code generation.
+;;
+;; TODO: is the above true? not so sure anymore, need to verify that, look at optimize-cps
+(define (analyze:find-recursive-calls2 exp)
+
+  (define (scan exp def-sym lid)
+    ;(trace:info `(analyze:find-recursive-calls2 scan ,def-sym ,exp ,lid))
+    (cond
+     ((ast:lambda? exp)
+      (for-each
+        (lambda (e)
+          (scan e def-sym (ast:lambda-id exp)))
+        (ast:lambda-body exp)))
+     ((quote? exp) exp)
+     ((const? exp) exp)
+     ((ref? exp) 
+      exp)
+     ((define? exp) #f) ;; TODO ??
+     ((set!? exp)
+      (for-each
+        (lambda (e)
+          (scan e def-sym lid))
+        (cdr exp))
+     )
+     ((if? exp)       
+      (scan (if->condition exp) def-sym lid)
+      (scan (if->then exp) def-sym lid)
+      (scan (if->else exp) def-sym lid))
+     ((app? exp)
+      (when (or ;(equal? (car exp) def-sym) TODO: def-sym is obsolete, remove it
+                (rec-call? (car exp) lid))
+        ;(trace:info `("recursive call" ,exp))
+        (with-fnc! lid (lambda (fnc)
+          (adbf:set-calls-self! fnc #t)))
+        (with-var! (car exp) (lambda (var)
+          (adbv:set-self-rec-call! var #t))))
+      (for-each
+        (lambda (e)
+          (scan e def-sym lid))
+        exp)
+     )
+     (else #f)))
+
+  ;; TODO: probably not good enough, what about recursive functions that are not top-level??
+;TODO: need to address those now, I think we have the support now via (rec-call?)
+  (if (pair? exp)
+      (for-each
+        (lambda (exp)
+          ;(trace:info `(analyze:find-recursive-calls ,exp))
+          (and-let* (((define? exp))
+                      (def-exps (define->exp exp))
+                     ((vector? (car def-exps)))
+                     ((ast:lambda? (car def-exps)))
+                     (id (ast:lambda-id (car def-exps)))
+                     )
+           (scan (car (ast:lambda-body (car def-exps))) (define->var exp) id)
+        ))
+        exp))
+)
 ;; well-known-lambda :: symbol -> Either (AST Lambda | Boolean)
 ;; Does the given symbol refer to a well-known lambda?
 ;; If so the corresponding lambda object is returned, else #f.

scheme/cyclone/primitives.sld

@@ -17,6 +17,7 @@
     ;; TODO: replace w/list that cannot be precomputed: precompute-prim-app?
     prim-call?
     prim->c-func
+    prim->c-func-uses-alloca?
     prim/data-arg?
     prim/c-var-pointer
     prim/c-var-assign
@@ -457,7 +458,38 @@
     (define (prim-call? exp)
       (and (list? exp) (prim? (car exp))))
 
-    (define (prim->c-func p)
+    (define (prim->c-func-uses-alloca? p use-alloca?)
+      (and
+        use-alloca?
+        (member 
+           p 
+          '(cons
+            Cyc-fast-list-1
+            Cyc-fast-list-2
+            Cyc-fast-list-3
+            Cyc-fast-list-4
+            cell))))
+
+    (define (prim->c-func p use-alloca?)
+      (cond
+         (use-alloca?
+          ;; Special case, when this flag is set the compiler is requesting a
+          ;; primitive that will allocate data, so any new objects must be
+          ;; created via alloca or such, and cannot be declared as stack vars.
+          ;; This is to support C loops in place of recursion.
+          (cond
+            ((eq? p 'cons)            "alloca_pair")
+            ((eq? p 'Cyc-fast-list-1) "alloca_list_1")
+            ((eq? p 'Cyc-fast-list-2) "alloca_list_2")
+            ((eq? p 'Cyc-fast-list-3) "alloca_list_3")
+            ((eq? p 'Cyc-fast-list-4) "alloca_list_4")
+            ((eq? p 'cell)            "alloca_cell")
+            (else
+              (_prim->c-func p))))
+         (else
+           (_prim->c-func p))))
+
+    (define (_prim->c-func p)
       (cond
          ((eq? p 'Cyc-global-vars)       "Cyc_get_global_variables")
          ((eq? p 'Cyc-get-cvar)          "Cyc_get_cvar")
@@ -876,9 +908,10 @@
     ;; Does primitive allocate an object?
     ;; TODO: these are the functions that are defined via macros. This method
     ;; is obsolete and should be replaced by prim:cont? functions over time.
-    (define (prim:allocates-object? exp)
+    (define (prim:allocates-object? exp use-alloca?)
         (and  (prim? exp)
-              (member exp '())))
+              use-alloca?
+              (member exp '(cons))))
     
     ;; Does the primitive only accept/return immutable objects?
     ;; This is useful during optimization

scheme/cyclone/transforms.sld

@@ -623,6 +623,7 @@
 
 ; free-vars : exp -> sorted-set[var]
 (define (free-vars ast . opts)
+  (define let-vars '())
   (define bound-only? 
     (and (not (null? opts))
          (car opts)))
@@ -636,7 +637,10 @@
       ((const? exp)    '())
       ((prim? exp)     '())    
       ((quote? exp)    '())    
-      ((ref? exp)      (if bound-only? '() (list exp)))
+      ((ref? exp)      
+       (if (member exp let-vars)
+           '()
+           (if bound-only? '() (list exp))))
       ((lambda? exp)   
         (difference (reduce union (map search (lambda->exp exp)) '())
                     (lambda-formals->list exp)))
@@ -648,6 +652,9 @@
       ((define-c? exp) (list (define->var exp)))
       ((set!? exp)     (union (list (set!->var exp)) 
                               (search (set!->exp exp))))
+      ((tagged-list? 'let exp)
+       (set! let-vars (append (map car (cadr exp)) let-vars))
+       (search (cdr exp)))
       ; Application:
       ((app? exp)       (reduce union (map search exp) '()))
       (else             (error "unknown expression: " exp))))
@@ -776,6 +783,9 @@
     
     ; Application:
     ((app? exp)
+     ;; Easy place to clean up nested Cyc-seq expressions
+     (when (tagged-list? 'Cyc-seq exp)
+           (set! exp (flatten-sequence exp)))
      (let ((result (map (lambda (e) (wrap-mutables e globals)) exp)))
        ;; This code can eliminate a lambda definition. But typically
        ;; the code that would have such a definition has a recursive
@@ -806,6 +816,42 @@
        result))
     (else            (error "unknown expression type: " exp))))
 
+;; Flatten a list containing subcalls of a given symbol.
+;; For example, the expression: 
+;;
+;;  '(Cyc-seq
+;;         (set! b '(#f . #f))
+;;         (Cyc-seq
+;;           (set-car!  a 1)
+;;           (Cyc-seq
+;;             (set-cdr!  a '(2))
+;;             ((fnc a1 a2 a3)))))
+;;
+;; becomes:
+;;
+;;  '(Cyc-seq
+;;     (set! b '(#f . #f))
+;;     (set-car! a 1)
+;;     (set-cdr! a '(2))
+;;     ((fnc a1 a2 a3)))
+;;
+(define (flatten-sequence sexp)
+  (define (flat sexp acc)
+    (cond
+      ((not (pair? sexp)) ;; Stop at end of sexp
+       acc)
+      ((and (tagged-list? 'Cyc-seq (car sexp))) ;; Flatten nexted sequences
+        (flat (cdar sexp) acc))
+      ((and (ref? (car sexp)) ;; Remove unused identifiers
+            (not (equal? 'Cyc-seq (car sexp))))
+        (flat (cdr sexp) acc))
+      (else ;;(pair? sexp)
+        (flat (cdr sexp) (cons (car sexp) acc))))
+  )
+  (reverse
+    (flat sexp '())))
+
+
 ;; Alpha conversion
 ;; (aka alpha renaming)
 ;;

test-eval-compilation.scm

@@ -1,22 +0,0 @@
-;; A temporary test file
-(import (scheme base) (scheme write))
-
-(define (analyze . opts)
-  (write 'test))
-
-(define (analyze-if exp a-env rename-env local-renamed)
-  (let ((pproc (analyze (if-predicate exp) a-env rename-env local-renamed))
-        (cproc (analyze (if-consequent exp) a-env rename-env local-renamed))
-        (aproc (analyze (if-alternative exp) a-env rename-env local-renamed)))
-    (lambda (env)
-      (if (pproc env)
-          (cproc env)
-          (aproc env)))))
-(define (if-predicate exp) (cadr exp))
-(define (if-consequent exp) (caddr exp))
-(define (if-alternative exp)
-  (if (not (null? (cdddr exp))) ;; TODO: add (not) support
-      (cadddr exp)
-      #f))
-
-(write (analyze-if 'a 'b 'c 'd))

test-matrix.scm

@@ -0,0 +1,881 @@
+;;; MATRIX -- Obtained from Andrew Wright.
+
+(import (scheme base) (scheme read) (scheme write) (scheme time))
+
+;;;; We need R6RS div and mod for this benchmark.
+;
+;(define (div x y)
+;  (cond ((and (exact-integer? x)
+;              (exact-integer? y)
+;              (>= x 0))
+;         (quotient x y))
+;        ((< y 0)
+;         ;; x < 0, y < 0
+;         (let* ((q (quotient x y))
+;                (r (- x (* q y))))
+;           (if (= r 0)
+;               q
+;               (+ q 1))))
+;        (else
+;         ;; x < 0, y > 0
+;         (let* ((q (quotient x y))
+;                (r (- x (* q y))))
+;           (if (= r 0)
+;               q
+;               (- q 1))))))
+;
+;(define (mod x y)
+;  (cond ((and (exact-integer? x)
+;              (exact-integer? y)
+;              (>= x 0))
+;         (remainder x y))
+;        ((< y 0)
+;         ;; x < 0, y < 0
+;         (let* ((q (quotient x y))
+;                (r (- x (* q y))))
+;           (if (= r 0)
+;               0
+;               (- r y))))
+;        (else
+;         ;; x < 0, y > 0
+;         (let* ((q (quotient x y))
+;                (r (- x (* q y))))
+;           (if (= r 0)
+;               0
+;               (+ r y))))))
+;
+;;; Chez-Scheme compatibility stuff:
+;
+;(define (chez-box x) (cons x '()))
+;(define (chez-unbox x) (car x))
+;(define (chez-set-box! x y) (set-car! x y))
+;
+;;; Test that a matrix with entries in {+1, -1} is maximal among the matricies
+;;; obtainable by
+;;;       re-ordering the rows
+;;;       re-ordering the columns
+;;;       negating any subset of the columns
+;;;       negating any subset of the rows
+;;; Where we compare two matricies by lexicographically comparing the first row,
+;;; then the next to last, etc., and we compare a row by lexicographically
+;;; comparing the first entry, the second entry, etc., and we compare two
+;;; entries by +1 > -1.
+;;; Note, this scheme obeys the useful fact that if (append mat1 mat2) is
+;;; maximal, then so is mat1.  Thus, we can build up maximal matricies
+;;; row by row.
+;;;
+;;; Once you have chosen the row re-ordering so that you know which row goes
+;;; last, the set of columns to negate is fixed (since the last row must be
+;;; all +1's).
+;;;
+;;; Note, the column ordering is really totally determined as follows:
+;;;       all columns for which the second row is +1 must come before all
+;;;               columns for which the second row is -1.
+;;;       among columns for which the second row is +1, all columns for which
+;;;               the third row is +1 come before those for which the third is
+;;;               -1, and similarly for columns in which the second row is -1.
+;;;       etc
+;;; Thus, each succeeding row sorts columns withing refinings equivalence
+;;; classes.
+;;;
+;;; Maximal? assumes that mat has atleast one row, and that the first row
+;;; is all +1's.
+;(define maximal?
+;  (lambda (mat)
+;    (let pick-first-row
+;        ((first-row-perm
+;          (gen-perms mat)))
+;      (if first-row-perm
+;          (and (zunda first-row-perm mat)
+;               (pick-first-row (first-row-perm 'brother)))
+;          #t))))
+
+(define zunda
+  (lambda (first-row-perm mat)
+    (let* ((first-row
+            (first-row-perm 'now))
+           (number-of-cols
+            (length first-row))
+           (make-row->func
+            (lambda (if-equal if-different)
+              (lambda (row)
+                (let ((vec
+                       (make-vector number-of-cols)))
+                  (do ((i 0 (+ i 1))
+                       (first first-row
+                              (cdr first))
+                       (row row
+                            (cdr row)))
+                      ((= i number-of-cols))
+                    (vector-set! vec
+                                 i
+                                 (if (= (car first) (car row))
+                                     if-equal
+                                     if-different)))
+                  (lambda (i)
+                    (vector-ref vec i))))))
+           (mat
+            (cdr mat)))
+;(make-row->func 1 -1)
+      (zebra (first-row-perm 'child)
+             (make-row->func 1 -1)
+             (make-row->func -1 1)
+             mat
+             number-of-cols))))
+
+;; TODO: with this test code, why is the fast-eq inlined????
+(write (zunda 1 -1))
+
+(define zebra
+  (lambda (row-perm row->func+ row->func- mat number-of-cols)
+    (write (list row-perm row->func+ row->func- mat number-of-cols))))
+;(define zebra
+;  (lambda (row-perm row->func+ row->func- mat number-of-cols)
+;    (let _-*-
+;        ((row-perm
+;          row-perm)
+;         (mat
+;          mat)
+;         (partitions
+;          (list (miota number-of-cols))))
+;      (or (not row-perm)
+;          (and
+;           (zulu (car mat)
+;                 (row->func+ (row-perm 'now))
+;                 partitions
+;                 (lambda (new-partitions)
+;                   (_-*- (row-perm 'child)
+;                         (cdr mat)
+;                         new-partitions)))
+;           (zulu (car mat)
+;                 (row->func- (row-perm 'now))
+;                 partitions
+;                 (lambda (new-partitions)
+;                   (_-*- (row-perm 'child)
+;                         (cdr mat)
+;                         new-partitions)))
+;           (let ((new-row-perm
+;                  (row-perm 'brother)))
+;             (or (not new-row-perm)
+;                 (_-*- new-row-perm
+;                       mat
+;                       partitions))))))))
+;
+;
+;(define zulu
+;  (let ((cons-if-not-null
+;         (lambda (lhs rhs)
+;           (if (null? lhs)
+;               rhs
+;               (cons lhs rhs)))))
+;    (lambda (old-row new-row-func partitions equal-cont)
+;      (let _-*-
+;          ((p-in
+;            partitions)
+;           (old-row
+;            old-row)
+;           (rev-p-out
+;            '()))
+;        (let _-split-
+;            ((partition
+;              (car p-in))
+;             (old-row
+;              old-row)
+;             (plus
+;              '())
+;             (minus
+;              '()))
+;          (if (null? partition)
+;              (let _-minus-
+;                  ((old-row
+;                    old-row)
+;                   (m
+;                    minus))
+;                (if (null? m)
+;                    (let ((rev-p-out
+;                           (cons-if-not-null
+;                            minus
+;                            (cons-if-not-null
+;                             plus
+;                             rev-p-out)))
+;                          (p-in
+;                           (cdr p-in)))
+;                      (if (null? p-in)
+;                          (equal-cont (reverse rev-p-out))
+;                          (_-*- p-in old-row rev-p-out)))
+;                    (or (= 1 (car old-row))
+;                        (_-minus- (cdr old-row)
+;                                  (cdr m)))))
+;              (let ((next
+;                     (car partition)))
+;                (case (new-row-func next)
+;                  ((1)
+;                   (and (= 1 (car old-row))
+;                        (_-split- (cdr partition)
+;                                  (cdr old-row)
+;                                  (cons next plus)
+;                                  minus)))
+;                  ((-1)
+;                   (_-split- (cdr partition)
+;                             old-row
+;                             plus
+;                             (cons next minus)))))))))))
+;
+;(define all?
+;  (lambda (ok? lst)
+;    (let _-*-
+;        ((lst
+;          lst))
+;      (or (null? lst)
+;          (and (ok? (car lst))
+;               (_-*- (cdr lst)))))))
+;
+;(define gen-perms
+;  (lambda (objects)
+;    (let _-*-
+;        ((zulu-future
+;          objects)
+;         (past
+;          '()))
+;      (if (null? zulu-future)
+;          #f
+;          (lambda (msg)
+;            (case msg
+;              ((now)
+;               (car zulu-future))
+;              ((brother)
+;               (_-*- (cdr zulu-future)
+;                     (cons (car zulu-future)
+;                           past)))
+;              ((child)
+;               (gen-perms
+;                (fold past cons (cdr zulu-future))))
+;              ((puke)
+;               (cons (car zulu-future)
+;                     (fold past cons (cdr zulu-future))))
+;              (else
+;               (error 'gen-perms "Bad msg: ~a" msg))))))))
+;
+;(define fold
+;  (lambda (lst folder state)
+;    (let _-*-
+;        ((lst
+;          lst)
+;         (state
+;          state))
+;      (if (null? lst)
+;          state
+;          (_-*- (cdr lst)
+;                (folder (car lst)
+;                        state))))))
+;
+;(define miota
+;  (lambda (len)
+;    (let _-*-
+;        ((i 0))
+;      (if (= i len)
+;          '()
+;          (cons i
+;                (_-*- (+ i 1)))))))
+;
+;(define proc->vector
+;  (lambda (size proc)
+;    (let ((res
+;           (make-vector size)))
+;      (do ((i 0
+;              (+ i 1)))
+;          ((= i size))
+;        (vector-set! res
+;                     i
+;                     (proc i)))
+;      res)))
+;
+;;; Given a prime number P, return a procedure which, given a `maker' procedure,
+;;; calls it on the operations for the field Z/PZ.
+;(define make-modular
+;  (lambda (modulus)
+;    (let* ((reduce
+;            (lambda (x)
+;              (mod x modulus)))
+;           (coef-zero?
+;            (lambda (x)
+;              (zero? (reduce x))))
+;           (coef-+
+;            (lambda (x y)
+;              (reduce (+ x y))))
+;           (coef-negate
+;            (lambda (x)
+;              (reduce (- x))))
+;           (coef-*
+;            (lambda (x y)
+;              (reduce (* x y))))
+;           (coef-recip
+;            (let ((inverses
+;                   (proc->vector (- modulus 1)
+;                                 (lambda (i)
+;                                   (extended-gcd (+ i 1)
+;                                                 modulus
+;                                                 (lambda (gcd inverse ignore)
+;                                                   inverse))))))
+;              ;; Coef-recip.
+;              (lambda (x)
+;                (let ((x
+;                       (reduce x)))
+;                  (vector-ref inverses (- x 1)))))))
+;      (lambda (maker)
+;        (maker 0;; coef-zero
+;               1;; coef-one
+;               coef-zero?
+;               coef-+
+;               coef-negate
+;               coef-*
+;               coef-recip)))))
+;
+;;; Extended Euclidean algorithm.
+;;; (extended-gcd a b cont) computes the gcd of a and b, and expresses it
+;;; as a linear combination of a and b.  It returns calling cont via
+;;;       (cont gcd a-coef b-coef)
+;;; where gcd is the GCD and is equal to a-coef * a + b-coef * b.
+;(define extended-gcd
+;  (let ((n->sgn/abs
+;         (lambda (x cont)
+;           (if (>= x 0)
+;               (cont 1 x)
+;               (cons -1 (- x))))))
+;    (lambda (a b cont)
+;      (n->sgn/abs a
+;                  (lambda (p-a p)
+;                    (n->sgn/abs b
+;                                (lambda (q-b q)
+;                                  (let _-*-
+;                                      ((p
+;                                        p)
+;                                       (p-a
+;                                        p-a)
+;                                       (p-b
+;                                        0)
+;                                       (q
+;                                        q)
+;                                       (q-a
+;                                        0)
+;                                       (q-b
+;                                        q-b))
+;                                    (if (zero? q)
+;                                        (cont p p-a p-b)
+;                                        (let ((mult
+;                                               (div p q)))
+;                                          (_-*- q
+;                                                q-a
+;                                                q-b
+;                                                (- p (* mult q))
+;                                                (- p-a (* mult q-a))
+;                                                (- p-b (* mult q-b)))))))))))))
+;
+;;; Given elements and operations on the base field, return a procedure which
+;;; computes the row-reduced version of a matrix over that field.  The result
+;;; is a list of rows where the first non-zero entry in each row is a 1 (in
+;;; the coefficient field) and occurs to the right of all the leading non-zero
+;;; entries of previous rows.  In particular, the number of rows is the rank
+;;; of the original matrix, and they have the same row-space.
+;;; The items related to the base field which are needed are:
+;;;       coef-zero       additive identity
+;;;       coef-one        multiplicative identity
+;;;       coef-zero?      test for additive identity
+;;;       coef-+          addition (two args)
+;;;       coef-negate     additive inverse
+;;;       coef-*          multiplication (two args)
+;;;       coef-recip      multiplicative inverse
+;;; Note, matricies are stored as lists of rows (i.e., lists of lists).
+;(define make-row-reduce
+;  (lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip)
+;    (lambda (mat)
+;      (let _-*-
+;          ((mat
+;            mat))
+;        (if (or (null? mat)
+;                (null? (car mat)))
+;            '()
+;            (let _-**-
+;                ((in
+;                  mat)
+;                 (out
+;                  '()))
+;              (if (null? in)
+;                  (map
+;                   (lambda (x)
+;                     (cons coef-zero x))
+;                   (_-*- out))
+;                  (let* ((prow
+;                          (car in))
+;                         (pivot
+;                          (car prow))
+;                         (prest
+;                          (cdr prow))
+;                         (in
+;                          (cdr in)))
+;                    (if (coef-zero? pivot)
+;                        (_-**- in
+;                               (cons prest out))
+;                        (let ((zap-row
+;                               (map
+;                                (let ((mult
+;                                       (coef-recip pivot)))
+;                                  (lambda (x)
+;                                    (coef-* mult x)))
+;                                prest)))
+;                          (cons (cons coef-one zap-row)
+;                                (map
+;                                 (lambda (x)
+;                                   (cons coef-zero x))
+;                                 (_-*-
+;                                  (fold in
+;                                        (lambda (row mat)
+;                                          (cons
+;                                           (let ((first-col
+;                                                  (car row))
+;                                                 (rest-row
+;                                                  (cdr row)))
+;                                             (if (coef-zero? first-col)
+;                                                 rest-row
+;                                                 (map
+;                                                  (let ((mult
+;                                                         (coef-negate first-col)))
+;                                                    (lambda (f z)
+;                                                      (coef-+ f
+;                                                              (coef-* mult z))))
+;                                                  rest-row
+;                                                  zap-row)))
+;                                           mat))
+;                                        out))))))))))))))
+;
+;
+;;; Given elements and operations on the base field, return a procedure which
+;;; when given a matrix and a vector tests to see if the vector is in the
+;;; row-space of the matrix.  This returned function is curried.
+;;; The items related to the base field which are needed are:
+;;;       coef-zero       additive identity
+;;;       coef-one        multiplicative identity
+;;;       coef-zero?      test for additive identity
+;;;       coef-+          addition (two args)
+;;;       coef-negate     additive inverse
+;;;       coef-*          multiplication (two args)
+;;;       coef-recip      multiplicative inverse
+;;; Note, matricies are stored as lists of rows (i.e., lists of lists).
+;(define make-in-row-space?
+;  (lambda (coef-zero coef-one coef-zero? coef-+ coef-negate coef-* coef-recip)
+;    (let ((row-reduce
+;           (make-row-reduce coef-zero
+;                            coef-one
+;                            coef-zero?
+;                            coef-+
+;                            coef-negate
+;                            coef-*
+;                            coef-recip)))
+;      (lambda (mat)
+;        (let ((mat
+;               (row-reduce mat)))
+;          (lambda (row)
+;            (let _-*-
+;                ((row
+;                  row)
+;                 (mat
+;                  mat))
+;              (if (null? row)
+;                  #t
+;                  (let ((r-first
+;                         (car row))
+;                        (r-rest
+;                         (cdr row)))
+;                    (cond ((coef-zero? r-first)
+;                           (_-*- r-rest
+;                                 (map cdr
+;                                      (if (or (null? mat)
+;                                              (coef-zero? (caar mat)))
+;                                          mat
+;                                          (cdr mat)))))
+;                          ((null? mat)
+;                           #f)
+;                          (else
+;                           (let* ((zap-row
+;                                   (car mat))
+;                                  (z-first
+;                                   (car zap-row))
+;                                  (z-rest
+;                                   (cdr zap-row))
+;                                  (mat
+;                                   (cdr mat)))
+;                             (if (coef-zero? z-first)
+;                                 #f
+;                                 (_-*-
+;                                  (map
+;                                   (let ((mult
+;                                          (coef-negate r-first)))
+;                                     (lambda (r z)
+;                                       (coef-+ r
+;                                               (coef-* mult z))))
+;                                   r-rest
+;                                   z-rest)
+;                                  (map cdr mat)))))))))))))))
+;
+;
+;;; Given a prime number, return a procedure which takes integer matricies
+;;; and returns their row-reduced form, modulo the prime.
+;(define make-modular-row-reduce
+;  (lambda (modulus)
+;    ((make-modular modulus)
+;     make-row-reduce)))
+;
+;
+;(define make-modular-in-row-space?
+;  (lambda (modulus)
+;    ((make-modular modulus)
+;     make-in-row-space?)))
+;
+;
+;
+;;; Usual utilities.
+;
+;
+;
+;;; Given a bound, find a prime greater than the bound.
+;(define find-prime
+;  (lambda (bound)
+;    (let* ((primes
+;            (list 2))
+;           (last
+;            (chez-box primes))
+;           (is-next-prime?
+;            (lambda (trial)
+;              (let _-*-
+;                  ((primes
+;                    primes))
+;                (or (null? primes)
+;                    (let ((p
+;                           (car primes)))
+;                      (or (< trial (* p p))
+;                          (and (not (zero? (mod trial p)))
+;                               (_-*- (cdr primes))))))))))
+;      (if (> 2 bound)
+;          2
+;          (let _-*-
+;              ((trial
+;                3))
+;            (if (is-next-prime? trial)
+;                (let ((entry
+;                       (list trial)))
+;                  (set-cdr! (chez-unbox last) entry)
+;                  (chez-set-box! last entry)
+;                  (if (> trial bound)
+;                      trial
+;                      (_-*- (+ trial 2))))
+;                (_-*- (+ trial 2))))))))
+;
+;;; Given the size of a square matrix consisting only of +1's and -1's,
+;;; return an upper bound on the determinant.
+;(define det-upper-bound
+;  (lambda (size)
+;    (let ((main-part
+;           (expt size
+;                 (div size 2))))
+;      (if (even? size)
+;          main-part
+;          (* main-part
+;             (do ((i 0 (+ i 1)))
+;                 ((>= (* i i) size)
+;                  i)))))))
+;
+;;; Fold over all maximal matrices.
+;(define go
+;  (lambda (number-of-cols inv-size folder state)
+;    (let* ((in-row-space?
+;            (make-modular-in-row-space?
+;             (find-prime
+;              (det-upper-bound inv-size))))
+;           (make-tester
+;            (lambda (mat)
+;              (let ((tests
+;                     (let ((old-mat
+;                            (cdr mat))
+;                           (new-row
+;                            (car mat)))
+;                       (fold-over-subs-of-size old-mat
+;                                               (- inv-size 2)
+;                                               (lambda (sub tests)
+;                                                 (cons
+;                                                  (in-row-space?
+;                                                   (cons new-row sub))
+;                                                  tests))
+;                                               '()))))
+;                (lambda (row)
+;                  (let _-*-
+;                      ((tests
+;                        tests))
+;                    (and (not (null? tests))
+;                         (or ((car tests) row)
+;                             (_-*- (cdr tests)))))))))
+;           (all-rows;; all rows starting with +1 in decreasing order
+;            (fold
+;             (fold-over-rows (- number-of-cols 1)
+;                             cons
+;                             '())
+;             (lambda (row rows)
+;               (cons (cons 1 row)
+;                     rows))
+;             '())))
+;      (let _-*-
+;          ((number-of-rows
+;            1)
+;           (rev-mat
+;            (list
+;             (car all-rows)))
+;           (possible-future
+;            (cdr all-rows))
+;           (state
+;            state))
+;        (let ((zulu-future
+;               (remove-in-order
+;                (if (< number-of-rows inv-size)
+;                    (in-row-space? rev-mat)
+;                    (make-tester rev-mat))
+;                possible-future)))
+;          (if (null? zulu-future)
+;              (folder (reverse rev-mat)
+;                      state)
+;              (let _-**-
+;                  ((zulu-future
+;                    zulu-future)
+;                   (state
+;                    state))
+;                (if (null? zulu-future)
+;                    state
+;                    (let ((rest-of-future
+;                           (cdr zulu-future)))
+;                      (_-**- rest-of-future
+;                             (let* ((first
+;                                     (car zulu-future))
+;                                    (new-rev-mat
+;                                     (cons first rev-mat)))
+;                               (if (maximal? (reverse new-rev-mat))
+;                                   (_-*- (+ number-of-rows 1)
+;                                         new-rev-mat
+;                                         rest-of-future
+;                                         state)
+;                                   state))))))))))))
+;
+;(define go-folder
+;  (lambda (mat bsize.blen.blist)
+;    (let ((bsize
+;           (car bsize.blen.blist))
+;          (size
+;           (length mat)))
+;      (if (< size bsize)
+;          bsize.blen.blist
+;          (let ((blen
+;                 (cadr bsize.blen.blist))
+;                (blist
+;                 (cddr bsize.blen.blist)))
+;            (if (= size bsize)
+;                (let ((blen
+;                       (+ blen 1)))
+;                  ;;                       (if
+;                  ;;                          (let _-*-
+;                  ;;                               ((blen
+;                  ;;                                   blen))
+;                  ;;                             (or (< blen 10)
+;                  ;;                                 (and (zero? (mod blen 10))
+;                  ;;                                      (_-*- (div blen 10)))))
+;                  ;;
+;                  ;;                          (begin
+;                  ;;                             (display blen)
+;                  ;;                             (display " of size ")
+;                  ;;                             (display bsize)
+;                  ;;                             (newline)))
+;
+;                  (cons bsize
+;                        (cons blen
+;                              (cond ((< blen 3000)
+;                                     (cons mat blist))
+;                                    ((= blen 3000)
+;                                     (cons "..." blist))
+;                                    (else
+;                                     blist)))))
+;                ;;                    (begin
+;                ;;                       (newline)
+;                ;;                       (display "First of size ")
+;                ;;                       (display size)
+;                ;;                       (display ":")
+;                ;;                       (newline)
+;                ;;                       (for-each
+;                ;;                          (lambda (row)
+;                ;;                             (display " ")
+;                ;;                             (for-each
+;                ;;                                (lambda (e)
+;                ;;                                   (case e
+;                ;;                                      ((1)
+;                ;;                                         (display "  1"))
+;                ;;                                      ((-1)
+;                ;;                                         (display " -1"))))
+;                ;;                                row)
+;                ;;                             (newline))
+;                ;;                          mat)
+;
+;                (list size 1 mat)))))))
+;
+;(define really-go
+;  (lambda (number-of-cols inv-size)
+;    (cddr
+;     (go number-of-cols
+;         inv-size
+;         go-folder
+;         (list -1 -1)))))
+;
+;(define remove-in-order
+;  (lambda (remove? lst)
+;    (reverse
+;     (fold lst
+;           (lambda (e lst)
+;             (if (remove? e)
+;                 lst
+;                 (cons e lst)))
+;           '()))))
+;
+;;; The first fold-over-rows is slower than the second one, but folds
+;;; over rows in lexical order (large to small).
+;(define fold-over-rows
+;  (lambda (number-of-cols folder state)
+;    (if (zero? number-of-cols)
+;        (folder '()
+;                state)
+;        (fold-over-rows (- number-of-cols 1)
+;                        (lambda (tail state)
+;                          (folder (cons -1 tail)
+;                                  state))
+;                        (fold-over-rows (- number-of-cols 1)
+;                                        (lambda (tail state)
+;                                          (folder (cons 1 tail)
+;                                                  state))
+;                                        state)))))
+;
+;;; Fold over subsets of a given size.
+;(define fold-over-subs-of-size
+;  (lambda (universe size folder state)
+;    (let ((usize
+;           (length universe)))
+;      (if (< usize size)
+;          state
+;          (let _-*-
+;              ((size
+;                size)
+;               (universe
+;                universe)
+;               (folder
+;                folder)
+;               (csize
+;                (- usize size))
+;               (state
+;                state))
+;            (cond ((zero? csize)
+;                   (folder universe state))
+;                  ((zero? size)
+;                   (folder '() state))
+;                  (else
+;                   (let ((first-u
+;                          (car universe))
+;                         (rest-u
+;                          (cdr universe)))
+;                     (_-*- size
+;                           rest-u
+;                           folder
+;                           (- csize 1)
+;                           (_-*- (- size 1)
+;                                 rest-u
+;                                 (lambda (tail state)
+;                                   (folder (cons first-u tail)
+;                                           state))
+;                                 csize
+;                                 state))))))))))
+;
+;(define (main)
+;  (let* ((count (read))
+;         (input1 (read))
+;         (input2 (read))
+;         (output (read))
+;         (s3 (number->string count))
+;         (s2 (number->string input2))
+;         (s1 (number->string input1))
+;         (name "matrix"))
+;    (run-r7rs-benchmark
+;     (string-append name ":" s1 ":" s2 ":" s3)
+;     count
+;     (lambda () (really-go (hide count input1) (hide count input2)))
+;     (lambda (result) (equal? result output)))))
+;
+;;;; The following code is appended to all benchmarks.
+;
+;;;; Given an integer and an object, returns the object
+;;;; without making it too easy for compilers to tell
+;;;; the object will be returned.
+;
+;(define (hide r x)
+;  (call-with-values
+;   (lambda ()
+;     (values (vector values (lambda (x) x))
+;             (if (< r 100) 0 1)))
+;   (lambda (v i)
+;     ((vector-ref v i) x))))
+;
+;;;; Given the name of a benchmark,
+;;;; the number of times it should be executed,
+;;;; a thunk that runs the benchmark once,
+;;;; and a unary predicate that is true of the
+;;;; correct results the thunk may return,
+;;;; runs the benchmark for the number of specified iterations.
+;
+;(define (run-r7rs-benchmark name count thunk ok?)
+;
+;  ;; Rounds to thousandths.
+;  (define (rounded x)
+;    (/ (round (* 1000 x)) 1000))
+;
+;  (display "Running ")
+;  (display name)
+;  (newline)
+;  (flush-output-port (current-output-port))
+;  (let* ((j/s (jiffies-per-second))
+;         (t0 (current-second))
+;         (j0 (current-jiffy)))
+;    (let loop ((i 0)
+;               (result #f))
+;      (cond ((< i count)
+;             (loop (+ i 1) (thunk)))
+;            ((ok? result)
+;             (let* ((j1 (current-jiffy))
+;                    (t1 (current-second))
+;                    (jifs (- j1 j0))
+;                    (secs (inexact (/ jifs j/s)))
+;                    (secs2 (rounded (- t1 t0))))
+;               (display "Elapsed time: ")
+;               (write secs)
+;               (display " seconds (")
+;               (write secs2)
+;               (display ") for ")
+;               (display name)
+;               (newline)
+;               (display "+!CSVLINE!+")
+;               (display (this-scheme-implementation-name))
+;               (display ",")
+;               (display name)
+;               (display ",")
+;               (display secs)
+;               (newline)
+;               (flush-output-port (current-output-port)))
+;             result)
+;            (else
+;             (display "ERROR: returned incorrect result: ")
+;             (write result)
+;             (newline)
+;             (flush-output-port (current-output-port))
+;             result)))))
+;(define (this-scheme-implementation-name)
+;  (string-append "cyclone-" (Cyc-version)))
+;(main)

tests/debug/flatten-seq.scm

@@ -0,0 +1,45 @@
+(import (scheme base) (scheme write) (scheme cyclone util) (scheme cyclone pretty-print))
+
+(define sexp
+  '(Cyc-seq
+         (set! b '(#f . #f))
+         (Cyc-seq
+           (set-car!  a 1)
+           (Cyc-seq
+             (set-cdr!  a '(2))
+             ((fnc a1 a2 a3))))))
+
+;; Flatten a list containing subcalls of a given symbol.
+;; For example, the expression: 
+;;
+;;  '(Cyc-seq
+;;         (set! b '(#f . #f))
+;;         (Cyc-seq
+;;           (set-car!  a 1)
+;;           (Cyc-seq
+;;             (set-cdr!  a '(2))
+;;             ((fnc a1 a2 a3)))))
+;;
+;; becomes:
+;;
+;;  '(Cyc-seq
+;;     (set! b '(#f . #f))
+;;     (set-car! a 1)
+;;     (set-cdr! a '(2))
+;;     ((fnc a1 a2 a3)))
+;;
+(define (flatten-subcalls sexp sym)
+  (define (flat sexp acc)
+    (cond
+      ((not (pair? sexp))
+       acc)
+      ((and (tagged-list? sym (car sexp)))
+        (flat (cdar sexp) acc))
+      (else ;;(pair? sexp)
+        (flat (cdr sexp) (cons (car sexp) acc))))
+  )
+  (reverse
+    (flat sexp '())))
+
+(pretty-print (flatten-subcalls sexp 'Cyc-seq))
+(pretty-print (flatten-subcalls '(a b c d e (f (g))) 'Cyc-seq))