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