Import to github.

7 files changed, 4079 insertions, 0 deletions

diff --git a/backend/README b/backend/README
new file mode 100644
index 0000000..f221b1a
--- /dev/null
+++ b/backend/README
@@ -0,0 +1,10 @@
+This directory contains the files for the compiler backend.  All of these
+phases operate on FLIC code.
+
+optimize -- performs various tweaks to compact the code and make it faster.
+  also includes a postpass to fill in some additional structure slots.
+
+strictness -- attaches strictness information to functions and decides
+  whether locally-bound variables have a boxed or unboxed representation.
+
+codegen -- generates Lisp code from the optimized FLIC code.
diff --git a/backend/backend.scm b/backend/backend.scm
new file mode 100644
index 0000000..b370ea7
--- /dev/null
+++ b/backend/backend.scm
@@ -0,0 +1,21 @@
+;;; backend.scm -- compilation unit for code generator stuff
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  13 May 1992
+;;;
+
+
+(define-compilation-unit backend
+  (source-filename "$Y2/backend/")
+  (require flic)
+  (unit optimize
+	(source-filename "optimize.scm"))
+  (unit strictness
+	(source-filename "strictness.scm"))
+  (unit box
+	(source-filename "box.scm"))
+  (unit codegen
+	(source-filename "codegen.scm"))
+  (unit interface-codegen
+	(source-filename "interface-codegen.scm")))
+
diff --git a/backend/box.scm b/backend/box.scm
new file mode 100644
index 0000000..c47848a
--- /dev/null
+++ b/backend/box.scm
@@ -0,0 +1,417 @@
+;;; box.scm -- determine which expressions need to be boxed
+;;;
+;;; author  :  Sandra Loosemore
+;;; date    :  03 Apr 1993
+;;;
+;;; 
+;;; This phase determines whether expressions need to be boxed or unboxed.
+;;;
+;;; In the case of an expression that needs to be boxed, it determines 
+;;; whether it can be evaluated eagerly and boxed or whether a delay
+;;; must be constructed.
+;;;
+;;; In the case of an expression that needs to be unboxed, it determines
+;;; whether it is already known to have been evaluated and can simply
+;;; be unboxed instead of checking for a delay that must be forced.
+;;;
+;;; This phase may mark previously non-strict variables as strict if their
+;;; initializers can be evaluated eagerly.  However, doing this evaluation
+;;; eagerly never causes any other non-strict variables to be forced,
+;;; so there is no need to propagate this strictness information backwards
+;;; (as happens in the var-strictness-walk pass).
+
+
+;;;======================================================================
+;;; Top-level function
+;;;======================================================================
+
+
+;;; Complexity computation
+
+(define-integrable delay-complexity 10)
+(define-integrable unbox-complexity 1)
+(define-integrable box-complexity 2)
+(define-integrable sel-complexity 1)
+(define-integrable is-constructor-complexity 1)
+(define-integrable pack-complexity 2)
+(define-integrable con-number-complexity 1)
+
+(define (add-complexity c1 c2)
+  (cond ((not c1)
+	 '#f)
+	((not c2)
+	 '#f)
+	(else
+	 ;; *** We might want to establish an arbitrary cutoff here.
+	 ;; *** e.g., if complexity > N then set it to '#f.
+	 (the fixnum (+ (the fixnum c1) (the fixnum c2))))))
+
+
+
+;;; The second argument to the walker is a list of things
+;;; that are known to have been forced already.
+;;; The third argument is a list of variables that have not yet
+;;; been initialized.
+;;; Walkers return two values:  a new value for already-forced and
+;;; the complexity of the expression.
+
+;;; This helper function sets the unboxed? and cheap? bits for the
+;;; code generator, and adjusts the basic complexity to account for
+;;; forces, boxes, and delays.
+;;;
+;;; The basic decision tree for the code generator should be:
+;;; if unboxed?
+;;;    then if strict-result?
+;;;            then generate x                                   (1)
+;;;            else if cheap?
+;;;                    then generate (unbox x)                   (2)
+;;;                    else generate (force x)                   (3)
+;;;    else if strict-result?
+;;;            then if cheap?
+;;;                    then generate (box x)                     (4)
+;;;                    else generate (delay x)                   (5)
+;;;            else if cheap?
+;;;                    then generate x                           (6)
+;;;                    then generate (delay (force x))           (7)
+;;; See function do-codegen in codegen.scm.
+
+
+(define (do-box-analysis object already-forced uninitialized unboxed?)
+  (setf (flic-exp-unboxed? object) unboxed?)
+  (multiple-value-bind (result complexity)
+      (box-analysis object already-forced uninitialized)
+    (setf complexity
+	  (if unboxed?
+	      ;; If the expression returns a boxed value and we want
+	      ;; an unboxed one, we may need to do a force.
+	      (if (flic-exp-strict-result? object)
+		  (begin                                       ; case (1)
+		    ;; this flic-exp-cheap? bit is used only by
+		    ;; exp-would-be-cheap? below -- not by codegen
+		    (setf (flic-exp-cheap? object)
+			  (if complexity '#t '#f))
+		    complexity)      
+		  (if (already-forced? object already-forced)
+		      (begin                                   ; case (2)
+			(setf (flic-exp-cheap? object) '#t)
+			(add-complexity complexity unbox-complexity))
+		      (begin                                   ; case (3)
+			(setf (flic-exp-cheap? object) '#f)
+			'#f)))
+	      ;; We want a boxed value.  If the expression already
+	      ;; returns a boxed value, return its complexity directly;
+	      ;; otherwise return the cost of either boxing or delaying it.
+	      (if (flic-exp-strict-result? object)
+		  (if complexity
+		      (begin                                   ; case (4)
+			(setf (flic-exp-cheap? object) '#t)
+			(add-complexity complexity box-complexity))
+		      (begin                                   ; case (5)
+			(setf (flic-exp-cheap? object) '#f)
+			delay-complexity))
+		  (if complexity
+		      (begin
+			(setf (flic-exp-cheap? object) '#t)    ; case (6)
+			complexity)
+		      (begin                                   ; case (7)
+		        (setf (flic-exp-cheap? object) '#f)
+			delay-complexity)))
+	    ))
+    (values
+      (if unboxed?
+	  (note-already-forced object result)
+	  result)
+      complexity)))
+
+
+
+
+;;;======================================================================
+;;; Code walk
+;;;======================================================================
+
+
+(define *local-function-calls* '())
+
+(define-flic-walker box-analysis (object already-forced uninitialized))
+
+(define-box-analysis flic-lambda (object already-forced uninitialized)
+  (do-box-analysis (flic-lambda-body object) already-forced uninitialized '#t)
+  (values already-forced 0))
+
+(define-box-analysis flic-let (object already-forced uninitialized)
+  (let ((bindings    (flic-let-bindings object)))
+    (dynamic-let ((*local-function-calls*  (dynamic *local-function-calls*)))
+      (dolist (var bindings)
+	;; Note local functions
+	(when (and (not (var-toplevel? var))
+		   (is-type? 'flic-lambda (var-value var))
+		   (not (var-standard-refs? var)))
+	  (push (cons var '()) (dynamic *local-function-calls*))))
+      (multiple-value-bind (already-forced complexity)
+	  (box-analysis-let-aux object already-forced uninitialized)
+	(dolist (var bindings)
+	  ;; Go back and reexamine local functions to see whether
+	  ;; we can make more arguments strict, based on the values
+	  ;; the function is actually called with.
+	  (let ((stuff  (assq var (dynamic *local-function-calls*))))
+	    (when stuff
+	      (maybe-make-more-arguments-strict var (cdr stuff)))))
+	(values already-forced complexity)))))
+
+(define (box-analysis-let-aux object already-forced uninitialized)
+  (let ((recursive?  (flic-let-recursive? object))
+	(bindings    (flic-let-bindings object))
+	(body        (flic-let-body object)))
+    (when recursive? (setf uninitialized (append bindings uninitialized)))
+    (dolist (var bindings)
+      (let* ((value   (var-value var))
+	     (strict? (var-strict? var))
+	     (result  (do-box-analysis value already-forced uninitialized
+				       strict?)))
+	(cond (strict?
+	       ;; Propagate information about things forced.
+	       (setf already-forced result))
+	      ((and (flic-exp-cheap? value)
+		    (flic-exp-strict-result? value))
+	       ;; The value expression is cheap unboxed value, so mark
+	       ;; the variable as strict.
+	       (setf (var-strict? var) '#t)
+	       (setf (flic-exp-unboxed? value) '#t))))
+      (when recursive? (pop uninitialized)))
+    ;; *** Could be smarter about computing complexity.
+    (values
+      (do-box-analysis body already-forced uninitialized '#t)
+      '#f)))
+
+(define (maybe-make-more-arguments-strict var calls)
+  (setf (var-strictness var)
+	(maybe-make-more-arguments-strict-aux
+	  (flic-lambda-vars (var-value var))
+	  calls)))
+
+(define (maybe-make-more-arguments-strict-aux vars calls)
+  (if (null? vars)
+      '()
+      (let ((var  (car vars)))
+	;; If the variable is not already strict, check to see
+	;; whether it's always called with "cheap" arguments.
+	(when (and (not (var-strict? var))
+		   (every-1 (lambda (call)
+			      (exp-would-be-cheap? (car call) var))
+			    calls))
+	  (setf (var-strict? var) '#t)
+	  (dolist (call calls)
+	    (setf (flic-exp-unboxed? (car call)) '#t)))
+	(cons (var-strict? var)
+	      (maybe-make-more-arguments-strict-aux
+	       (cdr vars)
+	       (map (function cdr) calls))))
+    ))
+
+
+;;; Look for one special fixed-point case: argument used as counter-type
+;;; variable.  Otherwise ignore fixed points.
+
+(define (exp-would-be-cheap? exp var)
+  (or (and (flic-exp-cheap? exp)
+	   (flic-exp-strict-result? exp))
+      (and (is-type? 'flic-ref exp)
+	   (eq? (flic-ref-var exp) var))
+      (and (is-type? 'flic-app exp)
+	   (is-type? 'flic-ref (flic-app-fn exp))
+	   (var-complexity (flic-ref-var (flic-app-fn exp)))
+	   (every-1 (lambda (a) (exp-would-be-cheap? a var))
+		    (flic-app-args exp)))
+      ))
+
+
+
+(define-box-analysis flic-app (object already-forced uninitialized)
+  (let ((fn         (flic-app-fn object))
+	(args       (flic-app-args object))
+	(saturated? (flic-app-saturated? object)))
+    (cond ((and saturated? (is-type? 'flic-ref fn))
+	   (let* ((var    (flic-ref-var fn))
+		  (stuff  (assq var (dynamic *local-function-calls*))))
+	     (when stuff
+	       (push args (cdr stuff)))
+	     (box-analysis-app-aux
+	       (var-strictness var) (var-complexity var)
+	       args already-forced uninitialized)))
+	  ((and saturated? (is-type? 'flic-pack fn))
+	   (box-analysis-app-aux
+	     (con-slot-strict? (flic-pack-con fn)) pack-complexity
+	     args already-forced uninitialized))
+	  (else
+	   ;; The function is going to be forced but all the arguments
+	   ;; are non-strict.
+	   (dolist (a args)
+	     (do-box-analysis a already-forced uninitialized '#f))
+	   (values 
+	     (do-box-analysis fn already-forced uninitialized '#t)
+	     '#f))
+	  )))
+	  
+
+
+;;; Propagation of already-forced information depends on whether or
+;;; not the implementation evaluates function arguments in left-to-right
+;;; order.  If not, we can still propagate this information upwards.
+
+(define (box-analysis-app-aux
+	   strictness complexity args already-forced uninitialized)
+  (let ((result   already-forced))
+    (dolist (a args)
+      (let ((strict?  (pop strictness)))
+	(multiple-value-bind (new-result new-complexity)
+	    (do-box-analysis a already-forced uninitialized strict?)
+	  (when strict?
+	    (setf result
+		  (if left-to-right-evaluation
+		      (setf already-forced new-result)
+		      (union-already-forced
+		        new-result already-forced result))))
+	  (setf complexity (add-complexity complexity new-complexity)))))
+    (values result complexity)))
+
+
+(define-box-analysis flic-ref (object already-forced uninitialized)
+  (values
+    already-forced
+    (if (memq (flic-ref-var object) uninitialized)
+	'#f
+	0)))
+
+(define-box-analysis flic-const (object already-forced uninitialized)
+  (declare (ignore object uninitialized))
+  (values already-forced 0))
+
+(define-box-analysis flic-pack (object already-forced uninitialized)
+  (declare (ignore object uninitialized))
+  (values already-forced 0))
+
+
+;;; For case-block and and, already-forced information can be propagated 
+;;; sequentially in the clauses.  But only the first expression is 
+;;; guaranteed to be evaluated, so only it can propagate the information
+;;; outwards.
+
+(define-box-analysis flic-case-block (object already-forced uninitialized)
+  (values
+    (box-analysis-sequence
+      (flic-case-block-exps object) already-forced uninitialized)
+    '#f))
+
+(define-box-analysis flic-and (object already-forced uninitialized)
+  (values
+    (box-analysis-sequence
+      (flic-and-exps object) already-forced uninitialized)
+    '#f))
+
+(define (box-analysis-sequence exps already-forced uninitialized)
+  (let ((result
+	  (setf already-forced
+		(do-box-analysis
+		  (car exps) already-forced uninitialized '#t))))
+    (dolist (e (cdr exps))
+      (setf already-forced
+	    (do-box-analysis e already-forced uninitialized '#t)))
+    (values result already-forced)))
+
+
+(define-box-analysis flic-return-from (object already-forced uninitialized)
+  (values
+    (do-box-analysis
+      (flic-return-from-exp object) already-forced uninitialized '#t)
+    '#f))
+
+
+;;; For if, the test propagates to both branches and the result.
+;;; Look for an important optimization:
+;;; in (if (and e1 e2 ...) e-then e-else),
+;;; e-then can inherit already-forced information from all of the ei
+;;; rather than only from e1.
+;;; *** Could be smarter about the complexity, I suppose....
+;;; *** Also could intersect already-forced results from both
+;;; *** branches.
+
+(define-box-analysis flic-if (object already-forced uninitialized)
+  (if (is-type? 'flic-and (flic-if-test-exp object))
+      (box-analysis-if-and-aux object already-forced uninitialized)
+      (box-analysis-if-other-aux object already-forced uninitialized)))
+
+(define (box-analysis-if-other-aux object already-forced uninitialized)
+  (setf already-forced
+	(do-box-analysis
+	  (flic-if-test-exp object) already-forced uninitialized '#t))
+  (do-box-analysis (flic-if-then-exp object) already-forced uninitialized '#t)
+  (do-box-analysis (flic-if-else-exp object) already-forced uninitialized '#t)
+  (values already-forced '#f))
+
+(define (box-analysis-if-and-aux object already-forced uninitialized)
+  (let* ((test-exp  (flic-if-test-exp object))
+	 (subexps   (flic-and-exps test-exp))
+	 (then-exp  (flic-if-then-exp object))
+	 (else-exp  (flic-if-else-exp object)))
+    (setf (flic-exp-unboxed? test-exp) '#t)
+    (multiple-value-bind (result1 resultn)
+	(box-analysis-sequence subexps already-forced uninitialized)
+      (do-box-analysis then-exp resultn uninitialized '#t)
+      (do-box-analysis else-exp result1 uninitialized '#t)
+      (values result1 '#f))))
+
+
+(define-box-analysis flic-sel (object already-forced uninitialized)
+  (multiple-value-bind (result complexity)
+      (do-box-analysis
+        (flic-sel-exp object) already-forced uninitialized '#t)
+    (values result (add-complexity sel-complexity complexity))))
+
+(define-box-analysis flic-is-constructor (object already-forced uninitialized)
+  (multiple-value-bind (result complexity)
+      (do-box-analysis
+        (flic-is-constructor-exp object) already-forced uninitialized '#t)
+    (values result (add-complexity is-constructor-complexity complexity))))
+
+(define-box-analysis flic-con-number (object already-forced uninitialized)
+  (multiple-value-bind (result complexity)
+      (do-box-analysis
+        (flic-con-number-exp object) already-forced uninitialized '#t)
+    (values result (add-complexity con-number-complexity complexity))))
+
+(define-box-analysis flic-void (object already-forced uninitialized)
+  (declare (ignore object uninitialized))
+  (values already-forced 0))
+
+
+
+
+;;;======================================================================
+;;; Already-forced bookkeeping
+;;;======================================================================
+
+
+;;; For now, we only keep track of variables that have been forced,
+;;; and not data structure accesses.
+
+(define (already-forced? object already-forced)
+  (and (is-type? 'flic-ref object)
+       (memq (flic-ref-var object) already-forced)))
+
+(define (note-already-forced object already-forced)
+  (if (is-type? 'flic-ref object)
+      (cons (flic-ref-var object) already-forced)
+      already-forced))
+
+(define (union-already-forced new tail result)
+  (cond ((eq? new tail)
+	 result)
+	((memq (car new) result)
+	 (union-already-forced (cdr new) tail result))
+	(else
+	 (union-already-forced (cdr new) tail (cons (car new) result)))
+	))
+
+				      
+
diff --git a/backend/codegen.scm b/backend/codegen.scm
new file mode 100644
index 0000000..283594f
--- /dev/null
+++ b/backend/codegen.scm
@@ -0,0 +1,600 @@
+;;; codegen.scm -- compile flic code to Lisp
+;;;
+;;; Author :  Sandra Loosemore
+;;; Date   :  29 Apr 1992
+;;;
+;;; to do:  check completeness of special cases for constructors
+;;;         constants still need work
+;;;         optimized entry points
+;;;
+;;; The code generated here uses the following helper functions:
+;;; (make-curried-fn opt-fn strictness)
+;;;   make a curried function that calls opt-fn after collecting the
+;;;   arguments and processing them according to strictness.  Both
+;;;   the arguments are evaluated.
+;;; (make-tuple-constructor arity)
+;;;   return a function that makes an untagged data structure with "arity" 
+;;;   slots.  "arity" is a constant.
+;;; (make-tuple . args)
+;;;   uncurried version of the above
+;;; (make-tagged-data-constructor n arity)
+;;;   return a function that makes a data structure with tag "n" and
+;;;   "arity" slots.
+;;; (make-tagged-data n . args)
+;;;   uncurried version of the above
+;;; (tuple-select arity i object)
+;;;   extract component "i" from untagged "object"
+;;; (tagged-data-select arity i object)
+;;;   extract component "i" from tagged "object"
+;;; (constructor-number object)
+;;;   return the tag from "object"
+;;; (delay form)
+;;;   returns a delay object with unevaluated "form".
+;;; (box form)
+;;;   returns a delay object with evaluated "form".
+;;; (force delay)
+;;;   return the value of the delay object.
+;;; (make-haskell-string string)
+;;;   Converts a Lisp string lazily to a haskell string (using a magic
+;;;   delay function).  Returns an unboxed result.
+
+
+
+;;;======================================================================
+;;; Code walker
+;;;======================================================================
+
+
+;;; Here is the main entry point.
+
+(define (codegen-top big-let)
+  (do ((bindings (flic-let-bindings big-let) (cdr bindings))
+       (result   '())
+       (decls    '()))
+      ((null? bindings) `(begin ,@(nreverse decls) ,@(nreverse result)))
+    (let ((var  (car bindings)))
+      (push `(predefine ,(fullname var)) decls)
+      (push (codegen-definition var (var-value var)) result))))
+
+
+;;; See box.scm for more information about this...
+
+(define (do-codegen object)
+  (let ((x               (codegen object))
+	(unboxed?        (flic-exp-unboxed? object))
+	(strict-result?  (flic-exp-strict-result? object))
+	(cheap?          (flic-exp-cheap? object)))
+    (if unboxed?
+	(if strict-result?
+	    x
+	    (if cheap?
+		`(unbox ,x)
+		`(force ,x)))
+	(if strict-result?
+	    (if cheap?
+		`(box ,x)
+		`(delay ,x))
+	    (if cheap?
+		x
+		`(delay (force ,x)))))))
+    
+
+(define (do-codegen-list list)
+  (map (function do-codegen) list))
+
+
+(define-flic-walker codegen (object))
+
+
+;;; For top-level definitions bound to lambda expressions, make both
+;;; a standard entry point (with possibly unboxed arguments) and
+;;; a standard entry point.
+
+(define (codegen-definition var exp)
+  (let ((fullname  (fullname var)))
+    (when (or (memq 'codegen (dynamic *printers*))
+	      (memq 'codegen-flic (dynamic *printers*)))
+;       (format '#t "~%Codegen of ~A [~A]  " (def-name var) (struct-hash var))
+       (format '#t "~%Codegen of ~A  " (def-name var))
+       (when (not (var-strict? var))
+	   (format '#t "Nonstrict  "))
+       (when (not (eq? (var-strictness var) '()))
+	   (format '#t "Strictness: ")
+	   (dolist (s (var-strictness var))
+	       (format '#t (if s "S " "N "))))
+       (when (var-simple? var)
+	   (format '#t " Inline "))
+       (format '#t "~%")
+       (when (memq 'codegen-flic (dynamic *printers*))
+          (pprint* exp)))
+    (let ((lisp-code
+	   (if (not (flic-lambda? exp))
+	       `(define ,fullname ,(do-codegen exp))
+	       (let* ((optname  (optname var))
+		      (lambda   (codegen-lambda-aux exp))
+		      (def      `(define (,optname ,@(cadr lambda))
+				                   ,@(cddr lambda))))
+		 (if (var-selector-fn? var)
+   	             ;; Standard entry point for selectors is never used.
+		     def
+		     `(begin
+			,def
+			(define ,fullname
+			  ,(maybe-make-box-value
+			    (codegen-curried-fn
+			     `(function ,optname) (var-strictness var))
+			    (var-strict? var)))))))))
+      (when (or (memq 'codegen (dynamic *printers*))
+		(memq 'codegen-flic (dynamic *printers*)))
+	    (pprint* lisp-code))
+      lisp-code)))
+
+(define (codegen-lambda-list vars)
+  (map (function fullname) vars))
+
+(define (codegen-curried-fn opt-fn strictness)
+  (if (null? (cdr strictness))
+      ;; one-argument special cases
+      (if (car strictness)
+	  `(make-curried-fn-1-strict ,opt-fn)
+	  `(make-curried-fn-1-nonstrict ,opt-fn))
+      ;; general case
+      `(make-curried-fn ,opt-fn ',strictness)))
+
+
+;;; Curry lambdas.  Functions always return an unboxed value.
+
+(define-codegen flic-lambda (object)
+  (codegen-curried-fn
+    (codegen-lambda-aux object)
+    (map (lambda (x) (var-strict? x)) (flic-lambda-vars object))))
+
+(define (codegen-lambda-aux object)
+  (let* ((vars    (flic-lambda-vars object))
+	 (ignore  '())
+	 (args    (codegen-lambda-list vars)))
+    (dolist (v vars)
+      (if (eqv? (var-referenced v) 0)
+	  (push (fullname v) ignore)))
+    `(lambda ,args
+       ,@(if (not (null? ignore))
+	     `((declare (ignore ,@ignore)))
+	     '())
+       ,(do-codegen (flic-lambda-body object)))))
+
+
+;;; This is only for non-top-level lets.
+;;; The boxing of the value of each of the bindings is controlled by its
+;;; strict? property.
+
+(define-codegen flic-let (object)
+  (let ((bindings   (flic-let-bindings object))
+	(body       (flic-let-body object))
+	(recursive? (flic-let-recursive? object)))
+    (if recursive?
+	(codegen-letrec bindings body)
+	(codegen-let*   bindings body))))
+
+
+;;; For efficiency reasons, we want to make all the function bindings
+;;; in the function namespace (some implementations do not do tail-recursion
+;;; or other optimizations correctly otherwise).  This means we have
+;;; to sort out the variable bindings from the function bindings here.
+
+(define (codegen-letrec bindings body)
+  (let ((let-bindings     '())
+	(labels-bindings  '()))
+    (dolist (var bindings)
+      (let ((value    (var-value var))
+	    (fullname (fullname var))
+	    (strict?  (var-strict? var)))
+	(if (flic-lambda? value)
+	    ;; Some functions may need only the optimized or standard
+	    ;; entry points, but not both.
+	    (let ((optname     (optname var))
+		  (lambda      (codegen-lambda-aux value))
+		  (optimized?  (var-optimized-refs? var))
+		  (standard?   (var-standard-refs? var)))
+	      (when standard?
+		(push (list fullname
+			    (maybe-make-box-value
+			      (codegen-curried-fn
+			        (if optimized? `(function ,optname) lambda)
+				(var-strictness var))
+			      strict?))
+		      let-bindings))
+	      (when optimized?
+		(push (cons optname (cdr lambda)) labels-bindings)))
+	    (push (list fullname (do-codegen value)) let-bindings))))
+    (setf let-bindings (nreverse let-bindings))
+    (setf labels-bindings (nreverse labels-bindings))
+    (cond ((null? let-bindings)
+	   `(labels ,labels-bindings ,(do-codegen body)))
+	  ((null? labels-bindings)
+	   `(letrec ,let-bindings ,(do-codegen body)))
+	  (t
+	   `(let ,(map (lambda (b) `(,(car b) '#f)) let-bindings)
+	      (labels ,labels-bindings
+		      ,@(map (lambda (b) `(setf ,@b)) let-bindings)
+		      ,(do-codegen body))))
+	  )))
+
+(define (codegen-let* bindings body)
+  (if (null? bindings)
+      (do-codegen body)
+      (let* ((var       (car bindings))
+	     (value     (var-value var))
+	     (fullname  (fullname var))
+	     (strict?   (var-strict? var))
+	     (body      (codegen-let* (cdr bindings) body)))
+	(if (flic-lambda? value)
+	    ;; Some functions may need only the optimized or standard
+	    ;; entry points, but not both.
+	    (let ((optname     (optname var))
+		  (lambda      (codegen-lambda-aux value))
+		  (optimized?  (var-optimized-refs? var))
+		  (standard?   (var-standard-refs? var)))
+	      (when standard?
+		(setf body
+		      (add-let-binding
+		        (list fullname
+			      (maybe-make-box-value
+			        (codegen-curried-fn
+				  (if optimized? `(function ,optname) lambda)
+				  (var-strictness var))
+				strict?))
+			body)))
+	      (when optimized?
+		(setf body `(flet ((,optname ,@(cdr lambda))) ,body)))
+	      body)
+	    (add-let-binding (list fullname (do-codegen value)) body)))))
+
+(define (add-let-binding binding body)
+  (if (and (pair? body) (eq? (car body) 'let*))
+      `(let* (,binding ,@(cadr body)) ,@(cddr body))
+      `(let* (,binding) ,body)))
+
+
+(define-codegen flic-app (object)
+  (let ((fn         (flic-app-fn object))
+	(args       (flic-app-args object))
+	(saturated? (flic-app-saturated? object)))
+    (cond ((and saturated? (flic-pack? fn))
+	   ;; Saturated call to constructor
+	   (codegen-constructor-app-aux
+	     (flic-pack-con fn)
+	     (do-codegen-list args)))
+	  ((and saturated? (flic-ref? fn))
+	   ;; Saturated call to named function
+	   (let* ((var     (flic-ref-var fn))
+		  (optname (optname var))
+		  (argcode (do-codegen-list args)))
+	     `(,optname ,@argcode)))
+	  (else
+	   ;; Have to make a curried call to standard entry point.
+	   (let ((fncode   (do-codegen fn))
+		 (argcode  (do-codegen-list args)))
+	     (if (and (pair? fncode)
+		      (eq? (car fncode) 'force))
+		 `(funcall-force ,(cadr fncode) ,@argcode)
+		 `(funcall ,fncode ,@argcode))))
+	  )))
+
+(define (codegen-constructor-app-aux con argcode)
+  (let ((alg  (con-alg con)))
+    (cond ((eq? con (core-symbol ":"))
+	   `(cons ,@argcode))
+	  ((algdata-implemented-by-lisp? alg)
+	   (apply-maybe-lambda (cadr (con-lisp-fns con)) argcode))
+	  ((algdata-tuple? alg)
+	   `(make-tuple ,@argcode))
+	  (else
+	   `(make-tagged-data ,(con-tag con) ,@argcode)))))
+
+
+(define-codegen flic-ref (object)
+  (fullname (flic-ref-var object)))
+
+
+(define-codegen flic-const (object)
+  (let ((value   (flic-const-value object)))
+    (cond ((string? value)
+	   `(make-haskell-string ,value))
+	  ((char? value)
+	   ;; *** I think the parser ought to convert characters to their
+	   ;; *** ASCII codes instead of doing it here.  There are problems
+	   ;; *** with valid Haskell characters that can't be represented
+	   ;; *** portably as Lisp characters.
+	   (char->integer value))
+	  ((number? value)
+	   value)
+	  (else
+	   ;; It must be a ratio.  This is a bit of a hack - this depends on
+	   ;; the fact that 2 tuples are represented in the same manner as
+	   ;; rationals.  Hacked for strict rationals - jcp
+	   `(make-tuple ,(car value) ,(cadr value)))
+	  )))
+
+
+;;; Returns a function or constant, so doesn't need to delay result.
+;;; See flic-app for handling of saturated constructor calls.
+
+(define-codegen flic-pack (object)
+  (let* ((con        (flic-pack-con object))
+	 (arity      (con-arity con))
+	 (alg        (con-alg con))
+	 (tuple?     (algdata-tuple? alg))
+	 (strictness (con-slot-strict? con))
+	 (index      (con-tag con)))
+    (cond ((eq? con (core-symbol "Nil"))
+	   ''())
+	  ((eq? con (core-symbol "True"))
+	   ''#t)
+	  ((eq? con (core-symbol "False"))
+	   ''#f)
+	  ((eq? con (core-symbol ":"))
+	   '(function make-cons-constructor))
+	  ((algdata-implemented-by-lisp? alg)
+	   (let ((fn (cadr (con-lisp-fns con))))
+	     (if (eqv? (con-arity con) 0)
+		 fn
+		 (codegen-curried-fn
+		  (if (and (pair? fn) (eq? (car fn) 'lambda))
+		      fn
+		      `(function ,fn))
+		  strictness))))
+	  ((algdata-enum? alg)
+	   ;; All constructors have 0 arity; represent them just
+	   ;; by numbers.
+	   index)
+	  (tuple?
+	   ;; Only a single constructor for this type.
+	   (codegen-curried-fn
+	     `(make-tuple-constructor ,arity)
+	     strictness))
+	  ((eqv? arity 0)
+	   ;; No arguments to this constructor.
+	   `(make-tagged-data ,index))
+	  (else
+	   ;; General case.
+	   (codegen-curried-fn
+	    `(make-tagged-data-constructor ,index ,arity)
+	    strictness))
+	  )))
+
+
+
+;;; These expressions translate directly into their Lisp equivalents.
+
+(define-codegen flic-case-block (object)
+  `(block ,(flic-case-block-block-name object)
+     ,@(do-codegen-list (flic-case-block-exps object))))
+
+(define-codegen flic-return-from (object)
+  `(return-from ,(flic-return-from-block-name object)
+		,(do-codegen (flic-return-from-exp object))))
+
+(define-codegen flic-and (object)
+  `(and ,@(do-codegen-list (flic-and-exps object))))
+
+(define-codegen flic-if (object)
+  `(if ,(do-codegen (flic-if-test-exp object))
+       ,(do-codegen (flic-if-then-exp object))
+       ,(do-codegen (flic-if-else-exp object))))
+
+(define-codegen flic-sel (object)
+  (codegen-flic-sel-aux
+    (flic-sel-con object)
+    (flic-sel-i object)
+    (do-codegen (flic-sel-exp object))))
+
+(define (codegen-flic-sel-aux con index exp)
+  (let* ((alg      (con-alg con))
+	 (tuple?   (algdata-tuple? alg))
+	 (arity    (con-arity con)))
+    (cond ((eq? con (core-symbol ":"))
+	   (if (eqv? index 0)
+	       `(car ,exp)
+	       `(cdr ,exp)))
+	  ((algdata-implemented-by-lisp? alg)
+	   (apply-maybe-lambda (list-ref (cddr (con-lisp-fns con)) index)
+			       (list exp)))
+	  (tuple?
+	   `(tuple-select ,arity ,index ,exp))
+	  (else
+	   `(tagged-data-select ,arity ,index ,exp))
+	  )))
+
+(define-codegen flic-is-constructor (object)
+  (codegen-flic-is-constructor-aux
+    (flic-is-constructor-con object)
+    (do-codegen (flic-is-constructor-exp object))))
+
+(define (codegen-flic-is-constructor-aux con exp)
+  (let ((type (con-alg con)))
+    (cond ((eq? type (core-symbol "Bool"))
+	   (if (eq? con (core-symbol "True"))
+	       exp
+	       `(not ,exp)))
+	  ((eq? type (core-symbol "List"))
+	   (if (eq? con (core-symbol ":"))
+	       `(pair? ,exp)
+	       `(null? ,exp)))
+	  ((algdata-implemented-by-lisp? type)
+	   (let ((fn (car (con-lisp-fns con))))
+	     (apply-maybe-lambda fn (list exp))))
+	  ((algdata-tuple? type)
+	   ;; This should never happen.
+	   ''#t)
+	  ((algdata-enum? type)
+	   `(eqv? (the fixnum ,exp) (the fixnum ,(con-tag con))))
+	  (else
+	   `(eqv? (the fixnum (constructor-number ,exp))
+		  (the fixnum ,(con-tag con))))
+	  )))
+
+
+(define-codegen flic-con-number (object)
+  (let ((type   (flic-con-number-type object))
+	(exp    (do-codegen (flic-con-number-exp object))))
+    `(the fixnum
+	  ,(cond ((eq? type (core-symbol "Bool"))
+		  `(if ,exp 1 0))
+		 ((eq? type (core-symbol "List"))
+		  `(if (pair? ,exp) 0 1))
+		 ((algdata-tuple? type)
+		  ;; This should never happen.
+		  0)
+		 ((algdata-implemented-by-lisp? type)
+		  (let ((var (gensym)))
+		    `(let ((,var ,exp))
+		       (cond ,@(map (lambda (con)
+				      `(,(apply-maybe-lambda
+					  (car (con-lisp-fns con))
+					  (list var))
+					',(con-tag con)))
+				    (algdata-constrs type))
+			     (else (error "No constructor satisfies ~A.~%"
+					  ',(def-name type)))))))
+		 ((algdata-enum? type)
+		  exp)
+		 (else
+		  `(constructor-number ,exp))
+		 ))
+    ))
+
+
+
+;;;======================================================================
+;;; Utility functions
+;;;======================================================================
+
+;;; Here are some helper functions for handing boxing and unboxing
+;;; of values.
+;;; maybe-make-box-delay is used to box forms that are "expensive" to
+;;; compute; maybe-make-box-value is used to box forms like constants
+;;; or functions that are "cheap" to compute eagerly.
+;;; Maybe-unbox is used to unbox a form that returns a boxed result.
+
+(define (maybe-make-box-delay form unboxed?)
+  (if unboxed?
+      form
+      `(delay ,form)))
+
+(define (maybe-make-box-value form unboxed?)
+  (if unboxed?
+      form
+      `(box ,form)))
+
+(define (maybe-unbox form unboxed?)
+  (if unboxed?
+      `(force ,form)
+      form))
+
+
+;;; These two var slots are filled in lazily by the code generator,
+;;; since most vars generated don't need them.  You should always
+;;; use these functions instead of accessing the structure slot
+;;; directly.
+
+(define (fullname var)
+  (or (var-fullname var)
+      (setf (var-fullname var)
+	    (if (var-toplevel? var)
+		;; For toplevel names, use module name glued onto base names.
+		;; These are always interned symbols.
+		(if (def-core? var)
+		    (symbol-append '|*Core:| (def-name var))
+		    (symbol-append (def-module var) '\: (def-name var)))
+		;; Otherwise, make sure we have a gensym.
+		;; The uniquification of interned symbols is required
+		;; because there may be multiple nested bindings of the
+		;; same name, and we want to be able to distinguish between
+		;; the different bindings.
+		(let ((name  (def-name var)))
+		  (if (gensym? name)
+		      name
+		      (gensym (symbol->string name))))))
+      ))
+
+(define (optname var)
+  (or (var-optimized-entry var)
+      (let ((name  (string-append (symbol->string (fullname var)) "/OPT")))
+	(setf (var-optimized-entry var)
+	      (if (var-toplevel? var)
+		  (string->symbol name)
+		  (gensym name))))))
+
+
+
+;;;======================================================================
+;;; Exported functions
+;;;======================================================================
+
+;;; This handles types exported to lisp from Haskell
+;;; *** Is this really supposed to create variable bindings as
+;;; *** opposed to function bindings???
+;;; *** I assume all of these functions want strict arguments and return
+;;; *** strict results, even if the data structures contain boxed values.
+
+(define (codegen-exported-types mods)
+  (let ((defs '()))
+    (dolist (m mods)
+      (dolist (a (module-alg-defs m))
+        (when (algdata-export-to-lisp? a)
+	  (dolist (c (algdata-constrs a))
+	    (setf defs (nconc (codegen-constr c) defs))))))
+    `(begin ,@defs)))
+
+(define (codegen-constr c)
+  (let ((lisp-fns (con-lisp-fns c)))
+    (if c
+        (let ((res
+	       `(,(codegen-lisp-predicate (car lisp-fns) c)
+		 ,(codegen-lisp-constructor (cadr lisp-fns) c)
+		 ,@(codegen-lisp-accessors
+		    (cddr lisp-fns) (con-slot-strict? c) c 0))))
+	  (when (memq 'codegen (dynamic *printers*))
+	    (dolist (d res)
+	      (pprint* d)))
+	  res)
+	'())))
+
+(define (codegen-lisp-predicate name c)
+  `(define (,name x)
+     ,(codegen-flic-is-constructor-aux c 'x)))
+
+(define (codegen-lisp-constructor name c)
+  (let ((strictness (con-slot-strict? c))
+	(args       '())
+	(exps       '()))
+    (dolist (s strictness)
+      (let ((arg  (gensym)))
+	(push arg args)
+	(push (if s arg `(box ,arg)) exps)))
+    `(define (,name ,@(nreverse args))
+	 ,(codegen-constructor-app-aux c (nreverse exps)))))
+
+(define (codegen-lisp-accessors names strictness c i)
+  (declare (type fixnum i))
+  (if (null? names)
+      '()
+      (let ((body  (codegen-flic-sel-aux c i 'x)))
+	(when (not (car strictness))
+	  (setf body `(force ,body)))
+	(cons `(define (,(car names) x) ,body)
+	      (codegen-lisp-accessors (cdr names) (cdr strictness) c (+ i 1))))
+    ))
+
+
+
+;;; This is a special hack needed due to brain-dead common lisp problems.
+;;; This allows the user to place lambda defined functions in ImportLispType
+;;; *** I'm not convinced this is necessary;  ((lambda ...) args)
+;;; *** is perfectly valid Common Lisp syntax!
+
+(define (apply-maybe-lambda fn args)
+  (if (and (pair? fn)
+	   (eq? (car fn) 'lambda))
+      `(funcall ,fn ,@args)
+      `(,fn ,@args)))
diff --git a/backend/interface-codegen.scm b/backend/interface-codegen.scm
new file mode 100644
index 0000000..50c8630
--- /dev/null
+++ b/backend/interface-codegen.scm
@@ -0,0 +1,200 @@
+
+;;; This generates code for vars defined in an interface.  This looks at
+;;; annotations and fills in the slots of the var definition.
+
+(define (haskell-codegen/interface mods)
+  (codegen/interface (car mods)))
+
+(define (codegen/interface mod)
+ (let ((code '()))
+  (dolist (d (module-decls mod))
+    (when (not (signdecl? d))
+      (error 'bad-decl))
+    (dolist (var (signdecl-vars d))
+     (let ((v (var-ref-var var)))
+      (setf (var-type v) (var-signature v))
+      (setf (var-toplevel? v) '#t)
+      (let ((a (lookup-annotation v '|Complexity|)))
+	(when (not (eq? a '#f))
+	  (setf (var-complexity v)
+		(car (annotation-value-args a)))))
+      (let ((a (lookup-annotation v '|LispName|)))
+	(when (not (eq? a '#f))
+	   (let ((lisp-entry (generate-lisp-entry v a)))
+	     (push lisp-entry code)
+	     (when (memq 'codegen (dynamic *printers*))
+  	        (pprint* lisp-entry))))))))
+  `(begin ,@code)))
+
+(define (generate-lisp-entry v a)
+  (let ((lisp-name (read-lisp-object (car (annotation-value-args a))))
+	(type (maybe-expand-io-type (gtype-type (var-type v)))))
+    (setf (var-optimized-entry v) lisp-name)
+    (if (arrow-type? type)
+	(codegen-lisp-fn v (gather-arg-types type))
+	(codegen-lisp-const v type))))
+
+(define (codegen-lisp-fn var arg-types)
+  (let* ((aux-definition '())
+	 (wrapper? (foreign-fn-needs-wrapper? var arg-types))
+	 (strictness-annotation (lookup-annotation var '|Strictness|))
+	 (strictness (determine-strictness strictness-annotation arg-types))
+	 (temps (gen-temp-names strictness)))
+    (setf (var-strict? var) '#t)
+    (setf (var-arity var) (length strictness))
+    (setf (var-strictness var) strictness)
+    (when wrapper?
+	  (mlet (((code name)
+		  (make-wrapper-fn var (var-optimized-entry var) arg-types)))
+	      (setf (var-optimized-entry var) name)
+	      (setf aux-definition (list code))))
+    `(begin ,@aux-definition
+	    (define ,(fullname var)
+		    ,(maybe-make-box-value
+		       (codegen-curried-fn
+			(if wrapper?
+			    `(function ,(var-optimized-entry var))
+			    `(lambda ,temps
+			          (,(var-optimized-entry var) ,@temps)))
+			 (var-strictness var))
+		       '#t)))))
+
+(define (determine-strictness a args)
+  (if (eq? a '#f)
+      (map (lambda (x) (declare (ignore x)) '#t) (cdr args))
+      (parse-strictness (car (annotation-value-args a)))))
+
+(define (codegen-lisp-const var type)
+  (let ((conversion-fn (output-conversion-fn type)))
+    (setf (var-strict? var) '#f)
+    (setf (var-arity var) 0)
+    (setf (var-strictness var) '())
+    `(define ,(fullname var)
+             (delay
+	       ,(if (eq? conversion-fn '#f)
+		    (var-optimized-entry var)
+		    `(,@conversion-fn ,(var-optimized-entry var)))))))
+
+(define (maybe-expand-io-type ty)
+  (cond ((and (ntycon? ty)
+	      (eq? (ntycon-tycon ty) (core-symbol "IO")))
+	 (**ntycon (core-symbol "Arrow")
+		   (list (**ntycon (core-symbol "SystemState") '())
+			 (**ntycon (core-symbol "IOResult")
+				   (ntycon-args ty)))))
+	((arrow-type? ty)
+	 (**ntycon (core-symbol "Arrow")
+		   (list (car (ntycon-args ty))
+			 (maybe-expand-io-type (cadr (ntycon-args ty))))))
+	(else ty)))
+
+(define (gather-arg-types type)
+  (if (arrow-type? type)
+      (let ((a (ntycon-args type)))
+	(cons (car a) (gather-arg-types (cadr a))))
+      (list type)))
+	   
+(define (input-conversion-fn ty)
+  (if (ntycon? ty)
+      (let ((tycon (ntycon-tycon ty)))
+	(cond ((eq? tycon (core-symbol "String"))
+	       (lambda (x) `(haskell-string->string ,x)))
+	      ((eq? tycon (core-symbol "List"))  ; needs to convert elements
+	       (let ((var (gensym "X"))
+		     (inner-fn (input-conversion-fn (car (ntycon-args ty)))))
+		 (lambda (x) `(haskell-list->list
+			       (lambda (,var)
+				 ,(if (eq? inner-fn '#f)
+				      var
+				      (funcall inner-fn var)))
+			       ,x))))
+	      ((eq? tycon (core-symbol "Char"))
+	       (lambda (x) `(integer->char ,x)))
+	      (else '#f)))
+      '#f))
+
+(define (output-conversion-fn ty)
+  (if (ntycon? ty)
+      (let ((tycon (ntycon-tycon ty)))
+	(cond ((eq? tycon (core-symbol "String"))
+	       (lambda (x) `(make-haskell-string ,x)))
+	      ((eq? tycon (core-symbol "List"))
+	       (let ((var (gensym "X"))
+		     (inner-fn (output-conversion-fn (car (ntycon-args ty)))))
+		 (lambda (x) `(list->haskell-list
+			       (lambda (,var)
+				 ,(if (eq? inner-fn '#f)
+				      var
+				      (funcall inner-fn var)))
+			       ,x))))
+	      ((eq? tycon (core-symbol "UnitType"))
+	       (lambda (x) `(insert-unit-value ,x)))
+	      ((eq? tycon (core-symbol "IOResult"))
+	       (lambda (x)
+		 (let ((c1 (output-conversion-fn (car (ntycon-args ty)))))
+		   `(box ,(apply-conversion c1 x)))))
+	      (else '#f)))
+      '#f))
+
+(define (apply-conversion fn x)
+  (if (eq? fn '#f)
+      x
+      (funcall fn x)))
+
+(define (foreign-fn-needs-wrapper? var args)
+ (if (lookup-annotation var '|NoConversion|)
+     '#f
+     (ffnw-1 args)))
+
+(define (ffnw-1 args)
+  (if (null? (cdr args))
+      (not (eq? (output-conversion-fn (car args)) '#f))
+      (or (not (eq? (input-conversion-fn (car args)) '#f))
+	  (systemstate? (car args))
+	  (ffnw-1 (cdr args)))))
+
+(define (make-wrapper-fn var fn args)
+  (mlet ((new-fn (symbol-append (fullname var) '|/wrapper|))
+	 (avars (gen-temp-names (cdr args)))
+	 (ignore-state? (systemstate? (cadr (reverse args))))
+	 ((arg-conversions res-conversion)
+	  (collect-conversion-fns avars args)))
+     (values
+      `(define (,new-fn ,@avars)
+	 ,@(if ignore-state? `((declare (ignore ,(car (last avars)))))
+	                     '())
+	 ,@arg-conversions
+	 ,(apply-conversion res-conversion
+			    `(,fn ,@(if ignore-state?
+					(butlast avars)
+					avars))))
+      new-fn)))
+
+(define (collect-conversion-fns avars args)
+  (if (null? avars)
+      (values '() (output-conversion-fn (car args)))
+      (mlet ((fn (input-conversion-fn (car args)))
+	     ((c1 r) (collect-conversion-fns (cdr avars) (cdr args))))
+	 (values (if (eq? fn '#f)
+		     c1
+		     `((setf ,(car avars) ,(funcall fn (car avars))) ,@c1))
+		 r))))
+
+(define (arrow-type? x)
+  (and (ntycon? x)
+       (eq? (ntycon-tycon x) (core-symbol "Arrow"))))
+
+(define (systemstate? x)
+  (and (ntycon? x)
+       (eq? (ntycon-tycon x) (core-symbol "SystemState"))))
+
+(define (gen-temp-names l)
+  (gen-temp-names-1 l '(A B C D E F G H I J K L M N O P)))
+
+(define (gen-temp-names-1 l1 l2)
+  (if (null? l1)
+      '()
+      (if (null? l2)
+	  (gen-temp-names-1 l1 (list (gensym "T")))
+	  (cons (car l2) (gen-temp-names-1 (cdr l1) (cdr l2))))))
+
diff --git a/backend/optimize.scm b/backend/optimize.scm
new file mode 100644
index 0000000..1624e35
--- /dev/null
+++ b/backend/optimize.scm
@@ -0,0 +1,1986 @@
+;;; optimize.scm -- flic optimizer
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  7 May 1992
+;;;
+;;;
+;;; The optimizer does these kinds of program transformations:
+;;;
+;;; * remove unreferenced variable bindings.
+;;;
+;;; * constant folding and various other kinds of compile-time
+;;;   evaluation.
+;;;
+;;; * beta reduction (replace references to variables bound to simple
+;;;   expressions with the expression)
+;;; 
+
+
+;;; Since some of the optimizations can make additional transformations
+;;; possible, we want to make multiple iteration passes.  But since each
+;;; pass is likely to have diminishing benefits, we don't want to keep
+;;; iterating indefinitely.  So establish a fairly arbitrary cutoff point.
+;;; The value is based on empirical results from compiling the prelude.
+
+(define *max-optimize-iterations* 5)
+(define *optimize-foldr-iteration* 0)  ; when to inline foldr
+(define *optimize-build-iteration* 0)  ; when to inline build
+(define *current-optimize-iteration* 0)
+
+
+;;; Flags for enabling various optimizations
+
+(define *all-optimizers* '(foldr inline constant lisp))
+(define *optimizers* *all-optimizers*)
+
+
+;;; Used to note whether we are doing the various optimizations
+
+(define-local-syntax (do-optimization? o)
+  `(memq ,o (dynamic *optimizers*)))
+
+(define *do-foldr-optimizations* (do-optimization? 'foldr))
+(define *do-inline-optimizations* (do-optimization? 'inline))
+(define *do-constant-optimizations* (do-optimization? 'constant))
+
+
+;;; If the foldr optimization is enabled, bind the corresponding
+;;; variables to these values instead of the defaults.
+
+(define *foldr-max-optimize-iterations* 15)
+(define *foldr-optimize-foldr-iteration* 8)
+(define *foldr-optimize-build-iteration* 5)
+
+
+;;; Some random other variables
+
+(define *structured-constants* '())
+(define *structured-constants-table* '#f)
+(define *lambda-depth* 0)
+(define *local-bindings* '())
+
+
+;;; This is for doing some crude profiling.  
+;;; Comment out the body of the macro to disable profiling.
+
+;;; Here are current counts from compiling the prelude:
+;;; (LET-REMOVE-UNUSED-BINDING . 5835) 
+;;; (REF-INLINE-SINGLE-REF . 2890) 
+;;; (REF-INLINE . 2692) 
+;;; (LET-EMPTY-BINDINGS . 2192) 
+;;; (APP-LAMBDA-TO-LET . 1537) 
+;;; (APP-MAKE-SATURATED . 416) 
+;;; (LET-HOIST-RETURN-FROM . 310) 
+;;; (CASE-BLOCK-IDENTITY . 273) 
+;;; (CASE-BLOCK-DEAD-CODE . 234) 
+;;; (CASE-BLOCK-TO-IF . 212) 
+;;; (SEL-FOLD-VAR . 211) 
+;;; (APP-HOIST-LET . 190) 
+;;; (LET-HOIST-LAMBDA . 181) 
+;;; (FOLDR-INLINE . 176) 
+;;; (AND-UNARY . 172) 
+;;; (LAMBDA-COMPRESS . 168) 
+;;; (APP-FOLD-SELECTOR . 141) 
+;;; (BUILD-INLINE-LAMBDA . 134) 
+;;; (LET-COMPRESS . 134) 
+;;; (IF-FOLD . 128) 
+;;; (INTEGER-TO-INT-CONSTANT-FOLD . 124) 
+;;; (AND-COMPRESS . 94) 
+;;; (APP-COMPRESS . 93) 
+;;; (FOLDR-CONS-IDENTITY . 69) 
+;;; (IF-COMPRESS-TEST . 65) 
+;;; (IF-HOIST-LAMBDA . 61) 
+;;; (APP-HOIST-STRUCTURED-CONSTANT . 60) 
+;;; (FOLDR-PRIM-APPEND-INLINE . 55) 
+;;; (FOLDR-BUILD-IDENTITY . 40) 
+;;; (CASE-BLOCK-DISCARD-REDUNDANT-TEST . 37) 
+;;; (FOLDR-NIL-IDENTITY . 36) 
+;;; (LET-HOIST-INVARIANT-ARGS . 30) 
+;;; (FOLDR-HOIST-LET . 28) 
+;;; (CON-NUMBER-FOLD-TUPLE . 21) 
+;;; (FOLDR-CONS-NIL-IDENTITY . 15) 
+;;; (AND-CONTAINS-TRUE . 14) 
+;;; (IF-IDENTITY-INVERSE . 8) 
+;;; (IF-HOIST-RETURN-FROM . 7) 
+;;; (CASE-BLOCK-HOIST-LET . 7) 
+;;; (INTEGER-TO-INT-IDENTITY . 7) 
+;;; (APP-PACK-IDENTITY . 2) 
+;;; (CON-NUMBER-FOLD . 2) 
+;;; (IF-IDENTITY . 2) 
+;;; (INT-TO-INTEGER-CONSTANT-FOLD . 2) 
+;;; (LET-HOIST-STRUCTURED-CONSTANT . 1) 
+
+
+(define-local-syntax (record-hack type . args)
+  (declare (ignore args))
+  `',type
+;  `(record-hack-aux ,type ,@args)
+  )
+
+(define *hacks-done* '())
+
+(define (record-hack-aux type . args)
+  ;; *** debug
+  ;; (format '#t "~s ~s~%" type args)
+  (declare (ignore args))
+  (let ((stuff  (assq type (car (dynamic *hacks-done*)))))
+    (if stuff
+	(incf (cdr stuff))
+	(push (cons type 1) (car (dynamic *hacks-done*))))))
+
+(define (total-hacks)
+  (let ((totals  '()))
+    (dolist (alist *hacks-done*)
+      (dolist (entry alist)
+	(let ((stuff  (assq (car entry) totals)))
+	  (if stuff
+	      (setf (cdr stuff) (+ (cdr stuff) (cdr entry)))
+	      (push (cons (car entry) (cdr entry)) totals)))))
+    totals))
+
+
+;;; This is the main entry point.
+
+(define (optimize-top object)
+  (dynamic-let ((*structured-constants*       '())
+		(*structured-constants-table* (make-table))
+		(*lambda-depth*               0)
+		(*local-bindings*             '())
+		(*do-inline-optimizations*
+		  (do-optimization? 'inline))
+		(*do-constant-optimizations*
+		  (do-optimization? 'constant))
+		(*max-optimize-iterations*
+		  (if (do-optimization? 'foldr)
+		      (dynamic *foldr-max-optimize-iterations*)
+		      (dynamic *max-optimize-iterations*)))
+		(*optimize-foldr-iteration*
+		  (if (do-optimization? 'foldr)
+		      (dynamic *foldr-optimize-foldr-iteration*)
+		      (dynamic *optimize-foldr-iteration*)))
+		(*optimize-build-iteration*
+		  (if (do-optimization? 'foldr)
+		      (dynamic *foldr-optimize-build-iteration*)
+		      (dynamic *optimize-build-iteration*))))
+    (setf *hacks-done* '())
+    (dotimes (i (dynamic *max-optimize-iterations*))
+      (dynamic-let ((*current-optimize-iteration*  i))
+;; debug	    (*duplicate-object-table*      (make-table)))
+	(when (memq 'optimize-extra (dynamic *printers*))
+	  (format '#t "~%Optimize pass ~s:" i)
+	  (pprint object))
+        (push '() *hacks-done*)
+	(setf object (optimize-flic-let-aux object '#t))))
+    (setf (flic-let-bindings object)
+	  (nconc (nreverse (dynamic *structured-constants*))
+		 (flic-let-bindings object))))
+  (install-uninterned-globals (flic-let-bindings object))
+  (postoptimize object)
+  object)
+
+
+(define-flic-walker optimize (object))
+
+;;; debugging stuff
+;;; 
+;;; (define *duplicate-object-table* (make-table))
+;;; 
+;;; (define (new-optimize object)
+;;;   (if (table-entry (dynamic *duplicate-object-table*) object)
+;;;       (error "Duplicate object ~s detected." object)
+;;;       (begin
+;;; 	(setf (table-entry (dynamic *duplicate-object-table*) object) '#t)
+;;; 	(old-optimize object))))
+;;; 
+;;; (lisp:setf (lisp:symbol-function 'old-optimize)
+;;; 	   (lisp:symbol-function 'optimize))
+;;; (lisp:setf (lisp:symbol-function 'optimize)
+;;;  	   (lisp:symbol-function 'new-optimize))
+
+(define (optimize-list objects)
+  (optimize-list-aux objects)
+  objects)
+
+(define (optimize-list-aux objects)
+  (if (null? objects)
+      '()
+      (begin
+        (setf (car objects) (optimize (car objects)))
+	(optimize-list-aux (cdr objects)))))
+
+
+;;; Compress nested lambdas.  This hack is desirable because saturating
+;;; applications within the lambda body effectively adds additional 
+;;; parameters to the function.
+
+;;; *** Maybe this should look for hoistable constant lambdas too.
+
+(define-optimize flic-lambda (object)
+  (let ((vars  (flic-lambda-vars object)))
+    (dynamic-let ((*lambda-depth*   (1+ (dynamic *lambda-depth*)))
+		  (*local-bindings* (cons vars (dynamic *local-bindings*))))
+      (dolist (var vars)
+	(setf (var-referenced var) 0))
+      (let ((new-body  (optimize (flic-lambda-body object))))
+	(setf (flic-lambda-body object) new-body)
+	(cond ((is-type? 'flic-lambda new-body)
+	       (record-hack 'lambda-compress)
+	       (setf (flic-lambda-vars object)
+		     (nconc (flic-lambda-vars object)
+			    (flic-lambda-vars new-body)))
+	       (setf (flic-lambda-body object) (flic-lambda-body new-body)))
+	      (else
+	       '#f))
+	object))))
+
+
+;;; For let, first mark all variables as unused and check for "simple"
+;;; binding values that permit beta reduction.  Then walk the subexpressions.
+;;; Finally discard any bindings that are still marked as unused.
+;;; *** This fails to detect unused recursive variables.
+
+(define-optimize flic-let (object)
+  (optimize-flic-let-aux object '#f))
+
+(define (optimize-flic-let-aux object toplevel?)
+  (let ((bindings      (flic-let-bindings object))
+	(recursive?    (flic-let-recursive? object)))
+    ;; *** This handling of *local-bindings* isn't quite right since
+    ;; *** it doesn't account for the sequential nature of bindings
+    ;; *** in a non-recursive let, but it's close enough.  We won't
+    ;; *** get any semantic errors, but it might miss a few optimizations.
+    (dynamic-let ((*local-bindings*
+		    (if (and recursive? (not toplevel?))
+			(cons bindings (dynamic *local-bindings*))
+			(dynamic *local-bindings*))))
+      (optimize-flic-let-bindings bindings recursive? toplevel?)
+      (dynamic-let ((*local-bindings*
+		      (if (and (not recursive?) (not toplevel?))
+			  (cons bindings (dynamic *local-bindings*))
+			  (dynamic *local-bindings*))))
+	(setf (flic-let-body object) (optimize (flic-let-body object))))
+      ;; Check for unused bindings and other rewrites.
+      ;; Only do this for non-toplevel lets.
+      (if toplevel?
+	  object
+	  (optimize-flic-let-rewrite object bindings recursive?)))))
+
+(define (optimize-flic-let-bindings bindings recursive? toplevel?)
+  ;; Initialize
+  (dolist (var bindings)
+    (setf (var-referenced var) 0)
+    (setf (var-fn-referenced var) 0)
+    (when (is-type? 'flic-lambda (var-value var))
+      (dolist (v (flic-lambda-vars (var-value var)))
+	(setf (var-arg-invariant? v) '#t)
+	(setf (var-arg-invariant-value v) '#f))))
+  ;; Traverse value subforms
+  (do ((bindings bindings (cdr bindings)))
+      ((null? bindings) '#f)
+      (let* ((var  (car bindings))
+	     (val  (var-value var)))
+	(if (and (is-type? 'flic-app val)
+		 (dynamic *do-constant-optimizations*)
+		 (let ((fn   (flic-app-fn val))
+		       (args (flic-app-args val)))
+		   (if recursive?
+		       (structured-constant-app-recursive?
+			 fn args bindings (list var))
+		       (structured-constant-app? fn args))))
+	    ;; Variable is bound to a structured constant.  If this
+	    ;; isn't already a top-level binding, replace the value
+	    ;; of the constant with a reference to a top-level variable
+	    ;; that is in turn bound to the constant expression.
+	    ;; binding to top-level if this is a new constant.
+	    ;; *** Maybe we should also look for variables bound
+	    ;; *** to lambdas, that can also be hoisted to top level.
+	    (when (not toplevel?)
+	      (multiple-value-bind (con args cvar)
+		  (enter-structured-constant-aux val '#t)
+		(record-hack 'let-hoist-structured-constant)
+		(if cvar
+		    (setf (var-value var) (make-flic-ref cvar))
+		    (add-new-structured-constant var con args))))
+	    (begin
+	      ;; If this is a function that's a candidate for foldr/build
+	      ;; optimization, stash the value away prior to
+	      ;; inlining the calls.
+	      ;; *** We might try to automagically detect functions
+	      ;; *** that are candidates for these optimizations here,
+	      ;; *** but have to watch out for infinite loops!
+	      (when (and (var-force-inline? var)
+			 (eqv? (the fixnum
+				    (dynamic *current-optimize-iteration*))
+			       (the fixnum
+				    (dynamic *optimize-build-iteration*)))
+			 (is-type? 'flic-lambda val)
+			 (or (is-foldr-or-build-app? (flic-lambda-body val))))
+		(setf (var-inline-value var) (copy-flic-top val)))
+	      ;; Then walk value normally.
+	      (let ((new-val  (optimize val)))
+		(setf (var-value var) new-val)
+		(setf (var-simple? var)
+		      (or (var-force-inline? var)
+			  (and (not (var-selector-fn? var))
+			       (can-inline?
+				 new-val
+				 (if recursive? bindings '())
+				 toplevel?))))))
+	  ))))
+
+
+(define (is-foldr-or-build-app? exp)
+  (typecase exp
+    (flic-app
+     (let ((fn  (flic-app-fn exp)))
+       (and (is-type? 'flic-ref fn)
+	    (or (eq? (flic-ref-var fn) (core-symbol "foldr"))
+		(eq? (flic-ref-var fn) (core-symbol "build"))))))
+    (flic-let
+     (is-foldr-or-build-app? (flic-let-body exp)))
+    (flic-ref
+     (let ((val  (var-value (flic-ref-var exp))))
+       (and val (is-foldr-or-build-app? val))))
+    (else
+     '#f)))
+
+
+(define (optimize-flic-let-rewrite object bindings recursive?)
+  ;; Delete unused variables from the list.
+  (setf bindings
+	(list-delete-if
+	  (lambda (var)
+	    (cond ((var-toplevel? var)
+		   ;; This was a structured constant hoisted to top-level.
+		   '#t)
+	          ((eqv? (the fixnum (var-referenced var)) (the fixnum 0))
+		   (record-hack 'let-remove-unused-binding var)
+		   '#t)
+		  ((eqv? (the fixnum (var-referenced var)) (the fixnum 1))
+		   (setf (var-single-ref var) (dynamic *lambda-depth*))
+		   '#f)
+		  (else
+		   (setf (var-single-ref var) '#f)
+		   '#f)))
+	  bindings))
+  ;; Add extra bindings for reducing functions with invariant
+  ;; arguments.  Hopefully some of the extra bindings will go
+  ;; away in future passes!
+  (setf (flic-let-bindings object)
+	(setf bindings (add-stuff-for-invariants bindings)))
+  ;; Look for other special cases.
+  (cond ((null? bindings)
+	 ;; Simplifying the expression by getting rid of the LET may
+	 ;; make it possible to do additional optimizations on the 
+	 ;; next pass.
+	 (record-hack 'let-empty-bindings)
+	 (flic-let-body object))
+	((is-type? 'flic-return-from (flic-let-body object))
+	 ;; Hoist return-from outside of LET.  This may permit
+	 ;; further optimizations by an enclosing case-block.
+	 (record-hack 'let-hoist-return-from)
+	 (let* ((body       (flic-let-body object))
+		(inner-body (flic-return-from-exp body)))
+	   (setf (flic-return-from-exp body) object)
+	   (setf (flic-let-body object) inner-body)
+	   body))
+	((and (not recursive?)
+	      (is-type? 'flic-let (flic-let-body object))
+	      (not (flic-let-recursive? (flic-let-body object))))
+	 ;; This is purely to produce more compact code.
+	 (record-hack 'let-compress)
+	 (let ((body  (flic-let-body object)))
+	   (setf (flic-let-bindings object)
+		 (nconc bindings (flic-let-bindings body)))
+	   (setf (flic-let-body object) (flic-let-body body))
+	   object))
+	((is-type? 'flic-lambda (flic-let-body object))
+	 ;; Hoist lambda outside of LET.  This may permit
+	 ;; merging of nested lambdas on a future pass.
+	 (record-hack 'let-hoist-lambda)
+	 (let* ((body       (flic-let-body object))
+		(inner-body (flic-lambda-body body)))
+	   (setf (flic-lambda-body body) object)
+	   (setf (flic-let-body object) inner-body)
+	   body))
+	(else
+	 object))
+  )
+
+;;; Look for constant-folding and structured constants here.
+
+(define-optimize flic-app (object)
+  (optimize-flic-app-aux object))
+
+(define (optimize-flic-app-aux object)
+  (let ((new-fn   (optimize (flic-app-fn object)))
+	(new-args (optimize-list (flic-app-args object))))
+    (typecase new-fn
+      (flic-ref
+       ;; The function is a variable.
+       (let* ((var    (flic-ref-var new-fn))
+	      (val    (var-value var))
+	      (n      (length new-args))
+	      (arity  (guess-function-arity var)))
+	 (cond ((and arity (< (the fixnum n) (the fixnum arity)))
+		;; This is a first-class call that is not fully saturated.
+		;; Make it saturated by wrapping a lambda around it.
+		(setf new-fn
+		      (do-app-make-saturated object new-fn new-args arity n))
+		(setf new-args '()))
+	       ((var-selector-fn? var)
+		;; This is a saturated call to a selector.  We might
+		;; be able to inline the call.
+		(multiple-value-bind (fn args)
+		    (try-to-fold-selector var new-fn new-args)
+		  (setf new-fn fn)
+		  (setf new-args args)))
+	       ((and (not (var-toplevel? var))
+		     (is-type? 'flic-lambda val))
+		;; This is a saturated call to a local function.
+		;; Increment its reference count and note if any of
+		;; the arguments are invariant.
+		(incf (var-fn-referenced var))
+		(note-invariant-args new-args (flic-lambda-vars val)))
+	       (else
+		(let ((magic  (magic-optimize-function var)))
+		  (when magic
+		    (multiple-value-bind (fn args)
+			(funcall magic new-fn new-args)
+		      (setf new-fn fn)
+		      (setf new-args args)))))
+	       )))
+      (flic-lambda
+       ;; Turn application of lambda into a let.
+       (multiple-value-bind (fn args)
+	   (do-lambda-to-let-aux new-fn new-args)
+	 (setf new-fn fn)
+	 (setf new-args args)))
+      (flic-pack
+       (let ((con  (flic-pack-con new-fn))
+	     (temp '#f))
+	 (when (eqv? (length new-args) (con-arity con))
+	   (cond ((and (dynamic *do-constant-optimizations*)
+		       (every-1 (function structured-constant?) new-args))
+		  ;; This is a structured constant that
+		  ;; can be replaced with a top-level binding.
+		  (setf (flic-app-fn object) new-fn)
+		  (setf (flic-app-args object) new-args)
+		  (record-hack 'app-hoist-structured-constant object)
+		  (setf new-fn (enter-structured-constant object '#t))
+		  (setf new-args '()))
+		 ((and (setf temp (is-selector? con 0 (car new-args)))
+		       (is-selector-list? con 1 temp (cdr new-args)))
+		  ;; This is an expression like (cons (car x) (cdr x)).
+		  ;; Replace it with just plain x to avoid reconsing.
+		  (record-hack 'app-pack-identity new-fn)
+		  (setf new-fn (copy-flic-top temp))
+		  (setf new-args '()))
+		 ))))
+      (flic-let
+       ;; Hoist let to surround entire application.
+       ;; Simplifying the function being applied may permit further
+       ;; optimizations on next pass.
+       ;; (We might try to hoist lets in the argument expressions, too,
+       ;; but I don't think that would lead to any real simplification
+       ;; of the code.)
+       (record-hack 'app-hoist-let)
+       (setf (flic-app-fn object) (flic-let-body new-fn))
+       (setf (flic-app-args object) new-args)
+       (setf new-args '())
+       (setf (flic-let-body new-fn) object)
+       )
+      (flic-app
+       ;; Try to compress nested applications.
+       ;; This may make the call saturated and permit further optimizations
+       ;; on the next pass.
+       (record-hack 'app-compress)
+       (setf new-args (nconc (flic-app-args new-fn) new-args))
+       (setf new-fn (flic-app-fn new-fn)))
+      )
+    (if (null? new-args)
+	new-fn
+	(begin
+	  (setf (flic-app-fn object) new-fn)
+	  (setf (flic-app-args object) new-args)
+	  object))
+    ))
+
+(define (guess-function-arity var)
+  (or (let ((value  (var-value var)))
+	(and value
+	     (is-type? 'flic-lambda value)
+	     (length (flic-lambda-vars value))))
+      (var-arity var)))
+
+(define (do-app-make-saturated app fn args arity nargs)
+  (declare (type fixnum arity nargs))
+  (record-hack 'app-make-saturated fn args)
+  (let ((newvars  '())
+	(newargs  '()))
+    (dotimes (i (- arity nargs))
+      (declare (type fixnum i))
+      (let ((v  (init-flic-var (create-temp-var 'arg) '#f '#f)))
+	(push v newvars)
+	(push (make-flic-ref v) newargs)))
+    (setf (flic-app-fn app) fn)
+    (setf (flic-app-args app) (nconc args newargs))
+    (make-flic-lambda newvars app)))
+
+
+
+;;; If the function is a selector applied to a literal dictionary,
+;;; inline it.
+
+(define (try-to-fold-selector var new-fn new-args)
+  (let ((exp  (car new-args)))
+    (if (or (and (is-type? 'flic-ref exp)
+		 ;; *** should check that var is top-level?
+		 (is-bound-to-constructor-app? (flic-ref-var exp)))
+	    (and (is-type? 'flic-app exp)
+		 (is-constructor-app-prim? exp)))
+	(begin
+	  (record-hack 'app-fold-selector)
+	  (setf new-fn (copy-flic-top (var-value var)))
+	  (do-lambda-to-let-aux new-fn new-args))
+	(values new-fn new-args))))
+
+
+;;; Various primitive functions have special optimizer functions
+;;; associated with them, that do constant folding and certain
+;;; other identities.  The optimizer function is called with the 
+;;; function expression and list of argument expressions (at least
+;;; as many arguments as the arity of the function) and should return
+;;; the two values.
+
+;;; *** This should really use some kind of hash table, but we'd
+;;; *** have to initialize the table dynamically because core-symbols
+;;; *** aren't defined when this file is loaded.
+
+(define (magic-optimize-function var)
+  (cond ((eq? var (core-symbol "foldr"))
+	 (function optimize-foldr-aux))
+	((eq? var (core-symbol "build"))
+	 (function optimize-build))
+	((eq? var (core-symbol "primIntegerToInt"))
+	 (function optimize-integer-to-int))
+	((eq? var (core-symbol "primIntToInteger"))
+	 (function optimize-int-to-integer))
+	((eq? var (core-symbol "primRationalToFloat"))
+	 (function optimize-rational-to-float))
+	((eq? var (core-symbol "primRationalToDouble"))
+	 (function optimize-rational-to-double))
+	((or (eq? var (core-symbol "primNegInt"))
+	     (eq? var (core-symbol "primNegInteger"))
+	     (eq? var (core-symbol "primNegFloat"))
+	     (eq? var (core-symbol "primNegDouble")))
+	 (function optimize-neg))
+	(else
+	 '#f)))
+
+
+;;; Foldr identities for deforestation
+
+(define (optimize-foldr fn args)
+  (multiple-value-bind (fn args)
+      (optimize-foldr-aux fn args)
+    (maybe-make-app fn args)))
+
+(define (optimize-foldr-aux fn args)
+  (let ((k     (car args))
+	(z     (cadr args))
+	(l     (caddr args))
+	(tail  (cdddr args)))
+    (cond ((and (is-type? 'flic-pack k)
+		(eq? (flic-pack-con k) (core-symbol ":"))
+		(is-type? 'flic-pack z)
+		(eq? (flic-pack-con z) (core-symbol "Nil")))
+	   ;; foldr (:) [] l ==> l
+	   ;; (We arrange for build to be inlined before foldr
+	   ;; so that this pattern can be detected.)
+	   (record-hack 'foldr-cons-nil-identity)
+	   (values l tail))
+	  ((and (is-type? 'flic-app l)
+		(is-type? 'flic-ref (flic-app-fn l))
+		(eq? (flic-ref-var (flic-app-fn l))
+		     (core-symbol "build"))
+		(null? (cdr (flic-app-args l))))
+	   ;; foldr k z (build g) ==> g k z
+	   (record-hack 'foldr-build-identity)
+	   (values
+	     (car (flic-app-args l))
+	     (cons k (cons z tail))))
+	  ((and (is-type? 'flic-pack l)
+		(eq? (flic-pack-con l) (core-symbol "Nil")))
+	   ;; foldr k z [] ==> z
+	   (record-hack 'foldr-nil-identity)
+	   (values z tail))
+	  ((short-string-constant? l)
+	   ;; If the list argument is a string constant, expand it inline.
+	   ;; Only do this if the string is fairly short, though.
+	   (optimize-foldr-aux
+	     fn
+	     (cons k (cons z (cons (expand-string-constant l) tail)))))
+	  ((and (is-type? 'flic-app l)
+		(is-type? 'flic-pack (flic-app-fn l))
+		(eq? (flic-pack-con (flic-app-fn l)) (core-symbol ":"))
+		(eqv? (length (flic-app-args l)) 2))
+	   ;; foldr k z x:xs ==> let c = k in c x (foldr c z xs)
+	   (record-hack 'foldr-cons-identity)
+	   (let ((x     (car (flic-app-args l)))
+		 (xs    (cadr (flic-app-args l))))
+	     (values 
+	       (if (can-inline? k '() '#f)
+		   (do-foldr-cons-identity k z x xs)
+		   (let ((cvar  (init-flic-var (create-temp-var 'c) k '#f)))
+		     (make-flic-let
+		       (list cvar)
+		       (do-foldr-cons-identity (make-flic-ref cvar) z x xs)
+		       '#f)))
+	       tail)))
+	  ((is-type? 'flic-let l)
+	   ;; foldr k z (let bindings in body) ==>
+	   ;;   let bindings in foldr k z body
+	   (record-hack 'foldr-hoist-let)
+	   (setf (flic-let-body l)
+		 (optimize-foldr fn (list k z (flic-let-body l))))
+	   (values l tail))
+	  ((not (eqv? (the fixnum (dynamic *current-optimize-iteration*))
+		      (the fixnum (dynamic *optimize-foldr-iteration*))))
+	   ;; Hope for more optimizations later.
+	   (values fn args))
+	  ((and (is-type? 'flic-pack k)
+		(eq? (flic-pack-con k) (core-symbol ":")))
+	   ;; Inline to special case, highly optimized append primitive.
+	   ;; Could also look for (++ (++ l1 l2) l3) => (++ l1 (++ l2 l3))
+	   ;; here, but I don't think that happens very often.
+           (record-hack 'foldr-prim-append-inline)
+	   (values
+	     (make-flic-ref (core-symbol "primAppend"))
+	     (cons l (cons z tail))))
+	  (else
+	   ;; Default inline.
+	   (record-hack 'foldr-inline k z)
+	   (let ((new-fn
+		   (copy-flic-top (var-value (core-symbol "inlineFoldr")))))
+	     (if (is-type? 'flic-lambda new-fn)
+		 (do-lambda-to-let-aux new-fn args)
+		 (values new-fn args))))
+	  )))
+
+
+;;; Mess with compile-time expansion of short string constants.
+
+(define-integrable max-short-string-length 3)
+
+(define (short-string-constant? l)
+  (and (is-type? 'flic-const l)
+       (let ((string  (flic-const-value l)))
+	 (and (string? string)
+	      (<= (the fixnum (string-length string))
+		  (the fixnum max-short-string-length))))))
+
+(define (expand-string-constant l)
+  (let* ((string  (flic-const-value l))
+	 (length  (string-length string)))
+    (expand-string-constant-aux string 0 length)))
+
+(define (expand-string-constant-aux string i length)
+  (declare (type fixnum i length))
+  (if (eqv? i length)
+      (make-flic-pack (core-symbol "Nil"))
+      (make-flic-app
+        (make-flic-pack (core-symbol ":"))
+	(list (make-flic-const (string-ref string i))
+	      (expand-string-constant-aux string (+ 1 i) length))
+	'#f)))
+
+
+;;; Helper function for the case of expanding foldr applied to cons call.
+
+(define (do-foldr-cons-identity c z x xs)
+  (make-flic-app
+    c
+    (list x
+	  (optimize-foldr
+	    (make-flic-ref (core-symbol "foldr"))
+	    (list (copy-flic-top c) z xs)))
+    '#f))
+
+
+
+;;; Short-circuit build inlining for the usual case where the
+;;; argument is a lambda.  (It would take several optimizer passes
+;;; for this simplification to fall out, otherwise.)
+
+(define (optimize-build fn args)
+  (let ((arg  (car args)))
+    (cond ((not (eqv? (dynamic *current-optimize-iteration*)
+		      (dynamic *optimize-build-iteration*)))
+	   (values fn args))
+	  ((is-type? 'flic-lambda arg)
+	   (record-hack 'build-inline-lambda)
+	   (do-lambda-to-let-aux
+	     arg
+	     (cons (make-flic-pack (core-symbol ":"))
+		   (cons (make-flic-pack (core-symbol "Nil"))
+			 (cdr args)))))
+	  (else
+	   (record-hack 'build-inline-other)
+	   (let ((new-fn
+		   (copy-flic-top (var-value (core-symbol "inlineBuild")))))
+	     (if (is-type? 'flic-lambda new-fn)
+		 (do-lambda-to-let-aux new-fn args)
+		 (values new-fn args))))
+	  )))
+
+
+;;; Various simplifications on numeric functions.
+;;; *** Obviously, could get much fancier about this.
+		  
+(define (optimize-integer-to-int fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+	   (record-hack 'integer-to-int-constant-fold)
+	   (if (is-type? 'integer (flic-const-value arg))
+	       (let ((value  (flic-const-value arg)))
+		 (when (not (is-type? 'fixnum value))
+		   ;; Overflow is a user error, not an implementation error.
+		   (phase-error 'int-overflow
+				"Int overflow in primIntegerToInt: ~s"
+				value))
+		 (values arg (cdr args)))
+	       (error "Bad argument ~s to primIntegerToInt." arg)))
+	  ((and (is-type? 'flic-app arg)
+		(is-type? 'flic-ref (flic-app-fn arg))
+		(eq? (flic-ref-var (flic-app-fn arg))
+		     (core-symbol "primIntToInteger"))
+		(null? (cdr (flic-app-args arg))))
+	   (record-hack 'integer-to-int-identity)
+	   (values (car (flic-app-args arg)) (cdr args)))
+	  (else
+	   (values fn args)))))
+
+(define (optimize-int-to-integer fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+	   (record-hack 'int-to-integer-constant-fold)
+	   (if (is-type? 'integer (flic-const-value arg))
+	       (values arg (cdr args))
+	       (error "Bad argument ~s to primIntToInteger." arg)))
+	  ((and (is-type? 'flic-app arg)
+		(is-type? 'flic-ref (flic-app-fn arg))
+		(eq? (flic-ref-var (flic-app-fn arg))
+		     (core-symbol "primIntegerToInt"))
+		(null? (cdr (flic-app-args arg))))
+	   (record-hack 'int-to-integer-identity)
+	   (values (car (flic-app-args arg)) (cdr args)))
+	  (else
+	   (values fn args)))))
+
+(predefine (prim.rational-to-float-aux n d))   ; in prims.scm
+(predefine (prim.rational-to-double-aux n d))  ; in prims.scm
+
+(define (optimize-rational-to-float fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+	   (record-hack 'rational-to-float-constant-fold)
+	   (if (is-type? 'list (flic-const-value arg))
+	       (let ((value  (flic-const-value arg)))
+		 (setf (flic-const-value arg)
+		       (prim.rational-to-float-aux (car value) (cadr value)))
+		 (values arg (cdr args)))
+	       (error "Bad argument ~s to primRationalToFloat." arg)))
+	  (else
+	   (values fn args)))))
+
+(define (optimize-rational-to-double fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+	   (record-hack 'rational-to-double-constant-fold)
+	   (if (is-type? 'list (flic-const-value arg))
+	       (let ((value  (flic-const-value arg)))
+		 (setf (flic-const-value arg)
+		       (prim.rational-to-double-aux (car value) (cadr value)))
+		 (values arg (cdr args)))
+	       (error "Bad argument ~s to primRationalToDouble." arg)))
+	  (else
+	   (values fn args)))))
+
+(define (optimize-neg fn args)
+  (let ((arg  (car args)))
+    (cond ((is-type? 'flic-const arg)
+	   (record-hack 'neg-constant-fold)
+	   (if (is-type? 'number (flic-const-value arg))
+	       (begin
+		 (setf (flic-const-value arg) (- (flic-const-value arg)))
+		 (values arg (cdr args)))
+	       (error "Bad argument ~s to ~s." arg fn)))
+	  (else
+	   (values fn args)))))
+
+
+
+;;; Convert lambda applications to lets.
+;;; If application is not saturated, break it up into two nested
+;;; lambdas before doing the transformation.
+;;; It's better to do this optimization immediately than hoping
+;;; the call will become fully saturated on the next pass.
+;;; Maybe we could also look for a flic-let with a flic-lambda as
+;;; the body to catch the cases where additional arguments can
+;;; be found on a later pass.
+
+(define (do-lambda-to-let new-fn new-args)
+  (multiple-value-bind (fn args)
+      (do-lambda-to-let-aux new-fn new-args)
+    (maybe-make-app fn args)))
+
+(define (maybe-make-app fn args)
+  (if (null? args)
+      fn
+      (make-flic-app fn args '#f)))
+
+(define (do-lambda-to-let-aux new-fn new-args)
+  (let ((vars     (flic-lambda-vars new-fn))
+	(body     (flic-lambda-body new-fn))
+	(matched  '()))
+    (record-hack 'app-lambda-to-let)
+    (do ()
+	((or (null? new-args) (null? vars)))
+	(let ((var  (pop vars))
+	      (arg  (pop new-args)))
+	  (setf (var-value var) arg)
+	  (setf (var-simple? var) (can-inline? arg '() '#t))
+	  (if (eqv? (var-referenced var) 1)
+	      (setf (var-single-ref var) (dynamic *lambda-depth*)))
+	  (push var matched)))
+    (setf matched (nreverse matched))
+    (if (not (null? vars))
+	(setf body (make-flic-lambda vars body)))
+    (setf new-fn (make-flic-let matched body '#f))
+    (values new-fn new-args)))
+
+
+;;; For references, check to see if we can beta-reduce.
+;;; Don't increment reference count for inlineable vars, but do
+;;; traverse the new value expression.
+
+(define-optimize flic-ref (object)
+  (optimize-flic-ref-aux object))
+
+(define (optimize-flic-ref-aux object)
+  (let ((var     (flic-ref-var object)))
+    (cond ((var-single-ref var)
+	   ;; (or (eqv? (var-single-ref var) (dynamic *lambda-depth*)))
+	   ;; *** The lambda-depth test is too conservative to handle
+	   ;; *** inlining of stuff necessary for foldr/build optimizations.
+	   ;; Can substitute value no matter how hairy it is.
+	   ;; Note that this is potentially risky; if the single
+	   ;; reference detected on the previous pass appeared as 
+	   ;; the value of a variable binding that is being inlined
+	   ;; on the current pass, it might turn into multiple
+	   ;; references again!
+	   ;; We copy the value anyway to avoid problems with shared
+	   ;; structure in the multiple reference case.
+	   (record-hack 'ref-inline-single-ref var)
+	   (optimize (copy-flic-top (var-value var))))
+	  ((and (var-inline-value var) (dynamic *do-inline-optimizations*))
+	   ;; Use the previously saved value in preference to the current
+	   ;; value of the variable.
+	   (record-hack 'ref-inline-foldr-hack)
+	   (optimize (copy-flic-top (var-inline-value var))))
+	  ((and (var-simple? var)
+		(or (dynamic *do-inline-optimizations*)
+		    (not (var-toplevel? var))))
+	   ;; Can substitute, but must copy.
+	   (record-hack 'ref-inline var)
+	   (optimize (copy-flic-top (var-value var))))
+	  ((eq? var (core-symbol "foldr"))
+	   ;; Magic stuff for deforestation
+	   (if (> (the fixnum (dynamic *current-optimize-iteration*))
+		  (the fixnum (dynamic *optimize-foldr-iteration*)))
+	       (begin
+		 (record-hack 'ref-inline-foldr)
+		 (optimize (make-flic-ref (core-symbol "inlineFoldr"))))
+	       object))
+	  ((eq? var (core-symbol "build"))
+	   ;; Magic stuff for deforestation
+	   (if (> (the fixnum (dynamic *current-optimize-iteration*))
+		  (the fixnum (dynamic *optimize-build-iteration*)))
+	       (begin
+		 (record-hack 'ref-inline-build)
+		 (optimize (make-flic-ref (core-symbol "inlineBuild"))))
+	       object))
+	  ((var-toplevel? var)
+	   object)
+	  (else
+	   (incf (var-referenced var))
+	   object))))
+
+
+;;; Don't do anything exciting with constants.
+
+(define-optimize flic-const (object)
+  object)
+
+(define-optimize flic-pack (object)
+  object)
+
+
+
+;;; Various simplifications on and
+
+(define-optimize flic-and (object)
+  (maybe-simplify-and
+    object
+    (optimize-and-exps (flic-and-exps object) '())))
+
+(define (maybe-simplify-and object exps)
+  (cond ((null? exps)
+	 (record-hack 'and-empty)
+	 (make-flic-pack (core-symbol "True")))
+	((null? (cdr exps))
+	 (record-hack 'and-unary)
+	 (car exps))
+	(else
+	 (setf (flic-and-exps object) exps)
+	 object)))
+
+(define (optimize-and-exps exps result)
+  (if (null? exps)
+      (nreverse result)
+      (let ((exp  (optimize (car exps))))
+	(typecase exp
+	  (flic-pack
+	    (cond ((eq? (flic-pack-con exp) (core-symbol "True"))
+		   ;; True appears in subexpressions.
+		   ;; Discard this test only.
+		   (record-hack 'and-contains-true)
+		   (optimize-and-exps (cdr exps) result))
+		  ((eq? (flic-pack-con exp) (core-symbol "False"))
+		   ;; False appears in subexpressions.
+		   ;; Discard remaining tests as dead code.
+		   ;; Can't replace the whole and expression with false because
+		   ;; of possible strictness side-effects.
+		   (record-hack 'and-contains-false)
+		   (nreverse (cons exp result)))
+		  (else
+		   ;; Should never happen.
+		   (error "Non-boolean con ~s in and expression!" exp))))
+	  (flic-and
+	   ;; Flatten nested ands.
+	   (record-hack 'and-compress)
+	   (optimize-and-exps
+	    (cdr exps)
+	    (nconc (nreverse (flic-and-exps exp)) result)))
+	  (else
+	   ;; No optimization possible.
+	   (optimize-and-exps (cdr exps) (cons exp result)))
+	  ))))
+
+
+;;; Case-block optimizations.  These optimizations are possible because
+;;; of the restricted way this construct is used;  return-froms are
+;;; never nested, etc.
+
+(define-optimize flic-case-block (object)
+  (let* ((sym  (flic-case-block-block-name object))
+	 (exps (optimize-case-block-exps
+		 sym (flic-case-block-exps object) '())))
+    (optimize-flic-case-block-aux object sym exps)))
+
+(define (optimize-flic-case-block-aux object sym exps)
+  (cond ((null? exps)
+	 ;; This should never happen.  It means all of the tests were
+	 ;; optimized away, including the failure case!
+	 (error "No exps left in case block ~s!" object))
+	((and (is-type? 'flic-and (car exps))
+	      (is-return-from-block?
+	        sym
+	        (car (last (flic-and-exps (car exps))))))
+	 ;; The first clause is a simple and.  Hoist it out of the
+	 ;; case-block and rewrite as if/then/else.
+	 (record-hack 'case-block-to-if)
+	 (let ((then-exp  (car (last (flic-and-exps (car exps))))))
+	   (setf (flic-case-block-exps object) (cdr exps))
+	   (make-flic-if
+	     (maybe-simplify-and
+	       (car exps)
+	       (butlast (flic-and-exps (car exps))))
+	     (flic-return-from-exp then-exp)
+	     (optimize-flic-case-block-aux object sym (cdr exps)))))
+	((is-return-from-block? sym (car exps))
+	 ;; Do an identity reduction.
+	 (record-hack 'case-block-identity)
+	 (flic-return-from-exp (car exps)))
+	((is-type? 'flic-let (car exps))
+	 ;; The first clause is a let.  Since this clause is going
+	 ;; to be executed anyway, hoisting the bindings to surround
+	 ;; the entire case-block should not change their strictness
+	 ;; properties, and it may permit some further optimizations.
+	 (record-hack 'case-block-hoist-let)
+	 (let* ((exp  (car exps))
+		(body (flic-let-body exp)))
+	   (setf (flic-let-body exp)
+		 (optimize-flic-case-block-aux
+		   object sym (cons body (cdr exps))))
+	   exp))
+	(else
+	 (setf (flic-case-block-exps object) exps)
+	 object)
+	))
+
+
+(define (optimize-case-block-exps sym exps result)
+  (if (null? exps)
+      (nreverse result)
+      (let ((exp  (optimize (car exps))))
+	(cond ((is-return-from-block? sym exp)
+	       ;; Any remaining clauses are dead code and should be removed.
+	       (if (not (null? (cdr exps)))
+		   (record-hack 'case-block-dead-code))
+	       (nreverse (cons exp result)))
+	      ((is-type? 'flic-and exp)
+	       ;; See if we can remove redundant tests.
+	       (push (maybe-simplify-and
+		       exp
+		       (look-for-redundant-tests (flic-and-exps exp) result))
+		     result)
+	       (optimize-case-block-exps sym (cdr exps) result))
+	      (else
+	       ;; No optimization possible.
+	       (optimize-case-block-exps sym (cdr exps) (cons exp result)))
+	      ))))
+
+
+;;; Look for case-block tests that are known to be either true or false
+;;; because of tests made in previous clauses.
+;;; For now, we only look at is-constructor tests.  Such a test is known
+;;; to be true if previous clauses have eliminated all other possible
+;;; constructors.  And such a test is known to be false if a previous
+;;; clause has already matched this constructor.
+
+(define (look-for-redundant-tests exps previous-clauses)
+  (if (null? exps)
+      '()
+      (let ((exp  (car exps)))
+	(cond ((and (is-type? 'flic-is-constructor exp)
+		    (constructor-test-redundant? exp previous-clauses))
+	       ;; Known to be true.
+	       (record-hack 'case-block-discard-redundant-test)
+	       (cons (make-flic-pack (core-symbol "True"))
+		     (look-for-redundant-tests (cdr exps) previous-clauses)))
+
+              ((and (is-type? 'flic-is-constructor exp)
+		    (constructor-test-duplicated? exp previous-clauses))
+	       ;; Known to be false.
+	       (record-hack 'case-block-discard-duplicate-test)
+	       (list (make-flic-pack (core-symbol "False"))))
+	      (else
+	       ;; No optimization.
+	       (cons exp
+		     (look-for-redundant-tests (cdr exps) previous-clauses)))
+	      ))))
+
+
+;;; In looking for redundant/duplicated tests, only worry about
+;;; is-constructor tests that have an argument that is a variable.
+;;; It's too hairy to consider any other cases.
+
+(define (constructor-test-duplicated? exp previous-clauses)
+  (let ((con  (flic-is-constructor-con exp))
+	(arg  (flic-is-constructor-exp exp)))
+    (and (is-type? 'flic-ref arg)
+	 (constructor-test-present? con arg previous-clauses))))
+
+(define (constructor-test-redundant? exp previous-clauses)
+  (let ((con     (flic-is-constructor-con exp))
+        (arg     (flic-is-constructor-exp exp)))
+    (and (is-type? 'flic-ref arg)
+	 (every-1 (lambda (c)
+		    (or (eq? c con)
+			(constructor-test-present? c arg previous-clauses)))
+		  (algdata-constrs (con-alg con))))))
+
+(define (constructor-test-present? con arg previous-clauses)
+  (cond ((null? previous-clauses)
+	 '#f)
+	((constructor-test-present-1? con arg (car previous-clauses))
+	 '#t)
+	(else
+	 (constructor-test-present? con arg (cdr previous-clauses)))))
+
+
+;;; The tricky thing here is that, even if the constructor test is 
+;;; present in the clause, we have to make sure that the entire clause won't
+;;; fail due to the presence of some other test which fails.  So look
+;;; for a very specific pattern here, namely
+;;;  (and (is-constructor con arg) (return-from ....))
+
+(define (constructor-test-present-1? con arg clause)
+  (and (is-type? 'flic-and clause)
+       (let ((exps  (flic-and-exps clause)))
+	 (and (is-type? 'flic-is-constructor (car exps))
+	      (is-type? 'flic-return-from (cadr exps))
+	      (null? (cddr exps))
+	      (let* ((inner-exp  (car exps))
+		     (inner-con  (flic-is-constructor-con inner-exp))
+		     (inner-arg  (flic-is-constructor-exp inner-exp)))
+		(and (eq? inner-con con)
+		     (flic-exp-eq? arg inner-arg)))))))
+
+
+
+;;; No fancy optimizations for return-from by itself.
+
+(define-optimize flic-return-from (object)
+  (setf (flic-return-from-exp object)
+	(optimize (flic-return-from-exp object)))
+  object)
+
+
+
+;;; Obvious simplification on if
+
+(define-optimize flic-if (object)
+  (let ((test-exp  (optimize (flic-if-test-exp object)))
+	(then-exp  (optimize (flic-if-then-exp object)))
+	(else-exp  (optimize (flic-if-else-exp object))))
+    (cond ((and (is-type? 'flic-pack test-exp)
+		(eq? (flic-pack-con test-exp) (core-symbol "True")))
+	   ;; Fold constant test
+	   (record-hack 'if-fold)
+	   then-exp)
+	  ((and (is-type? 'flic-pack test-exp)
+		(eq? (flic-pack-con test-exp) (core-symbol "False")))
+	   ;; Fold constant test
+	   (record-hack 'if-fold)
+	   else-exp)
+	  ((and (is-type? 'flic-is-constructor test-exp)
+		(eq? (flic-is-constructor-con test-exp) (core-symbol "True")))
+	   ;; Remove redundant is-constructor test.
+	   ;; Doing this as a general is-constructor identity
+	   ;; backfires because it prevents some of the important case-block
+	   ;; optimizations from being recognized, but it works fine here.
+	   (record-hack 'if-compress-test)
+	   (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
+	   (setf (flic-if-then-exp object) then-exp)
+	   (setf (flic-if-else-exp object) else-exp)
+	   object)
+	  ((and (is-type? 'flic-is-constructor test-exp)
+		(eq? (flic-is-constructor-con test-exp) (core-symbol "False")))
+	   ;; Remove redundant is-constructor test, flip branches.
+	   (record-hack 'if-compress-test)
+	   (setf (flic-if-test-exp object) (flic-is-constructor-exp test-exp))
+	   (setf (flic-if-then-exp object) else-exp)
+	   (setf (flic-if-else-exp object) then-exp)
+	   object)
+	  ((and (is-type? 'flic-return-from then-exp)
+		(is-type? 'flic-return-from else-exp)
+		(eq? (flic-return-from-block-name then-exp)
+		     (flic-return-from-block-name else-exp)))
+	   ;; Hoist return-from outside of IF.
+	   ;; This may permit further case-block optimizations.
+	   (record-hack 'if-hoist-return-from)
+	   (let ((return-exp  then-exp))
+	     (setf (flic-if-test-exp object) test-exp)
+	     (setf (flic-if-then-exp object) (flic-return-from-exp then-exp))
+	     (setf (flic-if-else-exp object) (flic-return-from-exp else-exp))
+	     (setf (flic-return-from-exp return-exp) object)
+	     return-exp))
+	  ((and (is-type? 'flic-pack then-exp)
+		(is-type? 'flic-pack else-exp)
+		(eq? (flic-pack-con then-exp) (core-symbol "True"))
+		(eq? (flic-pack-con else-exp) (core-symbol "False")))
+	   ;; This if does nothing useful at all!
+	   (record-hack 'if-identity)
+	   test-exp)
+	  ((and (is-type? 'flic-pack then-exp)
+		(is-type? 'flic-pack else-exp)
+		(eq? (flic-pack-con then-exp) (core-symbol "False"))
+		(eq? (flic-pack-con else-exp) (core-symbol "True")))
+	   ;; Inverse of previous case
+	   (record-hack 'if-identity-inverse)
+	   (make-flic-is-constructor (core-symbol "False") test-exp))
+	  ((or (is-type? 'flic-lambda then-exp)
+	       (is-type? 'flic-lambda else-exp))
+	   ;; Hoist lambdas to surround entire if.  This allows us to
+	   ;; do a better job of saturating them.
+	   (record-hack 'if-hoist-lambda)
+	   (multiple-value-bind (vars then-exp else-exp)
+	       (do-if-hoist-lambda then-exp else-exp)
+	     (setf (flic-if-test-exp object) test-exp)
+	     (setf (flic-if-then-exp object) then-exp)
+	     (setf (flic-if-else-exp object) else-exp)
+	     (make-flic-lambda vars object)))
+	  (else
+	   ;; No optimization possible
+	   (setf (flic-if-test-exp object) test-exp)
+	   (setf (flic-if-then-exp object) then-exp)
+	   (setf (flic-if-else-exp object) else-exp)
+	   object)
+	  )))
+
+
+
+;;; Try to pull as many variables as possible out to surround the entire
+;;; let.
+
+(define (do-if-hoist-lambda then-exp else-exp)
+  (let ((vars       '())
+	(then-args  '())
+	(else-args  '()))
+    (do ((then-vars  (if (is-type? 'flic-lambda then-exp)
+			 (flic-lambda-vars then-exp)
+			 '())
+		     (cdr then-vars))
+	 (else-vars  (if (is-type? 'flic-lambda else-exp)
+			 (flic-lambda-vars else-exp)
+			 '())
+		     (cdr else-vars)))
+	((and (null? then-vars) (null? else-vars)) '#f)
+	(let ((var  (init-flic-var (create-temp-var 'arg) '#f '#f)))
+	  (push var vars)
+	  (push (make-flic-ref var) then-args)
+	  (push (make-flic-ref var) else-args)))
+    (values
+      vars
+      (if (is-type? 'flic-lambda then-exp)
+	  (do-lambda-to-let then-exp then-args)
+	  (make-flic-app then-exp then-args '#f))
+      (if (is-type? 'flic-lambda else-exp)
+	  (do-lambda-to-let else-exp else-args)
+	  (make-flic-app else-exp else-args '#f)))))
+
+    
+
+;;; Look for (sel (pack x)) => x
+
+(define-optimize flic-sel (object)
+  (optimize-flic-sel-aux object))
+
+(define (optimize-flic-sel-aux object)
+  (let ((new-exp  (optimize (flic-sel-exp object))))
+    (setf (flic-sel-exp object) new-exp)
+    (typecase new-exp
+      (flic-ref
+       ;; Check to see whether this is bound to a pack application
+       (let ((val  (is-bound-to-constructor-app? (flic-ref-var new-exp))))
+	 (if val
+	     ;; Yup, it is.  Now extract the appropriate component,
+	     ;; provided it is inlineable.
+	     (let* ((i      (flic-sel-i object))
+		    (args   (flic-app-args val))
+		    (newval (list-ref args i)))
+	       (if (can-inline? newval '() '#t)
+		   (begin
+		     (record-hack 'sel-fold-var)
+		     (optimize (copy-flic-top newval)))
+		   object))
+	     ;; The variable was bound to something else.
+	     object)))
+      (flic-app
+       ;; The obvious optimization.
+       (if (is-constructor-app-prim? new-exp)
+	   (begin
+	     (record-hack 'sel-fold-app)
+	     (list-ref (flic-app-args new-exp) (flic-sel-i object)))
+	   object))
+      (else
+       object))))
+
+
+
+
+;;; Do similar stuff for is-constructor.
+
+(define-optimize flic-is-constructor (object)
+  (let ((con      (flic-is-constructor-con object))
+	(exp      (optimize (flic-is-constructor-exp object)))
+	(exp-con  '#f))
+    (cond ((algdata-tuple? (con-alg con))
+	   ;; Tuples have only one constructor, so this is always true
+	   (record-hack 'is-constructor-fold-tuple)
+	   (make-flic-pack (core-symbol "True")))
+	  ((setf exp-con (is-constructor-app? exp))
+	   ;; The expression is a constructor application.
+	   (record-hack 'is-constructor-fold)
+	   (make-flic-pack
+	     (if (eq? exp-con con)
+		 (core-symbol "True")
+		 (core-symbol "False"))))
+	  (else
+	   ;; No optimization possible
+	   (setf (flic-is-constructor-exp object) exp)
+	   object)
+	  )))
+
+
+(define-optimize flic-con-number (object)
+  (let ((exp  (flic-con-number-exp object))
+	(type (flic-con-number-type object)))
+    ;; ***Maybe ast-to-flic should look for this one.
+    (if (algdata-tuple? type)
+	(begin
+	  (record-hack 'con-number-fold-tuple)
+	  (make-flic-const 0))
+	(let* ((new-exp  (optimize exp))
+	       (con      (is-constructor-app? new-exp)))
+	  (if con
+	      (begin
+	        (record-hack 'con-number-fold)
+		(make-flic-const (con-tag con)))
+	      (begin
+	        (setf (flic-con-number-exp object) new-exp)
+		object)))
+      )))
+
+(define-optimize flic-void (object)
+  object)
+
+
+;;;===================================================================
+;;; General helper functions
+;;;===================================================================
+
+
+;;; Lucid's built-in every function seems to do a lot of unnecessary
+;;; consing.  This one is much faster.
+
+(define (every-1 fn list)
+  (cond ((null? list)
+	 '#t)
+	((funcall fn (car list))
+	 (every-1 fn (cdr list)))
+	(else
+	 '#f)))
+
+
+
+;;; Equality predicate on flic expressions
+
+(define (flic-exp-eq? a1 a2)
+  (typecase a1
+    (flic-const
+     (and (is-type? 'flic-const a2)
+	  (equal? (flic-const-value a1) (flic-const-value a2))))
+    (flic-ref
+     (and (is-type? 'flic-ref a2)
+	  (eq? (flic-ref-var a1) (flic-ref-var a2))))
+    (flic-pack
+     (and (is-type? 'flic-pack a2)
+	  (eq? (flic-pack-con a1) (flic-pack-con a2))))
+    (flic-sel
+     (and (is-type? 'flic-sel a2)
+	  (eq? (flic-sel-con a1) (flic-sel-con a2))
+	  (eqv? (flic-sel-i a1) (flic-sel-i a2))
+	  (flic-exp-eq? (flic-sel-exp a1) (flic-sel-exp a2))))
+    (else
+     '#f)))
+
+
+
+;;; Predicates for testing whether an expression matches a pattern.
+
+(define (is-constructor-app? exp)
+  (typecase exp
+    (flic-app
+     ;; See if we have a saturated call to a constructor.
+     (is-constructor-app-prim? exp))
+    (flic-ref
+     ;; See if we can determine anything about the value the variable
+     ;; is bound to.
+     (let ((value  (var-value (flic-ref-var exp))))
+       (if value
+	   (is-constructor-app? value)
+	   '#f)))
+    (flic-let
+     ;; See if we can determine anything about the body of the let.
+     (is-constructor-app? (flic-let-body exp)))
+    (flic-pack
+     ;; See if this is a nullary constructor.
+     (let ((con  (flic-pack-con exp)))
+       (if (eqv? (con-arity con) 0)
+	   con
+	   '#f)))
+    (else
+     '#f)))
+
+(define (is-return-from-block? sym exp)
+  (and (is-type? 'flic-return-from exp)
+       (eq? (flic-return-from-block-name exp) sym)))
+
+(define (is-constructor-app-prim? exp)
+  (let ((fn    (flic-app-fn exp))
+	(args  (flic-app-args exp)))
+    (if (and (is-type? 'flic-pack fn)
+	     (eqv? (length args) (con-arity (flic-pack-con fn))))
+	(flic-pack-con fn)
+	'#f)))
+
+(define (is-bound-to-constructor-app? var)
+  (let ((val  (var-value var)))
+    (if (and val
+	     (is-type? 'flic-app val)
+	     (is-constructor-app-prim? val))
+	val
+	'#f)))
+
+(define (is-selector? con i exp)
+  (or (and (is-type? 'flic-ref exp)
+	   (is-selector? con i (var-value (flic-ref-var exp))))
+      (and (is-type? 'flic-sel exp)
+	   (eq? (flic-sel-con exp) con)
+	   (eqv? (the fixnum i) (the fixnum (flic-sel-i exp)))
+	   (flic-sel-exp exp))
+      ))
+
+(define (is-selector-list? con i subexp exps)
+  (declare (type fixnum i))
+  (if (null? exps)
+      subexp
+      (let ((temp  (is-selector? con i (car exps))))
+	(and (flic-exp-eq? subexp temp)
+	     (is-selector-list? con (+ 1 i) subexp (cdr exps))))))
+
+
+
+;;;===================================================================
+;;; Inlining criteria
+;;;===================================================================
+
+;;; Expressions that can be inlined unconditionally are constants, variable
+;;; references, and some functions.
+;;; I've made some attempt here to arrange the cases in the order they
+;;; are likely to occur.
+
+(define (can-inline? exp recursive-vars toplevel?)
+  (typecase exp
+    (flic-sel
+     ;; Listed first because it happens more frequently than
+     ;; anything else.
+     ;; *** Inlining these is an experiment.
+     ;; *** This transformation interacts with the strictness
+     ;; *** analyzer; if the variable referenced is not strict, then
+     ;; *** it is probably not a good thing to do since it adds extra
+     ;; *** forces.
+     ;; (let ((subexp  (flic-sel-exp exp)))
+     ;;   (and (is-type? 'flic-ref subexp)
+     ;;        (not (memq (flic-ref-var subexp) recursive-vars))))
+     '#f)
+    (flic-lambda
+     ;; Do not try to inline lambdas if the fancy inline optimization
+     ;; is disabled.
+     ;; Watch for problems with infinite loops with recursive variables.
+     (if (dynamic *do-inline-optimizations*)
+	 (simple-function-body? (flic-lambda-body exp)
+				(flic-lambda-vars exp)
+				recursive-vars
+				toplevel?)
+	 '#f))
+    (flic-ref
+     ;; We get into infinite loops trying to inline recursive variables.
+     (not (memq (flic-ref-var exp) recursive-vars)))
+    ((or flic-pack flic-const)
+     '#t)
+    (else
+     '#f)))
+
+
+;;; Determining whether to inline a function is difficult.  This is
+;;; very conservative to avoid code bloat.  What we need to do is
+;;; compare the cost (in program size mainly) of the inline call with
+;;; an out of line call.  For an out of line call, we pay for one function
+;;; call and a setup for each arg.  When inlining, we pay for function
+;;; calls in the body and for args referenced more than once.  In terms of
+;;; execution time, we win big when a functional parameter is called
+;;; since this `firstifies' the program.
+
+;;; Here's the criteria:
+;;;  An inline function gets to reference no more that 2 non-parameter
+;;;  values (including constants and repeated parameter references).
+;;; For non-toplevel functions, be slightly more generous since the
+;;; fixed overhead of binding the local function would go away.
+
+(define (simple-function-body? exp lambda-vars recursive-vars toplevel?)
+  (let ((c  (if toplevel? 2 4)))
+    (>= (the fixnum (simple-function-body-1 exp lambda-vars recursive-vars c))
+	0)))
+
+
+;;; I've made some attempt here to order the cases by how frequently
+;;; they appear.
+
+(define (simple-function-body-1 exp lambda-vars recursive-vars c)
+  (declare (type fixnum c))
+  (if (< c 0)
+      (values c '())
+      (typecase exp
+	(flic-ref
+	 (let ((var (flic-ref-var exp)))
+	   (cond ((memq var lambda-vars)
+		  (values c (list-remove-1 var lambda-vars)))
+		 ((memq var recursive-vars)
+		  (values -1 '()))
+		 (else
+		  (values (the fixnum (1- c)) lambda-vars)))))
+	(flic-app
+	 (simple-function-body-1/l
+	   (cons (flic-app-fn exp) (flic-app-args exp))
+	   lambda-vars recursive-vars c))
+	(flic-sel
+	 (simple-function-body-1
+	  (flic-sel-exp exp)
+	  lambda-vars recursive-vars (the fixnum (1- c))))
+	(flic-is-constructor
+	 (simple-function-body-1
+	  (flic-is-constructor-exp exp)
+	  lambda-vars recursive-vars (the fixnum (1- c))))
+	((or flic-const flic-pack)
+	 (values (the fixnum (1- c)) lambda-vars))
+	(else
+         ;; case & let & lambda not allowed.
+	 (values -1 '())))))
+
+(define (list-remove-1 item list)
+  (cond ((null? list)
+	 '())
+	((eq? item (car list))
+	 (cdr list))
+	(else
+	 (cons (car list) (list-remove-1 item (cdr list))))
+	))
+
+(define (simple-function-body-1/l exps lambda-vars recursive-vars c)
+  (declare (type fixnum c))
+  (if (or (null? exps) (< c 0))
+      (values c lambda-vars)
+      (multiple-value-bind (c-1 lambda-vars-1)
+	  (simple-function-body-1 (car exps) lambda-vars recursive-vars c)
+	(simple-function-body-1/l
+	  (cdr exps) lambda-vars-1 recursive-vars c-1))))
+
+
+
+;;;===================================================================
+;;; Constant structured data detection
+;;;===================================================================
+
+
+;;; Look to determine whether an object is a structured constant,
+;;; recursively examining its components if it's an app.  This is
+;;; necessary in order to detect constants with arbitrary circular
+;;; reference to the vars in recursive-vars.
+
+(define (structured-constant-recursive? object recursive-vars stack)
+  (typecase object
+    (flic-const
+     '#t)
+    (flic-ref
+     (let ((var  (flic-ref-var object)))
+       (or (memq var stack)
+	   (var-toplevel? var)
+	   (and (memq var recursive-vars)
+		(structured-constant-recursive?
+		 (var-value var) recursive-vars (cons var stack))))))
+    (flic-pack
+     '#t)
+    (flic-app
+     (structured-constant-app-recursive?
+       (flic-app-fn object)
+       (flic-app-args object)
+       recursive-vars
+       stack))
+    (flic-lambda
+     (lambda-hoistable? object))
+    (else
+     '#f)))
+
+(define (structured-constant-app-recursive? fn args recursive-vars stack)
+  (and (is-type? 'flic-pack fn)
+       (eqv? (length args) (con-arity (flic-pack-con fn)))
+       (every-1 (lambda (a)
+		  (structured-constant-recursive? a recursive-vars stack))
+		args)))
+
+
+;;; Here's a non-recursive (and more efficient) version of the above.
+;;; Instead of looking at the whole structure, it only looks one level
+;;; deep.  This can't detect circular constants, but is useful in
+;;; contexts where circularities cannot appear.
+
+(define (structured-constant? object)
+  (typecase object
+    (flic-ref
+     (var-toplevel? (flic-ref-var object)))
+    (flic-const
+     '#t)
+    (flic-pack
+     '#t)
+    (flic-lambda
+     (lambda-hoistable? object))
+    (else
+     '#f)))
+
+(define (structured-constant-app? fn args)
+  (and (is-type? 'flic-pack fn)
+       (eqv? (length args) (con-arity (flic-pack-con fn)))
+       (every-1 (function structured-constant?) args)))
+
+
+;;; Determine whether a lambda can be hoisted to top-level.
+;;; The main purpose of this code is to mark structured constants
+;;; containing simple lambdas to permit later folding of sel expressions 
+;;; on those constants.  Since the latter expression is permissible
+;;; only on inlinable functions, stop if we hit an expression that
+;;; would make the function not inlinable.
+
+(define (lambda-hoistable? object)
+  (and (can-inline? object '() '#t)
+       (lambda-hoistable-aux
+	 (flic-lambda-body object)
+	 (flic-lambda-vars object))))
+
+(define (lambda-hoistable-aux object local-vars)
+  (typecase object
+    (flic-ref
+     (or (var-toplevel? (flic-ref-var object))
+	 (memq (flic-ref-var object) local-vars)))
+    ((or flic-const flic-pack)
+     '#t)
+    (flic-sel
+     (lambda-hoistable-aux (flic-sel-exp object) local-vars))
+    (flic-is-constructor
+     (lambda-hoistable-aux (flic-is-constructor-exp object) local-vars))
+    (flic-app
+     (and (lambda-hoistable-aux (flic-app-fn object) local-vars)
+	  (every-1 (lambda (x) (lambda-hoistable-aux x local-vars))
+		   (flic-app-args object))))
+    (else
+     '#f)))
+
+
+;;; Having determined that something is a structured constant,
+;;; enter it (and possibly its subcomponents) in the hash table
+;;; and return a var-ref.
+
+(define (enter-structured-constant value recursive?)
+  (multiple-value-bind (con args var)
+      (enter-structured-constant-aux value recursive?)
+    (when (not var)
+      (setf var (create-temp-var 'constant))
+      (add-new-structured-constant var con args))
+    (make-flic-ref var)))
+
+(define (enter-structured-constant-aux value recursive?)
+  (let* ((fn   (flic-app-fn value))
+	 (con  (flic-pack-con fn))
+	 (args (if recursive?
+		   (map (function enter-structured-constant-arg)
+			(flic-app-args value))
+		   (flic-app-args value))))
+    (values con args (lookup-structured-constant con args))))
+
+(define (enter-structured-constant-arg a)
+  (if (is-type? 'flic-app a)
+      (enter-structured-constant a '#t)
+      a))
+
+(define (lookup-structured-constant con args)
+  (lookup-structured-constant-aux
+    (table-entry *structured-constants-table* con) args))
+
+(define (lookup-structured-constant-aux alist args)
+  (cond ((null? alist)
+	 '#f)
+	((every (function flic-exp-eq?) (car (car alist)) args)
+	 (cdr (car alist)))
+	(else
+	 (lookup-structured-constant-aux (cdr alist) args))))
+
+(define (add-new-structured-constant var con args)
+  (push (cons args var) (table-entry *structured-constants-table* con))
+  (setf (var-toplevel? var) '#t)
+  (setf (var-value var) (make-flic-app (make-flic-pack con) args '#t))
+  (push var *structured-constants*)
+  var)
+
+
+
+;;;===================================================================
+;;; Invariant argument stuff
+;;;===================================================================
+
+
+;;; When processing a saturated call to a locally defined function,
+;;; note whether any of the arguments are always passed the same value.
+
+(define (note-invariant-args args vars)
+  (when (and (not (null? args)) (not (null? vars)))
+    (let* ((arg  (car args))
+	   (var  (car vars))
+	   (val  (var-arg-invariant-value var)))
+      (cond ((not (var-arg-invariant? var))
+	     ;; This argument already marked as having more than one
+	     ;; value.
+	     )
+	    ((and (is-type? 'flic-ref arg)
+		  (eq? (flic-ref-var arg) var))
+	     ;; This is a recursive call with the same argument.
+	     ;; Don't update the arg-invariant-value slot.
+	     )
+	    ((or (not val)
+		 (flic-exp-eq? arg val))
+	     ;; Either this is the first call, or a second call with
+	     ;; the same argument.
+	     (setf (var-arg-invariant-value var) arg))
+	    (else
+	     ;; Different values for this argument are passed in
+	     ;; different places, so we can't mess with it.
+	     (setf (var-arg-invariant? var) '#f)))
+      (note-invariant-args (cdr args) (cdr vars)))))
+
+
+;;; After processing a let form, check to see if any of the bindings
+;;; are for local functions with invariant arguments.
+;;; Suppose we have something like
+;;;   let foo = \ x y z -> <fn-body>
+;;;     in <let-body>
+;;; and y is known to be invariant; then we rewrite this as
+;;;   let foo1 = \ x z -> let y = <invariant-value> in <fn-body>
+;;;       foo = \ x1 y1 z1 -> foo1 x1 z1
+;;;     in <let-body>
+;;; The original foo binding is inlined on subsequent passes and 
+;;; should go away.  Likewise, the binding of y should be inlined also.
+;;; *** This is kind of bogus because of the way it depends on the
+;;; *** magic force-inline bit.  It would be better to do a code walk
+;;; *** now on the entire let expression to rewrite all the calls to foo.
+
+(define (add-stuff-for-invariants bindings)
+  (if (null? bindings)
+      '()
+      (let* ((var  (car bindings))
+	     (val  (var-value var)))
+	(setf (cdr bindings)
+	      (add-stuff-for-invariants (cdr bindings)))
+	(if (and (is-type? 'flic-lambda val)
+		 ;; Don't mess with single-reference variable bindings,
+		 ;; or things we are going to inline anyway.
+		 (not (var-single-ref var))
+		 (not (var-simple? var))
+		 ;; All references must be in saturated calls to do this.
+		 (eqv? (var-referenced var) (var-fn-referenced var))
+		 ;; There is at least one argument marked invariant.
+		 (some (function var-arg-invariant?) (flic-lambda-vars val))
+		 ;; Every argument marked invariant must also be hoistable.
+		 (every-1 (function arg-hoistable?) (flic-lambda-vars val)))
+	    (hoist-invariant-args
+	      var
+	      val
+	      bindings)
+	    bindings))))
+
+(define (arg-hoistable? var)
+  (if (var-arg-invariant? var)
+      (or (not (var-arg-invariant-value var))
+	  (flic-invariant? (var-arg-invariant-value var)
+			   (dynamic *local-bindings*)))
+      '#t))
+
+(define (hoist-invariant-args var val bindings)
+  (let ((foo1-var       (copy-temp-var (def-name var)))
+	(foo1-def-vars  '())
+	(foo1-app-args  '())
+	(foo1-let-vars  '())
+	(foo-def-vars   '()))
+    (push foo1-var bindings)
+    (dolist (v (flic-lambda-vars val))
+      (let ((new-v  (copy-temp-var (def-name v))))
+	(push (init-flic-var new-v '#f '#f) foo-def-vars)
+	(if (var-arg-invariant? v)
+	    (when (var-arg-invariant-value v)
+	      (push (init-flic-var
+		      v (copy-flic-top (var-arg-invariant-value v)) '#f)
+		    foo1-let-vars))
+	    (begin
+	      (push v foo1-def-vars)
+	      (push (make-flic-ref new-v) foo1-app-args))
+	  )))
+    (setf foo1-def-vars (nreverse foo1-def-vars))
+    (setf foo1-app-args (nreverse foo1-app-args))
+    (setf foo1-let-vars (nreverse foo1-let-vars))
+    (setf foo-def-vars (nreverse foo-def-vars))
+    (record-hack 'let-hoist-invariant-args var foo1-let-vars)
+    ;; Fix up the value of foo1
+    (init-flic-var
+      foo1-var
+      (let ((body  (make-flic-let foo1-let-vars (flic-lambda-body val) '#f)))
+	(if (null? foo1-def-vars)
+	    ;; *All* of the arguments were invariant.
+	    body
+	    ;; Otherwise, make a new lambda
+	    (make-flic-lambda foo1-def-vars body)))
+      '#f)
+    ;; Fix up the value of foo and arrange for it to be inlined.
+    (setf (flic-lambda-vars val) foo-def-vars)
+    (setf (flic-lambda-body val)
+	  (if (null? foo1-app-args)
+	      (make-flic-ref foo1-var)
+	      (make-flic-app (make-flic-ref foo1-var) foo1-app-args '#t)))
+    (setf (var-simple? var) '#t)
+    (setf (var-force-inline? var) '#t)
+    ;; Return modified list of bindings
+    bindings))
+
+
+
+;;;===================================================================
+;;; Install globals
+;;;===================================================================
+
+
+;;; The optimizer, CFN, etc. can introduce new top-level variables that
+;;; are not installed in the symbol table.  This causes problems if
+;;; those variables are referenced in the .hci file (as in the inline
+;;; expansion of some other variables).  So we need to fix up the 
+;;; symbol table before continuing.
+
+(define (install-uninterned-globals vars)
+  (dolist (v vars)
+    (let* ((module  (locate-module (def-module v)))
+	   (name    (def-name v))
+	   (table   (module-symbol-table module))
+	   (def     (table-entry table name)))
+      (cond ((not def)
+	     ;; This def was not installed.  Rename it if it's a gensym
+	     ;; and install it.
+	     (when (gensym? name)
+	       (setf name (rename-gensym-var v name table)))
+	     (setf (table-entry table name) v))
+	    ((eq? def v)
+	     ;; Already installed.
+	     '#t)
+	    (else
+	     ;; Ooops!  The symbol installed in the symbol table isn't 
+             ;; this one!
+	     (error "Duplicate defs ~s and ~s in symbol table for ~s!"
+		    v def module))
+	    ))))
+
+
+(define (rename-gensym-var var name table)
+  (setf name (string->symbol (symbol->string name)))
+  (if (table-entry table name)
+      ;; This name already in use; gensym a new one!
+      (rename-gensym-var var (gensym (symbol->string name)) table)
+      ;; OK, no problem
+      (setf (def-name var) name)))
+
+
+
+;;;===================================================================
+;;; Postoptimizer
+;;;===================================================================
+
+;;; This is another quick traversal of the structure to determine 
+;;; whether references to functions are fully saturated or not.
+;;; Also makes sure that reference counts on variables are correct;
+;;; this is needed so the code generator can generate ignore declarations
+;;; for unused lambda variables.
+
+(define-flic-walker postoptimize (object))
+
+(define-postoptimize flic-lambda (object)
+  (dolist (var (flic-lambda-vars object))
+    (setf (var-referenced var) 0))
+  (postoptimize (flic-lambda-body object)))
+
+(define-postoptimize flic-let (object)
+  (dolist (var (flic-let-bindings object))
+    (setf (var-referenced var) 0)
+    (let ((val  (var-value var)))
+      (setf (var-arity var)
+	    (if (is-type? 'flic-lambda val)
+		(length (flic-lambda-vars val))
+		0))))
+  (dolist (var (flic-let-bindings object))
+    (postoptimize (var-value var)))
+  (postoptimize (flic-let-body object)))
+
+(define-postoptimize flic-app (object)
+  (let ((fn    (flic-app-fn object)))
+    (typecase fn
+      (flic-ref
+       (let* ((var     (flic-ref-var fn))
+	      (arity   (var-arity var)))
+	 (if (not (var-toplevel? var)) (incf (var-referenced var)))
+	 (when (not (eqv? arity 0))
+	   (postoptimize-app-aux object var arity (flic-app-args object)))))
+      (flic-pack
+       (let* ((con    (flic-pack-con fn))
+	      (arity  (con-arity con)))
+	 (postoptimize-app-aux object '#f arity (flic-app-args object))))
+      (else
+       (postoptimize fn)))
+    (dolist (a (flic-app-args object))
+      (postoptimize a))))
+
+(define (postoptimize-app-aux object var arity args)
+  (declare (type fixnum arity))
+  (let ((nargs   (length args)))
+    (declare (type fixnum nargs))
+    (cond ((< nargs arity)
+	   ;; not enough arguments
+	   (when var (setf (var-standard-refs? var) '#t)))
+	  ((eqv? nargs arity)
+	   ;; exactly the right number of arguments
+	   (when var (setf (var-optimized-refs? var) '#t))
+	   (setf (flic-app-saturated? object) '#t))
+	  (else
+	   ;; make the fn a nested flic-app
+	   (multiple-value-bind (arghead argtail)
+	       (split-list args arity)
+	     (setf (flic-app-fn object)
+		   (make-flic-app (flic-app-fn object) arghead '#t))
+	     (setf (flic-app-args object) argtail)
+	     (when var (setf (var-optimized-refs? var) '#t))
+	     (dolist (a arghead)
+	       (postoptimize a))))
+	  )))
+
+(define-postoptimize flic-ref (object)
+  (let ((var  (flic-ref-var object)))
+    (if (not (var-toplevel? var)) (incf (var-referenced var)))
+    (setf (var-standard-refs? var) '#t)))
+
+(define-postoptimize flic-const (object)
+  object)
+
+(define-postoptimize flic-pack (object)
+  object)
+
+(define-postoptimize flic-and (object)
+  (for-each (function postoptimize) (flic-and-exps object)))
+
+(define-postoptimize flic-case-block (object)
+  (for-each (function postoptimize) (flic-case-block-exps object)))
+
+(define-postoptimize flic-if (object)
+  (postoptimize (flic-if-test-exp object))
+  (postoptimize (flic-if-then-exp object))
+  (postoptimize (flic-if-else-exp object)))
+
+(define-postoptimize flic-return-from (object)
+  (postoptimize (flic-return-from-exp object)))
+
+(define-postoptimize flic-sel (object)
+  (postoptimize (flic-sel-exp object)))
+
+(define-postoptimize flic-is-constructor (object)
+  (postoptimize (flic-is-constructor-exp object)))
+
+(define-postoptimize flic-con-number (object)
+  (postoptimize (flic-con-number-exp object)))
+
+(define-postoptimize flic-void (object)
+  object)
diff --git a/backend/strictness.scm b/backend/strictness.scm
new file mode 100644
index 0000000..5e03aa6
--- /dev/null
+++ b/backend/strictness.scm
@@ -0,0 +1,845 @@
+;;; strictness.scm -- strictness analyzer
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  28 May 1992
+;;;
+;;; The algorithm used here follows Consel, "Fast Strictness Analysis
+;;; Via Symbolic Fixpoint Interation".
+;;;
+;;; The basic idea is to do a traversal of the flic structure, building
+;;; a boolean term that represents the strictness of each subexpression.
+;;; The boolean terms are composed of ands & ors of the argument variables
+;;; to each function.  After traversing the body of the function, we can
+;;; determine which argument variables are strict by examining the 
+;;; corresponding term, and then we can update the strictness attribute
+;;; of the var that names the function.
+;;;
+;;; Another traversal needs to be done to attach strictness properties
+;;; to locally bound variables.  
+
+
+;;; Here's the main entry point.
+
+(define (strictness-analysis-top big-let)
+  (fun-strictness-walk big-let)
+  (var-strictness-walk big-let '() '())
+  ;; *** This probably belongs somewhere else?
+  (do-box-analysis big-let '() '() '#t)
+  big-let)
+
+
+;;;======================================================================
+;;; Function strictness analyzer code walk
+;;;======================================================================
+
+;;; This actually involves two code walkers.  The first merely traverses
+;;; structure and identifies function definitions.  The second traverses
+;;; the definitions of the functions to compute their strictness.
+
+
+;;; Fun-strictness-walk is the walker to find function definitions.
+;;; This is trivial for everything other than flic-let.
+
+(define-flic-walker fun-strictness-walk (object))
+
+(define-fun-strictness-walk flic-lambda (object)
+  (fun-strictness-walk (flic-lambda-body object)))
+
+(define-fun-strictness-walk flic-let (object)
+  (if (flic-let-recursive? object)
+      (fun-strictness-walk-letrec object)
+      (fun-strictness-walk-let* object))
+  (dolist (v (flic-let-bindings object))
+    (fun-strictness-walk (var-value v)))
+  (fun-strictness-walk (flic-let-body object)))
+
+(define-fun-strictness-walk flic-app (object)
+  (fun-strictness-walk (flic-app-fn object))
+  (for-each (function fun-strictness-walk) (flic-app-args object)))
+
+(define-fun-strictness-walk flic-ref (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-pack (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-const (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-case-block (object)
+  (for-each (function fun-strictness-walk) (flic-case-block-exps object)))
+
+(define-fun-strictness-walk flic-return-from (object)
+  (fun-strictness-walk (flic-return-from-exp object)))
+
+(define-fun-strictness-walk flic-and (object)
+  (for-each (function fun-strictness-walk) (flic-and-exps object)))
+
+(define-fun-strictness-walk flic-if (object)
+  (fun-strictness-walk (flic-if-test-exp object))
+  (fun-strictness-walk (flic-if-then-exp object))
+  (fun-strictness-walk (flic-if-else-exp object)))
+
+(define-fun-strictness-walk flic-sel (object)
+  (fun-strictness-walk (flic-sel-exp object)))
+
+(define-fun-strictness-walk flic-is-constructor (object)
+  (fun-strictness-walk (flic-is-constructor-exp object)))
+
+(define-fun-strictness-walk flic-con-number (object)
+  (fun-strictness-walk (flic-con-number-exp object)))
+
+(define-fun-strictness-walk flic-void (object)
+  (declare (ignore object))
+  '#f)
+
+
+
+;;; Here is the magic for let bindings of function definitions.
+;;; Sequential bindings are easy.  For recursive bindings, we must 
+;;; keep track of mutually recursive functions.
+;;; If a function binding has a strictness annotation attached,
+;;; do not mess with it further.
+
+(define (fun-strictness-walk-let* object)
+  (dolist (var (flic-let-bindings object))
+    (let ((val  (var-value var)))
+      (when (is-type? 'flic-lambda val)
+	(if (var-strictness var)
+	    (mark-argument-strictness
+	      (var-strictness var) (flic-lambda-vars val))
+	    (compute-function-strictness var val '())))
+      )))
+
+(define (fun-strictness-walk-letrec object)
+  (let ((stack   '()))
+    (dolist (var (flic-let-bindings object))
+      (let ((val  (var-value var)))
+	(if (and (is-type? 'flic-lambda val) (not (var-strictness var)))
+	    (setf stack (add-recursive-function-1 var (init-var-env) stack)))))
+    (dolist (var (flic-let-bindings object))
+      (let ((val  (var-value var)))
+	(when (is-type? 'flic-lambda val)
+	  (if (var-strictness var)
+	      (mark-argument-strictness
+	        (var-strictness var) (flic-lambda-vars val))
+	      (compute-function-strictness var val stack)))
+	))))
+
+(define (compute-function-strictness var val stack)
+  (let* ((vars  (flic-lambda-vars val))
+	 (env   (add-var-binding-n vars (map (function list) vars)
+				   (init-var-env)))
+	 (term  (compute-strictness-walk (flic-lambda-body val) env stack)))
+    (when (eq? term '#t)
+      (signal-infinite-loop-function var)
+      (setf (flic-lambda-body val)
+	    (make-infinite-loop-error
+	      (format '#f "Function ~s has an infinite loop." var))))
+    (setf (var-strictness var) (munge-strictness-terms term vars))))
+
+
+(define (signal-infinite-loop-function var)
+  (recoverable-error 'infinite-loop-function
+    "Function ~s has an infinite loop."
+    var))
+
+(define (make-infinite-loop-error msg)
+  (make-flic-app
+    (make-flic-ref (core-symbol "error"))
+    (list (make-flic-const msg))
+    '#t))
+
+  
+;;; compute-strictness-walk is the traversal to compute strictness
+;;; terms.
+;;; The purpose of the env is to map locally bound variables onto 
+;;; strictness terms which are expressed as lists of argument variables
+;;; to the function being analyzed.
+;;; The purpose of the stack is to keep track of recursive function
+;;; walks and recognize when we've reached a fixed point.
+
+(define-flic-walker compute-strictness-walk (object env stack))
+
+
+;;; Making a function never forces anything.
+
+(define-compute-strictness-walk flic-lambda (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+;;; For let, add bindings to environment and get strictness of body.
+
+(define-compute-strictness-walk flic-let (object env stack)
+  (let ((bindings    (flic-let-bindings object))
+	(body        (flic-let-body object))
+	(recursive?  (flic-let-recursive? object)))
+    (if recursive?
+	;; Must add stuff to env and stack before traversing anything.
+	(begin
+	  (dolist (var bindings)
+	    (setf env (add-var-binding-1 var '#f env)))
+	  (dolist (var bindings)
+	    (let ((val  (var-value var)))
+	      (when (is-type? 'flic-lambda val)
+		(setf stack (add-recursive-function-1 var env stack)))))
+	  (dolist (var bindings)
+	    (let ((val  (var-value var)))
+	      (set-var-env var env (compute-strictness-walk val env stack)))))
+	;; Otherwise just do things sequentially.
+	;; Note that even though there is no possibility of recursion
+	;; here, we must add stuff to the stack anyway so that we can
+	;; walk calls in the correct env.
+	(dolist (var bindings)
+	  (let ((val  (var-value var)))
+	    (when (is-type? 'flic-lambda val)
+	      (setf stack (add-recursive-function-1 var env stack)))
+	    (setf env
+		  (add-var-binding-1
+		    var (compute-strictness-walk val env stack) env)))))
+    (compute-strictness-walk body env stack)))
+
+
+;;; Treat explicit, saturated calls to named functions specially.
+
+(define-compute-strictness-walk flic-app (object env stack)
+  (let ((fn         (flic-app-fn object))
+	(args       (flic-app-args object))
+	(saturated? (flic-app-saturated? object)))
+    (cond ((and (is-type? 'flic-ref fn) saturated?)
+	   ;; Special handling for named functions.
+	   (compute-application-strictness
+	     (flic-ref-var fn)
+	     args env stack))
+	  ((and (is-type? 'flic-pack fn) saturated?)
+	   ;; Similarly for constructor applications, but we always
+	   ;; know which arguments are strict in advance.
+	   (compute-application-strictness-aux
+	      (con-slot-strict? (flic-pack-con fn))
+	      args env stack))
+	  (else
+	   ;; Otherwise, we know that the function expression is going to
+	   ;; be forced, but all of its arguments are lazy.  So ignore the
+	   ;; arguments in computing the strictness of the whole expression.
+	   (compute-strictness-walk fn env stack)))))
+
+
+(define (compute-application-strictness var args env stack)
+  (let* ((strictness          (var-strictness var))
+	 (info                '#f)
+	 (arg-strictness-list '#f))
+    (cond ((eq? var (core-symbol "error"))
+	   ;; This expression will return bottom no matter what.
+	   'error)
+	  (strictness
+	   ;; We've already completed the walk for this function and
+	   ;; determined which of its arguments are strict.
+	   ;; The strictness expression for the application is the
+	   ;; OR of the strictness of its non-lazy arguments.
+	   (compute-application-strictness-aux strictness args env stack))
+	  ((get-recursive-function-trace
+	     (setf arg-strictness-list
+		   (map (lambda (a) (compute-strictness-walk a env stack))
+			args))
+	     (setf info (get-recursive-function var stack)))
+	   ;; We're already tracing this call.  Return true to
+	   ;; terminate the fixpoint iteration.
+	   '#t)
+	  (else
+	   ;; Otherwise, begin a new trace instance.
+	   ;; Add stuff to the saved var-env to map references to
+	   ;; the argument variables to the strictness terms for
+	   ;; the actual arguments at this call site.
+	   ;; References to closed-over variables within the function
+	   ;; use the strictness values that were stored in the env
+	   ;; at the point of function definition.
+	   (let* ((env      (get-recursive-function-env info))
+		  (lambda   (var-value var))
+		  (body     (flic-lambda-body lambda))
+		  (vars     (flic-lambda-vars lambda))
+		  (result   '#f))
+	     (push-recursive-function-trace arg-strictness-list info)
+	     (setf result
+		   (compute-strictness-walk
+		     body
+		     (add-var-binding-n vars arg-strictness-list env)
+		     stack))
+	     (pop-recursive-function-trace info)
+	     result))
+	  )))
+
+
+(define (compute-application-strictness-aux strictness args env stack)
+  (make-or-term
+    (map (lambda (strict? arg)
+	   (if strict? (compute-strictness-walk arg env stack) '#f))
+	 strictness args)))
+
+
+;;; For a reference, look up the term associated with the variable in env.
+;;; If not present in the environment, ignore it; the binding was established
+;;; outside the scope of the function being analyzed.
+
+(define-compute-strictness-walk flic-ref (object env stack)
+  (declare (ignore stack))
+  (get-var-env (flic-ref-var object) env))
+	
+
+;;; References to constants or constructors never fail.
+
+(define-compute-strictness-walk flic-const (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+(define-compute-strictness-walk flic-pack (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+;;; The first clause of a case-block is the only one that is always
+;;; executed, so it is the only one that affects the strictness of
+;;; the overall expression.
+
+(define-compute-strictness-walk flic-case-block (object env stack)
+  (compute-strictness-walk (car (flic-case-block-exps object)) env stack))
+
+
+;;; Return-from fails if its subexpression fails.
+
+(define-compute-strictness-walk flic-return-from (object env stack)
+  (compute-strictness-walk (flic-return-from-exp object) env stack))
+
+
+;;; For and, the first subexpression is the only one that is always
+;;; executed, so it is the only one that affects the strictness of
+;;; the overall expression.
+
+(define-compute-strictness-walk flic-and (object env stack)
+  (compute-strictness-walk (car (flic-and-exps object)) env stack))
+
+
+;;; The strictness of an IF is the strictness of the test OR'ed
+;;; with the AND of the strictness of its branches.
+
+(define-compute-strictness-walk flic-if (object env stack)
+  (make-or-term-2
+    (compute-strictness-walk (flic-if-test-exp object) env stack)
+    (make-and-term-2
+      (compute-strictness-walk (flic-if-then-exp object) env stack)
+      (compute-strictness-walk (flic-if-else-exp object) env stack))))
+
+
+;;; Selecting a component of a data structure causes it to be forced,
+;;; so propagate the strictness of the subexpression upwards.
+
+(define-compute-strictness-walk flic-sel (object env stack)
+  (compute-strictness-walk (flic-sel-exp object) env stack))
+
+
+;;; Is-constructor and con-number force their subexpressions.
+
+(define-compute-strictness-walk flic-is-constructor (object env stack)
+  (compute-strictness-walk (flic-is-constructor-exp object) env stack))
+
+(define-compute-strictness-walk flic-con-number (object env stack)
+  (compute-strictness-walk (flic-con-number-exp object) env stack))
+
+(define-compute-strictness-walk flic-void (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+
+;;;======================================================================
+;;; Utilities for managing the env
+;;;======================================================================
+
+;;; The env is just an a-list.
+
+(define (init-var-env)
+  '())
+
+(define (add-var-binding-1 var binding env)
+  (cons (cons var binding) env))
+
+(define (add-var-binding-n vars bindings env)
+  (if (null? vars)
+      env
+      (add-var-binding-n (cdr vars) (cdr bindings)
+			 (cons (cons (car vars) (car bindings)) env))))
+
+(define (get-var-env var env)
+  (let ((stuff  (assq var env)))
+    (if stuff
+	(cdr stuff)
+	'#f)))
+
+(define (set-var-env var env new-value)
+  (let ((stuff  (assq var env)))
+    (if stuff
+	(setf (cdr stuff) new-value)
+	(error "Can't find binding for ~s in environment." var))))
+  
+
+
+;;;======================================================================
+;;; Utilities for managing the stack
+;;;======================================================================
+
+;;; For now, the stack is just an a-list too.
+;;; Some sort of hashing scheme could also be used instead of a linear
+;;; search, but if the iteration depth for the fixpoint analysis is
+;;; small, it's probably not worth the trouble.
+
+(define (add-recursive-function-1 var env stack)
+  (cons (list var env '()) stack))
+
+(define (get-recursive-function var stack)
+  (or (assq var stack)
+      (error "Can't find entry for ~s in stack." var)))
+
+(define (get-recursive-function-env entry)
+  (cadr entry))
+
+(define (push-recursive-function-trace new-args entry)
+  (push new-args (caddr entry)))
+
+(define (pop-recursive-function-trace entry)
+  (pop (caddr entry)))
+
+(define (get-recursive-function-trace args entry)
+  (get-recursive-function-trace-aux args (caddr entry)))
+
+(define (get-recursive-function-trace-aux args list)
+  (cond ((null? list)
+	 '#f)
+	((every (function term=) args (car list))
+	 '#t)
+	(else
+	 (get-recursive-function-trace-aux args (cdr list)))))
+
+
+;;;======================================================================
+;;; Utilities for boolean terms
+;;;======================================================================
+
+
+;;; A term is either #t, #f, the symbol 'error, or a list of variables 
+;;; (which are implicitly or'ed together).
+;;; #t and 'error are treated identically, except that #t indicates
+;;; failure because of infinite recursion and 'error indicates failure
+;;; due to a call to the error function.
+;;; In general, AND terms add nothing to the result, so to reduce
+;;; needless computation we generally reduce (and a b) to #f.
+
+;;; Make an OR term.  First look for some obvious special cases as an
+;;; efficiency hack, otherwise fall through to more general code.
+
+(define (make-or-term terms)
+  (cond ((null? terms)
+	 '#f)
+	((null? (cdr terms))
+	 (car terms))
+	((eq? (car terms) '#t)
+	 '#t)
+	((eq? (car terms) 'error)
+	 'error)
+	((eq? (car terms) '#f)
+	 (make-or-term (cdr terms)))
+	(else
+	 (make-or-term-2 (car terms) (make-or-term (cdr terms))))))
+
+(define (make-or-term-2 term1 term2)
+  (cond ((eq? term2 '#t)
+	 '#t)
+	((eq? term2 'error)
+	 'error)
+	((eq? term2 '#f)
+	 term1)
+	((eq? term1 '#t)
+	 '#t)
+	((eq? term1 'error)
+	 'error)
+	((eq? term1 '#f)
+	 term2)
+	;; At this point we know both terms are variable lists.
+	((implies? term2 term1)
+	 term2)
+	((implies? term1 term2)
+	 term1)
+	(else
+	 (merge-list-terms term1 term2))))
+
+
+;;;  Merge the two lists, throwing out duplicate variables.
+
+(define (merge-list-terms list1 list2)
+  (cond ((null? list1)
+	 list2)
+	((null? list2)
+	 list1)
+	((eq? (car list1) (car list2))
+	 (cons (car list1) (merge-list-terms (cdr list1) (cdr list2))))
+	((var< (car list1) (car list2))
+	 (cons (car list1) (merge-list-terms (cdr list1) list2)))
+	(else
+	 (cons (car list2) (merge-list-terms list1 (cdr list2))))))
+
+
+;;; Helper function: does term1 imply term2?
+;;; True if every subterm of term2 is also included in term1.
+
+(define (implies? term1 term2)
+  (every (lambda (v2) (memq v2 term1)) term2))
+
+
+;;; Make an AND term.  Because we don't want to build up arbitrarily
+;;; complex AND expressions, basically just compute an OR list that 
+;;; represents the intersection of the subterms.
+
+(define (make-and-term terms)
+  (cond ((null? terms)
+	 '#f)
+	((null? (cdr terms))
+	 (car terms))
+	((eq? (car terms) '#t)
+	 (make-and-term (cdr terms)))
+	((eq? (car terms) 'error)
+	 (make-and-term (cdr terms)))
+	((eq? (car terms) '#f)
+	 '#f)
+	(else
+	 (make-and-term-2 (car terms) (make-and-term (cdr terms))))))
+
+(define (make-and-term-2 term1 term2)
+  (cond ((eq? term2 '#t)
+	 term1)
+	((eq? term2 'error)
+	 term1)
+	((eq? term2 '#f)
+	 '#f)
+	((eq? term1 '#t)
+	 term2)
+	((eq? term1 'error)
+	 term2)
+	((eq? term1 '#f)
+	 '#f)
+	;; At this point we know both terms are variable lists.
+	((implies? term2 term1)
+	 term1)
+	((implies? term1 term2)
+	 term2)
+	(else
+	 (let ((result  '()))
+	   (dolist (v term1)
+	     (if (memq v term2)
+		 (push v result)))
+	   (if (null? result)
+	       '#f
+	       (nreverse result))))
+	))
+
+
+;;; Subterms of an and/or term are always sorted, so that to compare
+;;; two terms we can just compare subterms componentwise.
+
+(define (term= term1 term2)
+  (or (eq? term1 term2)
+      (and (pair? term1)
+	   (pair? term2)
+	   (eq? (car term1) (car term2))
+	   (term= (cdr term1) (cdr term2)))))
+
+
+;;; Variables within an OR-list are sorted alphabetically by names.
+
+(define (var< var1 var2)
+  (string<? (symbol->string (def-name var1))
+	    (symbol->string (def-name var2))))
+
+
+;;; Determine which of the vars are present in the term.
+
+(define (munge-strictness-terms term vars)
+  (map (lambda (v)
+	 (setf (var-strict? v)
+	       (cond ((var-force-strict? v)
+		      '#t)
+		     ((eq? term '#t)
+		      '#t)
+		     ((eq? term 'error)
+		      '#t)
+		     ((eq? term '#f)
+		      '#f)
+		     ((memq v term)
+		      '#t)
+		     (else
+		      '#f))))
+       vars))
+
+(define (mark-argument-strictness strictness vars)
+  (map (lambda (s v) (setf (var-strict? v) s)) strictness vars))
+
+
+
+;;;======================================================================
+;;; Variable strictness propagation code walk
+;;;======================================================================
+
+;;; Walk the code, marking any vars found in strict contexts as strict.
+;;; Locally bound variables are consed onto the varlist.  This is
+;;; used to determine which variables can be marked as strict when they
+;;; appear in strict contexts.
+;;; When walking something that does not appear in a strict context
+;;; or that is not always evaluated, reinitialize varlist to the empty
+;;; list.
+;;; The stack is used to keep track of variables that have not been
+;;; initialized yet, so that we can detect some kinds of infinite loops.
+;;; When walking something that is not always evaluated, reset this to 
+;;; the empty list.
+
+(define-flic-walker var-strictness-walk (object varlist stack))
+
+
+
+;;; Since the body of the lambda might not be evaluated, reset
+;;; both varlist and stack.
+
+(define-var-strictness-walk flic-lambda (object varlist stack)
+  (declare (ignore varlist stack))
+  (var-strictness-walk (flic-lambda-body object) '() '()))
+
+
+;;; The basic idea for let is to find the variables that are strict in 
+;;; the body first, and propagate that information backwards to the 
+;;; binding initializers.
+
+(define-var-strictness-walk flic-let (object varlist stack)
+  (let ((bindings  (flic-let-bindings object)))
+    (var-strictness-walk-let-aux
+      bindings
+      (flic-let-body object)
+      (append bindings varlist)
+      (append bindings stack)
+      (flic-let-recursive? object))))
+
+(define (var-strictness-walk-let-aux bindings body varlist stack recursive?)
+  (if (null? bindings)
+      (var-strictness-walk body varlist stack)
+      (begin
+	(var-strictness-walk-let-aux
+	  (cdr bindings) body varlist (cdr stack) recursive?)
+	(let* ((var  (car bindings))
+	       (val  (var-value var)))
+	  (cond ((var-strict? var)
+		 ;; Recursive variables have to be set back to unstrict
+		 ;; because the value form might contain forward references.
+		 ;; The box analyzer will set them to strict again if the
+		 ;; value forms are safe.
+		 (when recursive? (setf (var-strict? var) '#f))
+		 ;; Detect x = 1 + x circularities here
+		 (var-strictness-walk val varlist stack))
+		((flic-exp-strict-result? val)
+		 ;; The val is going to be wrapped in a delay.
+		 (var-strictness-walk val '() '()))
+		(else
+		 ;; Watch out for x = x and x = cdr x circularities.
+		 ;; *** I am still a little confused about this.  It
+		 ;; *** seems like the stack should be passed through
+		 ;; *** when walking already-boxed values that appear as
+                 ;; *** non-strict function arguments as well, but doing
+		 ;; *** so generates some apparently bogus complaints
+		 ;; *** about infinite loops.  So maybe doing it here
+		 ;; *** is incorrect too, and we just haven't run across
+		 ;; *** a test case that triggers it???
+		 (var-strictness-walk val '() stack))
+		)))))
+
+
+(define (flic-exp-strict-result? val)
+  (cond ((is-type? 'flic-ref val)
+	 (var-strict? (flic-ref-var val)))
+	((is-type? 'flic-sel val)
+	 (list-ref (con-slot-strict? (flic-sel-con val)) (flic-sel-i val)))
+	(else
+	 '#t)))
+
+(define-var-strictness-walk flic-app (object varlist stack)
+  (let ((fn           (flic-app-fn object))
+	(args         (flic-app-args object))
+	(saturated?   (flic-app-saturated? object)))
+    (cond ((and saturated? (is-type? 'flic-ref fn))
+	   ;; Strictness of function should be stored on var
+	   (do-var-strictness-flic-app-aux
+	     (var-strictness (flic-ref-var fn))
+	     fn args varlist stack))
+	  ((and saturated? (is-type? 'flic-pack fn))
+	   ;; Strictness of constructor should be stored on con
+	   (do-var-strictness-flic-app-aux
+	     (con-slot-strict? (flic-pack-con fn))
+	     fn args varlist stack))
+	  (else
+	   ;; All arguments are non-strict
+	   (var-strictness-walk fn varlist stack)
+	   (dolist (a args)
+	     (var-strictness-walk a '() '()))))))
+
+(define (do-var-strictness-flic-app-aux strictness fn args varlist stack)
+  (when (not strictness)
+    (error "Can't find strictness for function ~s." fn))
+  (dolist (a args)
+    (if (pop strictness)
+	(var-strictness-walk a varlist stack)
+	(var-strictness-walk a '() '()))))
+
+
+(define-var-strictness-walk flic-ref (object varlist stack)
+  (let ((var  (flic-ref-var object)))
+    (cond ((memq var stack)
+	   ;; Circular variable definition detected.
+	   (signal-infinite-loop-variable var)
+	   (setf (var-value var)
+		 (make-infinite-loop-error
+		   (format '#f "Variable ~s has an infinite loop." var))))
+	  ((memq var varlist)
+	   (setf (var-strict? var) '#t))
+	  (else
+	   '#f))))
+
+(define (signal-infinite-loop-variable var)
+  (recoverable-error 'infinite-loop-variable
+    "Variable ~s has an infinite loop."
+    var))
+
+(define-var-strictness-walk flic-const (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+(define-var-strictness-walk flic-pack (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+(define-var-strictness-walk flic-case-block (object varlist stack)
+  (var-strictness-walk (car (flic-case-block-exps object)) varlist stack)
+  (dolist (exp (cdr (flic-case-block-exps object)))
+    (var-strictness-walk exp '() '())))
+
+(define-var-strictness-walk flic-return-from (object varlist stack)
+  (var-strictness-walk (flic-return-from-exp object) varlist stack))
+
+(define-var-strictness-walk flic-and (object varlist stack)
+  (var-strictness-walk (car (flic-and-exps object)) varlist stack)
+  (dolist (exp (cdr (flic-and-exps object)))
+    (var-strictness-walk exp '() '())))
+
+(define-var-strictness-walk flic-if (object varlist stack)
+  (var-strictness-walk (flic-if-test-exp object) varlist stack)
+  (var-strictness-walk (flic-if-then-exp object) '() '())
+  (var-strictness-walk (flic-if-else-exp object) '() '()))
+
+(define-var-strictness-walk flic-sel (object varlist stack)
+  (var-strictness-walk (flic-sel-exp object) varlist stack))
+
+(define-var-strictness-walk flic-is-constructor (object varlist stack)
+  (var-strictness-walk (flic-is-constructor-exp object) varlist stack))
+
+(define-var-strictness-walk flic-con-number (object varlist stack)
+  (var-strictness-walk (flic-con-number-exp object) varlist stack))
+
+(define-var-strictness-walk flic-void (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+
+
+;;;======================================================================
+;;; Printer support
+;;;======================================================================
+
+(define (strictness-analysis-printer big-let)
+  (print-strictness big-let 0))
+
+(define (print-strictness-list list depth)
+  (dolist (o list)
+    (print-strictness o depth)))
+
+(define (print-strictness-indent depth)
+  (dotimes (i (* 2 depth))
+    (declare (ignorable i))
+    (write-char #\space)))
+
+(define (strictness-string bool)
+  (if bool "#t" "#f"))
+
+(define-flic-walker print-strictness (object depth))
+
+(define-print-strictness flic-lambda (object depth)
+  (print-strictness-indent depth)
+  (format '#t "In anonymous function:~%")
+  (print-strictness (flic-lambda-body object) (1+ depth)))
+
+(define-print-strictness flic-let (object depth)
+  (dolist (var (flic-let-bindings object))
+    (let ((val  (var-value var)))
+      (if (is-type? 'flic-lambda val)
+	  (begin
+	    (print-strictness-indent depth)
+	    (format '#t "Function ~s has argument strictness ~a.~%"
+		    var
+		    (map (function strictness-string) (var-strictness var)))
+	    (print-strictness (flic-lambda-body val) (1+ depth)))
+	  (begin
+	    (print-strictness-indent depth)
+	    (format '#t "Variable ~s has strictness ~a.~%"
+		    var
+		    (strictness-string (var-strict? var)))
+	    (print-strictness val depth)))))
+  (print-strictness (flic-let-body object) depth))
+
+(define-print-strictness flic-app (object depth)
+  (print-strictness (flic-app-fn object) depth)
+  (print-strictness-list (flic-app-args object) depth))
+
+(define-print-strictness flic-ref (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-const (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-pack (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-case-block (object depth)
+  (print-strictness-list (flic-case-block-exps object) depth))
+
+(define-print-strictness flic-return-from (object depth)
+  (print-strictness (flic-return-from-exp object) depth))
+
+(define-print-strictness flic-and (object depth)
+  (print-strictness-list (flic-and-exps object) depth))
+
+(define-print-strictness flic-if (object depth)
+  (print-strictness (flic-if-test-exp object) depth)
+  (print-strictness (flic-if-then-exp object) depth)
+  (print-strictness (flic-if-else-exp object) depth))
+
+(define-print-strictness flic-sel (object depth)
+  (print-strictness (flic-sel-exp object) depth))
+
+(define-print-strictness flic-is-constructor (object depth)
+  (print-strictness (flic-is-constructor-exp object) depth))
+
+(define-print-strictness flic-con-number (object depth)
+  (print-strictness (flic-con-number-exp object) depth))
+
+(define-print-strictness flic-void (object depth)
+  (declare (ignore object depth))
+  '#f)
+