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/strictness.scm | 845 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 845 insertions(+)
 create mode 100644 backend/strictness.scm

(limited to 'backend/strictness.scm')

diff --git a/backend/strictness.scm b/backend/strictness.scm
new file mode 100644
index 0000000..5e03aa6
--- /dev/null
+++ b/backend/strictness.scm
@@ -0,0 +1,845 @@
+;;; strictness.scm -- strictness analyzer
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  28 May 1992
+;;;
+;;; The algorithm used here follows Consel, "Fast Strictness Analysis
+;;; Via Symbolic Fixpoint Interation".
+;;;
+;;; The basic idea is to do a traversal of the flic structure, building
+;;; a boolean term that represents the strictness of each subexpression.
+;;; The boolean terms are composed of ands & ors of the argument variables
+;;; to each function.  After traversing the body of the function, we can
+;;; determine which argument variables are strict by examining the 
+;;; corresponding term, and then we can update the strictness attribute
+;;; of the var that names the function.
+;;;
+;;; Another traversal needs to be done to attach strictness properties
+;;; to locally bound variables.  
+
+
+;;; Here's the main entry point.
+
+(define (strictness-analysis-top big-let)
+  (fun-strictness-walk big-let)
+  (var-strictness-walk big-let '() '())
+  ;; *** This probably belongs somewhere else?
+  (do-box-analysis big-let '() '() '#t)
+  big-let)
+
+
+;;;======================================================================
+;;; Function strictness analyzer code walk
+;;;======================================================================
+
+;;; This actually involves two code walkers.  The first merely traverses
+;;; structure and identifies function definitions.  The second traverses
+;;; the definitions of the functions to compute their strictness.
+
+
+;;; Fun-strictness-walk is the walker to find function definitions.
+;;; This is trivial for everything other than flic-let.
+
+(define-flic-walker fun-strictness-walk (object))
+
+(define-fun-strictness-walk flic-lambda (object)
+  (fun-strictness-walk (flic-lambda-body object)))
+
+(define-fun-strictness-walk flic-let (object)
+  (if (flic-let-recursive? object)
+      (fun-strictness-walk-letrec object)
+      (fun-strictness-walk-let* object))
+  (dolist (v (flic-let-bindings object))
+    (fun-strictness-walk (var-value v)))
+  (fun-strictness-walk (flic-let-body object)))
+
+(define-fun-strictness-walk flic-app (object)
+  (fun-strictness-walk (flic-app-fn object))
+  (for-each (function fun-strictness-walk) (flic-app-args object)))
+
+(define-fun-strictness-walk flic-ref (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-pack (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-const (object)
+  (declare (ignore object))
+  '#f)
+
+(define-fun-strictness-walk flic-case-block (object)
+  (for-each (function fun-strictness-walk) (flic-case-block-exps object)))
+
+(define-fun-strictness-walk flic-return-from (object)
+  (fun-strictness-walk (flic-return-from-exp object)))
+
+(define-fun-strictness-walk flic-and (object)
+  (for-each (function fun-strictness-walk) (flic-and-exps object)))
+
+(define-fun-strictness-walk flic-if (object)
+  (fun-strictness-walk (flic-if-test-exp object))
+  (fun-strictness-walk (flic-if-then-exp object))
+  (fun-strictness-walk (flic-if-else-exp object)))
+
+(define-fun-strictness-walk flic-sel (object)
+  (fun-strictness-walk (flic-sel-exp object)))
+
+(define-fun-strictness-walk flic-is-constructor (object)
+  (fun-strictness-walk (flic-is-constructor-exp object)))
+
+(define-fun-strictness-walk flic-con-number (object)
+  (fun-strictness-walk (flic-con-number-exp object)))
+
+(define-fun-strictness-walk flic-void (object)
+  (declare (ignore object))
+  '#f)
+
+
+
+;;; Here is the magic for let bindings of function definitions.
+;;; Sequential bindings are easy.  For recursive bindings, we must 
+;;; keep track of mutually recursive functions.
+;;; If a function binding has a strictness annotation attached,
+;;; do not mess with it further.
+
+(define (fun-strictness-walk-let* object)
+  (dolist (var (flic-let-bindings object))
+    (let ((val  (var-value var)))
+      (when (is-type? 'flic-lambda val)
+	(if (var-strictness var)
+	    (mark-argument-strictness
+	      (var-strictness var) (flic-lambda-vars val))
+	    (compute-function-strictness var val '())))
+      )))
+
+(define (fun-strictness-walk-letrec object)
+  (let ((stack   '()))
+    (dolist (var (flic-let-bindings object))
+      (let ((val  (var-value var)))
+	(if (and (is-type? 'flic-lambda val) (not (var-strictness var)))
+	    (setf stack (add-recursive-function-1 var (init-var-env) stack)))))
+    (dolist (var (flic-let-bindings object))
+      (let ((val  (var-value var)))
+	(when (is-type? 'flic-lambda val)
+	  (if (var-strictness var)
+	      (mark-argument-strictness
+	        (var-strictness var) (flic-lambda-vars val))
+	      (compute-function-strictness var val stack)))
+	))))
+
+(define (compute-function-strictness var val stack)
+  (let* ((vars  (flic-lambda-vars val))
+	 (env   (add-var-binding-n vars (map (function list) vars)
+				   (init-var-env)))
+	 (term  (compute-strictness-walk (flic-lambda-body val) env stack)))
+    (when (eq? term '#t)
+      (signal-infinite-loop-function var)
+      (setf (flic-lambda-body val)
+	    (make-infinite-loop-error
+	      (format '#f "Function ~s has an infinite loop." var))))
+    (setf (var-strictness var) (munge-strictness-terms term vars))))
+
+
+(define (signal-infinite-loop-function var)
+  (recoverable-error 'infinite-loop-function
+    "Function ~s has an infinite loop."
+    var))
+
+(define (make-infinite-loop-error msg)
+  (make-flic-app
+    (make-flic-ref (core-symbol "error"))
+    (list (make-flic-const msg))
+    '#t))
+
+  
+;;; compute-strictness-walk is the traversal to compute strictness
+;;; terms.
+;;; The purpose of the env is to map locally bound variables onto 
+;;; strictness terms which are expressed as lists of argument variables
+;;; to the function being analyzed.
+;;; The purpose of the stack is to keep track of recursive function
+;;; walks and recognize when we've reached a fixed point.
+
+(define-flic-walker compute-strictness-walk (object env stack))
+
+
+;;; Making a function never forces anything.
+
+(define-compute-strictness-walk flic-lambda (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+;;; For let, add bindings to environment and get strictness of body.
+
+(define-compute-strictness-walk flic-let (object env stack)
+  (let ((bindings    (flic-let-bindings object))
+	(body        (flic-let-body object))
+	(recursive?  (flic-let-recursive? object)))
+    (if recursive?
+	;; Must add stuff to env and stack before traversing anything.
+	(begin
+	  (dolist (var bindings)
+	    (setf env (add-var-binding-1 var '#f env)))
+	  (dolist (var bindings)
+	    (let ((val  (var-value var)))
+	      (when (is-type? 'flic-lambda val)
+		(setf stack (add-recursive-function-1 var env stack)))))
+	  (dolist (var bindings)
+	    (let ((val  (var-value var)))
+	      (set-var-env var env (compute-strictness-walk val env stack)))))
+	;; Otherwise just do things sequentially.
+	;; Note that even though there is no possibility of recursion
+	;; here, we must add stuff to the stack anyway so that we can
+	;; walk calls in the correct env.
+	(dolist (var bindings)
+	  (let ((val  (var-value var)))
+	    (when (is-type? 'flic-lambda val)
+	      (setf stack (add-recursive-function-1 var env stack)))
+	    (setf env
+		  (add-var-binding-1
+		    var (compute-strictness-walk val env stack) env)))))
+    (compute-strictness-walk body env stack)))
+
+
+;;; Treat explicit, saturated calls to named functions specially.
+
+(define-compute-strictness-walk flic-app (object env stack)
+  (let ((fn         (flic-app-fn object))
+	(args       (flic-app-args object))
+	(saturated? (flic-app-saturated? object)))
+    (cond ((and (is-type? 'flic-ref fn) saturated?)
+	   ;; Special handling for named functions.
+	   (compute-application-strictness
+	     (flic-ref-var fn)
+	     args env stack))
+	  ((and (is-type? 'flic-pack fn) saturated?)
+	   ;; Similarly for constructor applications, but we always
+	   ;; know which arguments are strict in advance.
+	   (compute-application-strictness-aux
+	      (con-slot-strict? (flic-pack-con fn))
+	      args env stack))
+	  (else
+	   ;; Otherwise, we know that the function expression is going to
+	   ;; be forced, but all of its arguments are lazy.  So ignore the
+	   ;; arguments in computing the strictness of the whole expression.
+	   (compute-strictness-walk fn env stack)))))
+
+
+(define (compute-application-strictness var args env stack)
+  (let* ((strictness          (var-strictness var))
+	 (info                '#f)
+	 (arg-strictness-list '#f))
+    (cond ((eq? var (core-symbol "error"))
+	   ;; This expression will return bottom no matter what.
+	   'error)
+	  (strictness
+	   ;; We've already completed the walk for this function and
+	   ;; determined which of its arguments are strict.
+	   ;; The strictness expression for the application is the
+	   ;; OR of the strictness of its non-lazy arguments.
+	   (compute-application-strictness-aux strictness args env stack))
+	  ((get-recursive-function-trace
+	     (setf arg-strictness-list
+		   (map (lambda (a) (compute-strictness-walk a env stack))
+			args))
+	     (setf info (get-recursive-function var stack)))
+	   ;; We're already tracing this call.  Return true to
+	   ;; terminate the fixpoint iteration.
+	   '#t)
+	  (else
+	   ;; Otherwise, begin a new trace instance.
+	   ;; Add stuff to the saved var-env to map references to
+	   ;; the argument variables to the strictness terms for
+	   ;; the actual arguments at this call site.
+	   ;; References to closed-over variables within the function
+	   ;; use the strictness values that were stored in the env
+	   ;; at the point of function definition.
+	   (let* ((env      (get-recursive-function-env info))
+		  (lambda   (var-value var))
+		  (body     (flic-lambda-body lambda))
+		  (vars     (flic-lambda-vars lambda))
+		  (result   '#f))
+	     (push-recursive-function-trace arg-strictness-list info)
+	     (setf result
+		   (compute-strictness-walk
+		     body
+		     (add-var-binding-n vars arg-strictness-list env)
+		     stack))
+	     (pop-recursive-function-trace info)
+	     result))
+	  )))
+
+
+(define (compute-application-strictness-aux strictness args env stack)
+  (make-or-term
+    (map (lambda (strict? arg)
+	   (if strict? (compute-strictness-walk arg env stack) '#f))
+	 strictness args)))
+
+
+;;; For a reference, look up the term associated with the variable in env.
+;;; If not present in the environment, ignore it; the binding was established
+;;; outside the scope of the function being analyzed.
+
+(define-compute-strictness-walk flic-ref (object env stack)
+  (declare (ignore stack))
+  (get-var-env (flic-ref-var object) env))
+	
+
+;;; References to constants or constructors never fail.
+
+(define-compute-strictness-walk flic-const (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+(define-compute-strictness-walk flic-pack (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+;;; The first clause of a case-block is the only one that is always
+;;; executed, so it is the only one that affects the strictness of
+;;; the overall expression.
+
+(define-compute-strictness-walk flic-case-block (object env stack)
+  (compute-strictness-walk (car (flic-case-block-exps object)) env stack))
+
+
+;;; Return-from fails if its subexpression fails.
+
+(define-compute-strictness-walk flic-return-from (object env stack)
+  (compute-strictness-walk (flic-return-from-exp object) env stack))
+
+
+;;; For and, the first subexpression is the only one that is always
+;;; executed, so it is the only one that affects the strictness of
+;;; the overall expression.
+
+(define-compute-strictness-walk flic-and (object env stack)
+  (compute-strictness-walk (car (flic-and-exps object)) env stack))
+
+
+;;; The strictness of an IF is the strictness of the test OR'ed
+;;; with the AND of the strictness of its branches.
+
+(define-compute-strictness-walk flic-if (object env stack)
+  (make-or-term-2
+    (compute-strictness-walk (flic-if-test-exp object) env stack)
+    (make-and-term-2
+      (compute-strictness-walk (flic-if-then-exp object) env stack)
+      (compute-strictness-walk (flic-if-else-exp object) env stack))))
+
+
+;;; Selecting a component of a data structure causes it to be forced,
+;;; so propagate the strictness of the subexpression upwards.
+
+(define-compute-strictness-walk flic-sel (object env stack)
+  (compute-strictness-walk (flic-sel-exp object) env stack))
+
+
+;;; Is-constructor and con-number force their subexpressions.
+
+(define-compute-strictness-walk flic-is-constructor (object env stack)
+  (compute-strictness-walk (flic-is-constructor-exp object) env stack))
+
+(define-compute-strictness-walk flic-con-number (object env stack)
+  (compute-strictness-walk (flic-con-number-exp object) env stack))
+
+(define-compute-strictness-walk flic-void (object env stack)
+  (declare (ignore object env stack))
+  '#f)
+
+
+
+;;;======================================================================
+;;; Utilities for managing the env
+;;;======================================================================
+
+;;; The env is just an a-list.
+
+(define (init-var-env)
+  '())
+
+(define (add-var-binding-1 var binding env)
+  (cons (cons var binding) env))
+
+(define (add-var-binding-n vars bindings env)
+  (if (null? vars)
+      env
+      (add-var-binding-n (cdr vars) (cdr bindings)
+			 (cons (cons (car vars) (car bindings)) env))))
+
+(define (get-var-env var env)
+  (let ((stuff  (assq var env)))
+    (if stuff
+	(cdr stuff)
+	'#f)))
+
+(define (set-var-env var env new-value)
+  (let ((stuff  (assq var env)))
+    (if stuff
+	(setf (cdr stuff) new-value)
+	(error "Can't find binding for ~s in environment." var))))
+  
+
+
+;;;======================================================================
+;;; Utilities for managing the stack
+;;;======================================================================
+
+;;; For now, the stack is just an a-list too.
+;;; Some sort of hashing scheme could also be used instead of a linear
+;;; search, but if the iteration depth for the fixpoint analysis is
+;;; small, it's probably not worth the trouble.
+
+(define (add-recursive-function-1 var env stack)
+  (cons (list var env '()) stack))
+
+(define (get-recursive-function var stack)
+  (or (assq var stack)
+      (error "Can't find entry for ~s in stack." var)))
+
+(define (get-recursive-function-env entry)
+  (cadr entry))
+
+(define (push-recursive-function-trace new-args entry)
+  (push new-args (caddr entry)))
+
+(define (pop-recursive-function-trace entry)
+  (pop (caddr entry)))
+
+(define (get-recursive-function-trace args entry)
+  (get-recursive-function-trace-aux args (caddr entry)))
+
+(define (get-recursive-function-trace-aux args list)
+  (cond ((null? list)
+	 '#f)
+	((every (function term=) args (car list))
+	 '#t)
+	(else
+	 (get-recursive-function-trace-aux args (cdr list)))))
+
+
+;;;======================================================================
+;;; Utilities for boolean terms
+;;;======================================================================
+
+
+;;; A term is either #t, #f, the symbol 'error, or a list of variables 
+;;; (which are implicitly or'ed together).
+;;; #t and 'error are treated identically, except that #t indicates
+;;; failure because of infinite recursion and 'error indicates failure
+;;; due to a call to the error function.
+;;; In general, AND terms add nothing to the result, so to reduce
+;;; needless computation we generally reduce (and a b) to #f.
+
+;;; Make an OR term.  First look for some obvious special cases as an
+;;; efficiency hack, otherwise fall through to more general code.
+
+(define (make-or-term terms)
+  (cond ((null? terms)
+	 '#f)
+	((null? (cdr terms))
+	 (car terms))
+	((eq? (car terms) '#t)
+	 '#t)
+	((eq? (car terms) 'error)
+	 'error)
+	((eq? (car terms) '#f)
+	 (make-or-term (cdr terms)))
+	(else
+	 (make-or-term-2 (car terms) (make-or-term (cdr terms))))))
+
+(define (make-or-term-2 term1 term2)
+  (cond ((eq? term2 '#t)
+	 '#t)
+	((eq? term2 'error)
+	 'error)
+	((eq? term2 '#f)
+	 term1)
+	((eq? term1 '#t)
+	 '#t)
+	((eq? term1 'error)
+	 'error)
+	((eq? term1 '#f)
+	 term2)
+	;; At this point we know both terms are variable lists.
+	((implies? term2 term1)
+	 term2)
+	((implies? term1 term2)
+	 term1)
+	(else
+	 (merge-list-terms term1 term2))))
+
+
+;;;  Merge the two lists, throwing out duplicate variables.
+
+(define (merge-list-terms list1 list2)
+  (cond ((null? list1)
+	 list2)
+	((null? list2)
+	 list1)
+	((eq? (car list1) (car list2))
+	 (cons (car list1) (merge-list-terms (cdr list1) (cdr list2))))
+	((var< (car list1) (car list2))
+	 (cons (car list1) (merge-list-terms (cdr list1) list2)))
+	(else
+	 (cons (car list2) (merge-list-terms list1 (cdr list2))))))
+
+
+;;; Helper function: does term1 imply term2?
+;;; True if every subterm of term2 is also included in term1.
+
+(define (implies? term1 term2)
+  (every (lambda (v2) (memq v2 term1)) term2))
+
+
+;;; Make an AND term.  Because we don't want to build up arbitrarily
+;;; complex AND expressions, basically just compute an OR list that 
+;;; represents the intersection of the subterms.
+
+(define (make-and-term terms)
+  (cond ((null? terms)
+	 '#f)
+	((null? (cdr terms))
+	 (car terms))
+	((eq? (car terms) '#t)
+	 (make-and-term (cdr terms)))
+	((eq? (car terms) 'error)
+	 (make-and-term (cdr terms)))
+	((eq? (car terms) '#f)
+	 '#f)
+	(else
+	 (make-and-term-2 (car terms) (make-and-term (cdr terms))))))
+
+(define (make-and-term-2 term1 term2)
+  (cond ((eq? term2 '#t)
+	 term1)
+	((eq? term2 'error)
+	 term1)
+	((eq? term2 '#f)
+	 '#f)
+	((eq? term1 '#t)
+	 term2)
+	((eq? term1 'error)
+	 term2)
+	((eq? term1 '#f)
+	 '#f)
+	;; At this point we know both terms are variable lists.
+	((implies? term2 term1)
+	 term1)
+	((implies? term1 term2)
+	 term2)
+	(else
+	 (let ((result  '()))
+	   (dolist (v term1)
+	     (if (memq v term2)
+		 (push v result)))
+	   (if (null? result)
+	       '#f
+	       (nreverse result))))
+	))
+
+
+;;; Subterms of an and/or term are always sorted, so that to compare
+;;; two terms we can just compare subterms componentwise.
+
+(define (term= term1 term2)
+  (or (eq? term1 term2)
+      (and (pair? term1)
+	   (pair? term2)
+	   (eq? (car term1) (car term2))
+	   (term= (cdr term1) (cdr term2)))))
+
+
+;;; Variables within an OR-list are sorted alphabetically by names.
+
+(define (var< var1 var2)
+  (string<? (symbol->string (def-name var1))
+	    (symbol->string (def-name var2))))
+
+
+;;; Determine which of the vars are present in the term.
+
+(define (munge-strictness-terms term vars)
+  (map (lambda (v)
+	 (setf (var-strict? v)
+	       (cond ((var-force-strict? v)
+		      '#t)
+		     ((eq? term '#t)
+		      '#t)
+		     ((eq? term 'error)
+		      '#t)
+		     ((eq? term '#f)
+		      '#f)
+		     ((memq v term)
+		      '#t)
+		     (else
+		      '#f))))
+       vars))
+
+(define (mark-argument-strictness strictness vars)
+  (map (lambda (s v) (setf (var-strict? v) s)) strictness vars))
+
+
+
+;;;======================================================================
+;;; Variable strictness propagation code walk
+;;;======================================================================
+
+;;; Walk the code, marking any vars found in strict contexts as strict.
+;;; Locally bound variables are consed onto the varlist.  This is
+;;; used to determine which variables can be marked as strict when they
+;;; appear in strict contexts.
+;;; When walking something that does not appear in a strict context
+;;; or that is not always evaluated, reinitialize varlist to the empty
+;;; list.
+;;; The stack is used to keep track of variables that have not been
+;;; initialized yet, so that we can detect some kinds of infinite loops.
+;;; When walking something that is not always evaluated, reset this to 
+;;; the empty list.
+
+(define-flic-walker var-strictness-walk (object varlist stack))
+
+
+
+;;; Since the body of the lambda might not be evaluated, reset
+;;; both varlist and stack.
+
+(define-var-strictness-walk flic-lambda (object varlist stack)
+  (declare (ignore varlist stack))
+  (var-strictness-walk (flic-lambda-body object) '() '()))
+
+
+;;; The basic idea for let is to find the variables that are strict in 
+;;; the body first, and propagate that information backwards to the 
+;;; binding initializers.
+
+(define-var-strictness-walk flic-let (object varlist stack)
+  (let ((bindings  (flic-let-bindings object)))
+    (var-strictness-walk-let-aux
+      bindings
+      (flic-let-body object)
+      (append bindings varlist)
+      (append bindings stack)
+      (flic-let-recursive? object))))
+
+(define (var-strictness-walk-let-aux bindings body varlist stack recursive?)
+  (if (null? bindings)
+      (var-strictness-walk body varlist stack)
+      (begin
+	(var-strictness-walk-let-aux
+	  (cdr bindings) body varlist (cdr stack) recursive?)
+	(let* ((var  (car bindings))
+	       (val  (var-value var)))
+	  (cond ((var-strict? var)
+		 ;; Recursive variables have to be set back to unstrict
+		 ;; because the value form might contain forward references.
+		 ;; The box analyzer will set them to strict again if the
+		 ;; value forms are safe.
+		 (when recursive? (setf (var-strict? var) '#f))
+		 ;; Detect x = 1 + x circularities here
+		 (var-strictness-walk val varlist stack))
+		((flic-exp-strict-result? val)
+		 ;; The val is going to be wrapped in a delay.
+		 (var-strictness-walk val '() '()))
+		(else
+		 ;; Watch out for x = x and x = cdr x circularities.
+		 ;; *** I am still a little confused about this.  It
+		 ;; *** seems like the stack should be passed through
+		 ;; *** when walking already-boxed values that appear as
+                 ;; *** non-strict function arguments as well, but doing
+		 ;; *** so generates some apparently bogus complaints
+		 ;; *** about infinite loops.  So maybe doing it here
+		 ;; *** is incorrect too, and we just haven't run across
+		 ;; *** a test case that triggers it???
+		 (var-strictness-walk val '() stack))
+		)))))
+
+
+(define (flic-exp-strict-result? val)
+  (cond ((is-type? 'flic-ref val)
+	 (var-strict? (flic-ref-var val)))
+	((is-type? 'flic-sel val)
+	 (list-ref (con-slot-strict? (flic-sel-con val)) (flic-sel-i val)))
+	(else
+	 '#t)))
+
+(define-var-strictness-walk flic-app (object varlist stack)
+  (let ((fn           (flic-app-fn object))
+	(args         (flic-app-args object))
+	(saturated?   (flic-app-saturated? object)))
+    (cond ((and saturated? (is-type? 'flic-ref fn))
+	   ;; Strictness of function should be stored on var
+	   (do-var-strictness-flic-app-aux
+	     (var-strictness (flic-ref-var fn))
+	     fn args varlist stack))
+	  ((and saturated? (is-type? 'flic-pack fn))
+	   ;; Strictness of constructor should be stored on con
+	   (do-var-strictness-flic-app-aux
+	     (con-slot-strict? (flic-pack-con fn))
+	     fn args varlist stack))
+	  (else
+	   ;; All arguments are non-strict
+	   (var-strictness-walk fn varlist stack)
+	   (dolist (a args)
+	     (var-strictness-walk a '() '()))))))
+
+(define (do-var-strictness-flic-app-aux strictness fn args varlist stack)
+  (when (not strictness)
+    (error "Can't find strictness for function ~s." fn))
+  (dolist (a args)
+    (if (pop strictness)
+	(var-strictness-walk a varlist stack)
+	(var-strictness-walk a '() '()))))
+
+
+(define-var-strictness-walk flic-ref (object varlist stack)
+  (let ((var  (flic-ref-var object)))
+    (cond ((memq var stack)
+	   ;; Circular variable definition detected.
+	   (signal-infinite-loop-variable var)
+	   (setf (var-value var)
+		 (make-infinite-loop-error
+		   (format '#f "Variable ~s has an infinite loop." var))))
+	  ((memq var varlist)
+	   (setf (var-strict? var) '#t))
+	  (else
+	   '#f))))
+
+(define (signal-infinite-loop-variable var)
+  (recoverable-error 'infinite-loop-variable
+    "Variable ~s has an infinite loop."
+    var))
+
+(define-var-strictness-walk flic-const (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+(define-var-strictness-walk flic-pack (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+(define-var-strictness-walk flic-case-block (object varlist stack)
+  (var-strictness-walk (car (flic-case-block-exps object)) varlist stack)
+  (dolist (exp (cdr (flic-case-block-exps object)))
+    (var-strictness-walk exp '() '())))
+
+(define-var-strictness-walk flic-return-from (object varlist stack)
+  (var-strictness-walk (flic-return-from-exp object) varlist stack))
+
+(define-var-strictness-walk flic-and (object varlist stack)
+  (var-strictness-walk (car (flic-and-exps object)) varlist stack)
+  (dolist (exp (cdr (flic-and-exps object)))
+    (var-strictness-walk exp '() '())))
+
+(define-var-strictness-walk flic-if (object varlist stack)
+  (var-strictness-walk (flic-if-test-exp object) varlist stack)
+  (var-strictness-walk (flic-if-then-exp object) '() '())
+  (var-strictness-walk (flic-if-else-exp object) '() '()))
+
+(define-var-strictness-walk flic-sel (object varlist stack)
+  (var-strictness-walk (flic-sel-exp object) varlist stack))
+
+(define-var-strictness-walk flic-is-constructor (object varlist stack)
+  (var-strictness-walk (flic-is-constructor-exp object) varlist stack))
+
+(define-var-strictness-walk flic-con-number (object varlist stack)
+  (var-strictness-walk (flic-con-number-exp object) varlist stack))
+
+(define-var-strictness-walk flic-void (object varlist stack)
+  (declare (ignore object varlist stack))
+  '#f)
+
+
+
+;;;======================================================================
+;;; Printer support
+;;;======================================================================
+
+(define (strictness-analysis-printer big-let)
+  (print-strictness big-let 0))
+
+(define (print-strictness-list list depth)
+  (dolist (o list)
+    (print-strictness o depth)))
+
+(define (print-strictness-indent depth)
+  (dotimes (i (* 2 depth))
+    (declare (ignorable i))
+    (write-char #\space)))
+
+(define (strictness-string bool)
+  (if bool "#t" "#f"))
+
+(define-flic-walker print-strictness (object depth))
+
+(define-print-strictness flic-lambda (object depth)
+  (print-strictness-indent depth)
+  (format '#t "In anonymous function:~%")
+  (print-strictness (flic-lambda-body object) (1+ depth)))
+
+(define-print-strictness flic-let (object depth)
+  (dolist (var (flic-let-bindings object))
+    (let ((val  (var-value var)))
+      (if (is-type? 'flic-lambda val)
+	  (begin
+	    (print-strictness-indent depth)
+	    (format '#t "Function ~s has argument strictness ~a.~%"
+		    var
+		    (map (function strictness-string) (var-strictness var)))
+	    (print-strictness (flic-lambda-body val) (1+ depth)))
+	  (begin
+	    (print-strictness-indent depth)
+	    (format '#t "Variable ~s has strictness ~a.~%"
+		    var
+		    (strictness-string (var-strict? var)))
+	    (print-strictness val depth)))))
+  (print-strictness (flic-let-body object) depth))
+
+(define-print-strictness flic-app (object depth)
+  (print-strictness (flic-app-fn object) depth)
+  (print-strictness-list (flic-app-args object) depth))
+
+(define-print-strictness flic-ref (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-const (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-pack (object depth)
+  (declare (ignore object depth))
+  '#f)
+
+(define-print-strictness flic-case-block (object depth)
+  (print-strictness-list (flic-case-block-exps object) depth))
+
+(define-print-strictness flic-return-from (object depth)
+  (print-strictness (flic-return-from-exp object) depth))
+
+(define-print-strictness flic-and (object depth)
+  (print-strictness-list (flic-and-exps object) depth))
+
+(define-print-strictness flic-if (object depth)
+  (print-strictness (flic-if-test-exp object) depth)
+  (print-strictness (flic-if-then-exp object) depth)
+  (print-strictness (flic-if-else-exp object) depth))
+
+(define-print-strictness flic-sel (object depth)
+  (print-strictness (flic-sel-exp object) depth))
+
+(define-print-strictness flic-is-constructor (object depth)
+  (print-strictness (flic-is-constructor-exp object) depth))
+
+(define-print-strictness flic-con-number (object depth)
+  (print-strictness (flic-con-number-exp object) depth))
+
+(define-print-strictness flic-void (object depth)
+  (declare (ignore object depth))
+  '#f)
+
-- 
cgit v1.2.3