From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 backend/optimize.scm | 1986 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 1986 insertions(+)
 create mode 100644 backend/optimize.scm

(limited to 'backend/optimize.scm')

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)
-- 
cgit v1.2.3