path: root/backend/optimize.scm

;;; 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)