| 4e987026 |
;;; ast-to-flic.scm -- convert AST to flic structures.
;;;
;;; author : Sandra Loosemore
;;; date : 3 Apr 1992
;;;
;;;
;;; ====================================================================
;;; Support
;;; ====================================================================
(define-walker ast-to-flic ast-td-ast-to-flic-walker)
(define-local-syntax (define-ast-to-flic ast-type lambda-list . body)
`(define-walker-method ast-to-flic ,ast-type ,lambda-list ,@body))
(define (ast-to-flic big-let)
(ast-to-flic-let-aux (let-decls big-let) (make-flic-void) '#t))
(define (ast-to-flic-1 ast-node)
(call-walker ast-to-flic ast-node))
(define (ast-to-flic/list l)
(map (function ast-to-flic-1) l))
(define (init-flic-var var value toplevel?)
(setf (var-value var) value)
(setf (var-toplevel? var) toplevel?)
(setf (var-simple? var)
(and value
(or (is-type? 'flic-const value)
(is-type? 'flic-pack value))))
(setf (var-strict? var) '#f)
;; Remember the strictness annotation.
(let ((strictness-ann (lookup-annotation var '|Strictness|)))
(setf (var-strictness var)
(if strictness-ann
(adjust-annotated-strictness var
(parse-strictness (car (annotation-value-args strictness-ann))))
'#f)))
;; If the variable has an inline annotation, rewrite its value
;; from var = value
;; to var = let temp = value in temp
;; (Necessary for inlining recursive definitions.)
(let ((inline-ann (lookup-annotation var '|Inline|)))
(when inline-ann
(setf (var-force-inline? var) '#t)
(setf (var-value var) (wrap-with-let var value))))
var)
(define (wrap-with-let var value)
(let ((temp (copy-temp-var (def-name var))))
(init-flic-var temp (copy-flic value (list (cons var temp))) '#f)
(make-flic-let (list temp) (make-flic-ref temp) '#t)))
;;; ====================================================================
;;; ast expression structs
;;; ====================================================================
(define-ast-to-flic lambda (object)
(make-flic-lambda
(map (lambda (pat)
(init-flic-var
(cond ((var-pat? pat)
(var-ref-var (var-pat-var pat)))
(else
(error "Bad lambda pattern: ~s." pat)))
'#f
'#f))
(lambda-pats object))
(ast-to-flic-1 (lambda-body object))))
;;; For LET, the CFN has turned all of the definitions into
;;; simple assignments to a variable. The dependency analyzer
;;; adds recursive-decl-groups for things which need to be bound
;;; with LETREC.
(define-ast-to-flic let (object)
(ast-to-flic-let-aux
(let-decls object)
(ast-to-flic-1 (let-body object))
'#f))
(define (ast-to-flic-let-aux decls body toplevel?)
(multiple-value-bind (bindings newbody)
(ast-to-flic-bindings decls body toplevel?)
(if (null? bindings)
newbody
(make-flic-let bindings newbody toplevel?))))
(define (ast-to-flic-bindings decls body toplevel?)
(if (null? decls)
(values '() body)
(multiple-value-bind (bindings newbody)
(ast-to-flic-bindings (cdr decls) body toplevel?)
(cond ((is-type? 'valdef (car decls))
;; Continue collecting bindings.
(let* ((decl (car decls))
(pat (valdef-lhs decl))
(exp (single-definition-rhs decl)))
(values
(cond ((var-pat? pat)
(cons
(init-flic-var
(var-ref-var (var-pat-var pat))
(ast-to-flic-1 exp)
toplevel?)
bindings))
(else
(error "Definition has invalid pattern: ~s." decl)))
newbody)))
((not (is-type? 'recursive-decl-group (car decls)))
(error "Decl has weird value: ~s." (car decls)))
(toplevel?
;; We don't do any of this mess with top level bindings.
;; Turn it into one big letrec.
(multiple-value-bind (more-bindings newerbody)
(ast-to-flic-bindings
(recursive-decl-group-decls (car decls))
newbody
toplevel?)
(values (nconc more-bindings bindings)
newerbody)))
(else
;; Otherwise, turn remaining bindings into a nested
;; let or letrec, and put that in the body of a new
;; letrec.
(multiple-value-bind (more-bindings newerbody)
(ast-to-flic-bindings
(recursive-decl-group-decls (car decls))
(if (null? bindings)
newbody
(make-flic-let bindings newbody '#f))
toplevel?)
(values
'()
(if (null? more-bindings)
newerbody
(make-flic-let more-bindings newerbody '#t)))))
))))
(define (single-definition-rhs decl)
(let* ((def-list (valdef-definitions decl))
(def (car def-list))
(rhs-list (single-fun-def-rhs-list def))
(rhs (car rhs-list)))
;; All of this error checking could be omitted for efficiency, since
;; none of these conditions are supposed to happen anyway.
(cond ((not (null? (cdr def-list)))
(error "Decl has multiple definitions: ~s." decl))
((not (null? (single-fun-def-where-decls def)))
(error "Definition has non-null where-decls list: ~s." decl))
((not (null? (cdr rhs-list)))
(error "Definition has multiple right-hand-sides: ~s." decl))
((not (is-type? 'omitted-guard (guarded-rhs-guard rhs)))
(error "Definition has a guard: ~s." decl)))
(guarded-rhs-rhs rhs)))
;;; These are all straightforward translations.
(define-ast-to-flic if (object)
(make-flic-if
(ast-to-flic-1 (if-test-exp object))
(ast-to-flic-1 (if-then-exp object))
(ast-to-flic-1 (if-else-exp object))))
(define-ast-to-flic case-block (object)
(make-flic-case-block
(case-block-block-name object)
(ast-to-flic/list (case-block-exps object))))
(define-ast-to-flic return-from (object)
(make-flic-return-from
(return-from-block-name object)
(ast-to-flic-1 (return-from-exp object))))
(define-ast-to-flic and-exp (object)
(make-flic-and (ast-to-flic/list (and-exp-exps object))))
;;; Applications. Uncurry here. It's more convenient to do the
;;; optimizer on fully uncurried applications. After the optimizer
;;; has run, all applications are adjusted based on observed arity
;;; of the functions and the saturated? flag is set correctly.
(define-ast-to-flic app (object)
(ast-to-flic-app-aux object '()))
(define (ast-to-flic-app-aux object args)
(if (is-type? 'app object)
(ast-to-flic-app-aux
(app-fn object)
(cons (ast-to-flic-1 (app-arg object)) args))
(make-flic-app (ast-to-flic-1 object) args '#f)))
;;; References
(define-ast-to-flic var-ref (object)
(make-flic-ref (var-ref-var object)))
(define-ast-to-flic con-ref (object)
(make-flic-pack (con-ref-con object)))
;;; Constants
(define-ast-to-flic integer-const (object)
(make-flic-const (integer-const-value object)))
;;; We should probably add a type field to flic-const but at the moment
;;; I'll force the value to be a list of numerator, denominator.
(define-ast-to-flic float-const (object)
(let ((e (float-const-exponent object))
(n (float-const-numerator object))
(d (float-const-denominator object)))
(make-flic-const
(if (> e 0)
(list (* n (expt 10 e)) d)
(list n (* d (expt 10 (- e))))))))
(define-ast-to-flic char-const (object)
(make-flic-const (char-const-value object)))
(define-ast-to-flic string-const (object)
(let ((value (string-const-value object)))
(if (equal? value "")
(make-flic-pack (core-symbol "Nil"))
(make-flic-const value))))
;;; Random stuff
(define-ast-to-flic con-number (object)
(make-flic-con-number
(con-number-type object)
(ast-to-flic-1 (con-number-value object))))
(define-ast-to-flic sel (object)
(make-flic-sel
(sel-constructor object)
(sel-slot object)
(ast-to-flic-1 (sel-value object))))
(define-ast-to-flic is-constructor (object)
(make-flic-is-constructor
(is-constructor-constructor object)
(ast-to-flic-1 (is-constructor-value object))))
(define-ast-to-flic void (object)
(declare (ignore object))
(make-flic-void))
;;; This hack make strictness annotations work. It adds #t's which correspond
;;; to the strictness of the dict params.
(define (adjust-annotated-strictness v s)
(let* ((ty (var-type v))
(c (gtype-context ty)))
(dolist (c1 c)
(dolist (c2 c1)
(declare (ignorable c2))
(push '#t s)))
s))
|