271 lines
7.9 KiB
ArmAsm
271 lines
7.9 KiB
ArmAsm
|
|
|||
|
; -*- 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
|
|||
|
|
|||
|
|
|||
|
;==================================================================
|
|||
|
|