271 lines
7.9 KiB
Common Lisp
271 lines
7.9 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: pca.s
|
||
|
||
; Last Revision: 1-Oct-85 1700ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; David Bartley ;
|
||
; ;
|
||
; Closure Analysis and Heap Allocation ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
;
|
||
; Pass 1
|
||
;
|
||
; Mark lambda expressions to be closed (LAMBDA-CLOSED?=T) at the point
|
||
; of definition whenever any of the following occur:
|
||
;
|
||
; -- the identifier bound to the lambda expression is used as a
|
||
; funarg [p1-id]
|
||
;
|
||
; -- the lambda expression is itself used as a funarg
|
||
; [p1-lambda]
|
||
;
|
||
; -- the identifier bound to the lambda expression is modified
|
||
; by SET! [p1-set!]
|
||
;
|
||
; -- the expression is a MULAMBDA [p1-lambda]
|
||
;
|
||
; Mark all identifiers which are bound to closures by LETREC:
|
||
;
|
||
; -- ID-INIT: the lambda expression the ID was bound to
|
||
; (else it is NIL) [p1-lambda]
|
||
;
|
||
; Pass 2
|
||
;
|
||
; Determine which variables must be heap-allocated by gathering the
|
||
; following facts used later:
|
||
;
|
||
; -- ID-SET!?: it is modified by a SET! [p2-set!]
|
||
;
|
||
; -- ID-FREEREF?: it is freely referenced by some function
|
||
;
|
||
; -- ID-FUNARGSEES?: it is "visible" to a closed function
|
||
;
|
||
; We do not compute the transitive closure of functions reachable from
|
||
; closed functions. Instead, we consider an ID to be funargref'd if
|
||
; (1) ID is freely referenced from SOME function AND (2) ID is visible,
|
||
; though not necessarily referenced, from a closed function.
|
||
;
|
||
; An ID will be heap-allocated if it is potentially referenced from a
|
||
; funarg (both ID-FREEREF? and ID-FUNARGSEES? set non-nil) and must
|
||
; exist at runtime. It exists at runtime if it is modified (ID-SET!?),
|
||
; or is initialized to some value other than a lambda expression
|
||
; (ID-INIT=NIL), or the lambda expression it is bound to is closed.
|
||
;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
|
||
(define pcs-closure-analysis
|
||
(lambda (exp)
|
||
(letrec
|
||
;----!
|
||
(
|
||
(p1-exp
|
||
(lambda (x)
|
||
(case (car x)
|
||
(quote '())
|
||
(T (p1-id x))
|
||
(lambda (p1-lambda x))
|
||
(set! (p1-set! x))
|
||
;; (if (p1-args (cdr x))) treat as a primop
|
||
;; (begin (p1-args (cdr x))) treat as a primop
|
||
(letrec (p1-letrec x))
|
||
(else (p1-application x))
|
||
)))
|
||
|
||
(p1-id
|
||
(lambda (id)
|
||
(close-funarg (id-init id))))
|
||
|
||
(p1-set!
|
||
(lambda (x)
|
||
(p1-id (set!-id x))
|
||
(p1-exp (set!-exp x))))
|
||
|
||
(p1-lambda
|
||
(lambda (x)
|
||
(create-lambda-label x '())
|
||
(close-funarg x)
|
||
(p1-exp (lambda-body x))))
|
||
|
||
(p1-letrec
|
||
(lambda (x)
|
||
(let ((pairs (letrec-pairs x)))
|
||
(p1-pairs-1 pairs) ; link up lambda's and id's
|
||
(p1-pairs-2 pairs) ; find funargref's to id's
|
||
(p1-exp (letrec-body x)))))
|
||
|
||
(p1-pairs-1
|
||
(lambda (pairs)
|
||
(when pairs
|
||
(let* ((pr (car pairs))
|
||
(id (car pr))
|
||
(exp (cadr pr)))
|
||
(when (eq? (car exp) 'lambda)
|
||
(create-lambda-label exp id)
|
||
(set-id-init id exp)
|
||
(when (negative? (lambda-nargs exp))
|
||
(close-funarg exp)))
|
||
(p1-pairs-1 (cdr pairs))))))
|
||
|
||
(p1-pairs-2
|
||
(lambda (pairs)
|
||
(when pairs
|
||
(let* ((pr (car pairs))
|
||
(id (car pr))
|
||
(exp (cadr pr)))
|
||
(if (eq? (car exp) 'lambda)
|
||
(p1-exp (lambda-body exp))
|
||
(p1-exp exp))
|
||
(p1-pairs-2 (cdr pairs))))))
|
||
|
||
(p1-application
|
||
(lambda (x)
|
||
(let ((fn (car x))
|
||
(args (cdr x)))
|
||
(p1-args args)
|
||
(cond ((or (atom? fn)
|
||
(eq? (car fn) 'T))
|
||
'())
|
||
((eq? (car fn) 'LAMBDA)
|
||
(p1-exp (lambda-body fn)))
|
||
(else
|
||
(p1-exp fn))))))
|
||
|
||
(p1-args
|
||
(lambda (args)
|
||
(when args
|
||
(p1-exp (car args))
|
||
(p1-args (cdr args)))))
|
||
|
||
(close-funarg
|
||
(lambda (fn)
|
||
(when fn
|
||
(set-lambda-closed? fn #!true))))
|
||
|
||
(create-lambda-label
|
||
(lambda (fn id)
|
||
(set-lambda-label fn
|
||
(if (null? id)
|
||
(pcs-make-label 'lambda)
|
||
(cons (id-number id)(id-name id))))))
|
||
|
||
;; ------ pass 2 -------
|
||
|
||
(p2-exp
|
||
(lambda (x env locals)
|
||
(case (car x)
|
||
(quote '())
|
||
(T (p2-id x env locals))
|
||
(lambda (p2-lambda x env locals))
|
||
(set! (p2-set! x env locals))
|
||
;; (if (p2-args (cdr x) env locals)) treat as a primop
|
||
;; (begin (p2-args (cdr x) env locals)) treat as a primop
|
||
(letrec (p2-letrec x env locals))
|
||
(else (p2-application x env locals))
|
||
)))
|
||
|
||
(p2-id
|
||
(lambda (id env locals)
|
||
(when (not (memq id locals))
|
||
(set-id-freeref? id #!true))))
|
||
|
||
(p2-set!
|
||
(lambda (x env locals)
|
||
(let ((id (set!-id x))
|
||
(val (set!-exp x)))
|
||
(set-id-set!? id #!true)
|
||
(p2-id id env locals)
|
||
(p2-exp val env locals))))
|
||
|
||
(p2-lambda
|
||
(lambda (x env locals)
|
||
(let ((bvl (lambda-bvl x)))
|
||
(when (lambda-closed? x)
|
||
(do ((env env (cdr env)))
|
||
((null? env))
|
||
(do ((rib (car env)(cdr rib)))
|
||
((null? rib))
|
||
(set-id-funargsees? (car rib) #!true))))
|
||
(p2-exp (lambda-body x)
|
||
(cons bvl env)
|
||
bvl))))
|
||
|
||
(p2-letrec
|
||
(lambda (x env locals)
|
||
(let* ((pairs (letrec-pairs x))
|
||
(bvl (mapcar car pairs))
|
||
(body (letrec-body x))
|
||
(env (cons bvl env))
|
||
(locals (append bvl locals)))
|
||
(p2-pairs pairs env locals)
|
||
(p2-exp body env locals))))
|
||
|
||
(p2-pairs
|
||
(lambda (pairs env locals)
|
||
(when pairs
|
||
(p2-exp (cadr (car pairs)) env locals)
|
||
(p2-pairs (cdr pairs) env locals))))
|
||
|
||
;; p2-application must process IDs in function position
|
||
;; because they may need to be heap allocated; e.g:
|
||
;; (lambda (f)
|
||
;; (lambda (x) ; 'f' must be heap allocated
|
||
;; (f x))) ; 'f' appears only in function position
|
||
|
||
(p2-application
|
||
(lambda (x env locals)
|
||
(let ((fn (car x)))
|
||
(if (or (eq? fn 'THE-ENVIRONMENT)
|
||
(eq? fn '%MAKE-HASHED-ENVIRONMENT))
|
||
(smash-the-environment #!true env)
|
||
(let ((args (cdr x)))
|
||
(when (eq? fn '%CALL/CC)
|
||
(smash-the-environment #!false env))
|
||
(p2-args args env locals)
|
||
(when (pair? fn)
|
||
(if (eq? (car fn) 'LAMBDA)
|
||
(p2-exp (lambda-body fn)
|
||
(cons (lambda-bvl fn) env)
|
||
(lambda-bvl fn))
|
||
(p2-exp fn env locals))))))))
|
||
|
||
;; (THE-ENVIRONMENT) requires all visible lexical variables
|
||
;; to be heap-allocated
|
||
|
||
(smash-the-environment
|
||
(lambda (smash-all? env)
|
||
(when env
|
||
(do ((rib (car env) ; CDR down this rib
|
||
(cdr rib)))
|
||
((null? rib))
|
||
(let ((id (car rib))
|
||
(yes #!true))
|
||
(set-id-funargsees? id yes)
|
||
(set-id-freeref? id yes)
|
||
(when smash-all?
|
||
(set-id-set!? id yes)
|
||
(close-funarg (id-init id)))))
|
||
(smash-the-environment smash-all? (cdr env))))) ; get the next rib
|
||
|
||
(p2-args
|
||
(lambda (args env locals)
|
||
(when args
|
||
(p2-exp (car args) env locals)
|
||
(p2-args (cdr args) env locals))))
|
||
|
||
;----!
|
||
)
|
||
(begin
|
||
(p1-exp exp)
|
||
(p2-exp exp '() '())
|
||
'())))) ; executed for effect only
|
||
|
||
|
||
;==================================================================
|
||
|