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