724 lines
22 KiB
Scheme
724 lines
22 KiB
Scheme
|
|
||
|
|
; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
|
||
|
|
|
||
|
|
; This file contains miscellaneous utilities for accessing and modifying the
|
||
|
|
; node tree.
|
||
|
|
|
||
|
|
; Get the root of the tree containing node.
|
||
|
|
|
||
|
|
(define (node-base node)
|
||
|
|
(do ((p node (node-parent p)))
|
||
|
|
((not (node? (node-parent p)))
|
||
|
|
p)))
|
||
|
|
|
||
|
|
; Find the procedure node that contains NODE. Go up one parent at a time
|
||
|
|
; until a lambda node is found, then go up two at a time, skipping the
|
||
|
|
; intervening call nodes.
|
||
|
|
|
||
|
|
(define (containing-procedure node)
|
||
|
|
(do ((node (node-parent node) (node-parent node)))
|
||
|
|
((lambda-node? node)
|
||
|
|
(do ((node node (node-parent (node-parent node))))
|
||
|
|
((proc-lambda? node) node)))))
|
||
|
|
|
||
|
|
; Trivial calls are those whose parents are call nodes.
|
||
|
|
|
||
|
|
(define (trivial? call)
|
||
|
|
(call-node? (node-parent call)))
|
||
|
|
|
||
|
|
(define (nontrivial? call)
|
||
|
|
(lambda-node? (node-parent call)))
|
||
|
|
|
||
|
|
(define (nontrivial-ancestor call)
|
||
|
|
(let loop ((call call))
|
||
|
|
(if (or (not (node? (node-parent call)))
|
||
|
|
(nontrivial? call))
|
||
|
|
call
|
||
|
|
(loop (node-parent call)))))
|
||
|
|
|
||
|
|
(define (calls-this-primop? call id)
|
||
|
|
(eq? id (primop-id (call-primop call))))
|
||
|
|
|
||
|
|
; Return the variable to which a value is bound by LET or LETREC.
|
||
|
|
|
||
|
|
(define (bound-to-variable node)
|
||
|
|
(let ((parent (node-parent node)))
|
||
|
|
(case (primop-id (call-primop parent))
|
||
|
|
((let)
|
||
|
|
(if (n= 0 (node-index node))
|
||
|
|
(list-ref (lambda-variables (call-arg parent 0))
|
||
|
|
(- (node-index node) 1))
|
||
|
|
#f))
|
||
|
|
((letrec2)
|
||
|
|
(if (< 1 (node-index node))
|
||
|
|
(list-ref (lambda-variables
|
||
|
|
(variable-binder
|
||
|
|
(reference-variable (call-arg parent 1))))
|
||
|
|
(- (node-index node) 1))
|
||
|
|
#f))
|
||
|
|
(else #f))))
|
||
|
|
|
||
|
|
; Return a list of all the reference to lambda-node L's value that call it.
|
||
|
|
; If not all can be identified then #F is returned.
|
||
|
|
|
||
|
|
(define (find-calls l)
|
||
|
|
(let ((refs (cond ((bound-to-variable l)
|
||
|
|
=> variable-refs)
|
||
|
|
((called-node? l)
|
||
|
|
(list l))
|
||
|
|
(else
|
||
|
|
#f))))
|
||
|
|
(cond ((and refs (every? called-node? refs))
|
||
|
|
refs)
|
||
|
|
((calls-known? l)
|
||
|
|
(bug "cannot find calls for known lambda ~S" l))
|
||
|
|
(else #f))))
|
||
|
|
|
||
|
|
; Walk (or map) a tree-modifying procedure down a variable's references.
|
||
|
|
|
||
|
|
(define (walk-refs-safely proc var)
|
||
|
|
(for-each proc (copy-list (variable-refs var))))
|
||
|
|
|
||
|
|
; Return #t if the total primop-cost of NODE is less than SIZE.
|
||
|
|
|
||
|
|
(define (small-node? node size)
|
||
|
|
(let label ((call (lambda-body node)))
|
||
|
|
(set! size (- size (primop-cost call)))
|
||
|
|
(if (>= size 0)
|
||
|
|
(walk-vector (lambda (n)
|
||
|
|
(cond ((lambda-node? n)
|
||
|
|
(label (lambda-body n)))
|
||
|
|
((call-node? n)
|
||
|
|
(label n))))
|
||
|
|
(call-args call))))
|
||
|
|
(>= size 0))
|
||
|
|
|
||
|
|
; True if executing NODE involves side-effects.
|
||
|
|
|
||
|
|
(define (side-effects? node . permissable)
|
||
|
|
(let ((permissable (cons #f permissable)))
|
||
|
|
(let label ((node node))
|
||
|
|
(cond ((not (call-node? node))
|
||
|
|
#f)
|
||
|
|
((or (n= 0 (call-exits node))
|
||
|
|
(not (memq (primop-side-effects (call-primop node))
|
||
|
|
permissable)))
|
||
|
|
#t)
|
||
|
|
(else
|
||
|
|
(let loop ((i (- (call-arg-count node) 1)))
|
||
|
|
(cond ((< i 0) #f)
|
||
|
|
((label (call-arg node i)) #t)
|
||
|
|
(else (loop (- i 1))))))))))
|
||
|
|
|
||
|
|
; A conservative check - is there only one SET-CONTENTS call for the owner and
|
||
|
|
; are all calls between CALL and the LETREC call that binds the owner calls to
|
||
|
|
; SET-CONTENTS?
|
||
|
|
|
||
|
|
;(define (single-letrec-set? call)
|
||
|
|
; (let ((owner (call-arg call set/owner)))
|
||
|
|
; (and (reference-node? owner)
|
||
|
|
; (every? (lambda (ref)
|
||
|
|
; (or (eq? (node-parent ref) call)
|
||
|
|
; (not (set-reference? ref))))
|
||
|
|
; (variable-refs (reference-variable owner))))))
|
||
|
|
|
||
|
|
;(define (set-reference? node)
|
||
|
|
; (and (eq? 'set-contents
|
||
|
|
; (primop-id (call-primop (node-parent node))))
|
||
|
|
; (= (node-index node) set/owner)))
|
||
|
|
|
||
|
|
;-------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define the-undefined-value (list '*undefined-value*))
|
||
|
|
|
||
|
|
(define (undefined-value? x)
|
||
|
|
(eq? x the-undefined-value))
|
||
|
|
|
||
|
|
(define (undefined-value-node? x)
|
||
|
|
(and (literal-node? x)
|
||
|
|
(undefined-value? (literal-value x))))
|
||
|
|
|
||
|
|
(define (make-undefined-literal)
|
||
|
|
(make-literal-node the-undefined-value #f))
|
||
|
|
|
||
|
|
;-------------------------------------------------------------------------------
|
||
|
|
; Finding the lambda node called by CALL, JUMP, or RETURN
|
||
|
|
|
||
|
|
(define (called-node? node)
|
||
|
|
(and (node? (node-parent node))
|
||
|
|
(eq? node (called-node (node-parent node)))))
|
||
|
|
|
||
|
|
(define (called-node call)
|
||
|
|
(cond ((and (primop-procedure? (call-primop call))
|
||
|
|
(primop-call-index (call-primop call)))
|
||
|
|
=> (lambda (i)
|
||
|
|
(call-arg call i)))
|
||
|
|
(else '#f)))
|
||
|
|
|
||
|
|
(define (called-lambda call)
|
||
|
|
(get-lambda-value (call-arg call (primop-call-index (call-primop call)))))
|
||
|
|
|
||
|
|
(define (get-lambda-value value)
|
||
|
|
(cond ((lambda-node? value)
|
||
|
|
value)
|
||
|
|
((reference-node? value)
|
||
|
|
(get-variable-lambda (reference-variable value)))
|
||
|
|
(else
|
||
|
|
(error "peculiar procedure in ~S" value))))
|
||
|
|
|
||
|
|
(define (get-variable-lambda variable)
|
||
|
|
(if (global-variable? variable)
|
||
|
|
(or (variable-known-lambda variable)
|
||
|
|
(error "peculiar procedure variable ~S" variable))
|
||
|
|
(let* ((binder (variable-binder variable))
|
||
|
|
(index (node-index binder))
|
||
|
|
(call (node-parent binder))
|
||
|
|
(lose (lambda ()
|
||
|
|
(error "peculiar procedure variable ~S" variable))))
|
||
|
|
(case (primop-id (call-primop call))
|
||
|
|
((let)
|
||
|
|
(if (= 0 index)
|
||
|
|
(get-lambda-value (call-arg call (+ 1 (variable-index variable))))
|
||
|
|
(lose)))
|
||
|
|
((letrec1)
|
||
|
|
(if (= 0 index)
|
||
|
|
(get-letrec-variable-lambda variable)
|
||
|
|
(lose)))
|
||
|
|
((call)
|
||
|
|
(if (and (= 1 index)
|
||
|
|
(= 0 (variable-index variable))) ; var is a continuation var
|
||
|
|
(get-lambda-value (call-arg call 0))
|
||
|
|
(lose)))
|
||
|
|
(else
|
||
|
|
(lose))))))
|
||
|
|
|
||
|
|
; Some of the checking can be removed once I know the LETREC code works.
|
||
|
|
|
||
|
|
(define (get-letrec-variable-lambda variable)
|
||
|
|
(let* ((binder (variable-binder variable))
|
||
|
|
(call (lambda-body binder)))
|
||
|
|
(if (and (eq? 'letrec2 (primop-id (call-primop call)))
|
||
|
|
(reference-node? (call-arg call 1))
|
||
|
|
(eq? (car (lambda-variables binder))
|
||
|
|
(reference-variable (call-arg call 1))))
|
||
|
|
(call-arg call (+ 1 (variable-index variable)))
|
||
|
|
(error "LETREC is incorrectly organized ~S" (node-parent binder)))))
|
||
|
|
|
||
|
|
;(define (get-cell-variable-lambda variable)
|
||
|
|
; (let ((ref (first set-reference? (variable-refs variable))))
|
||
|
|
; (if (and ref
|
||
|
|
; (eq? 'letrec
|
||
|
|
; (literal-value (call-arg (node-parent ref) set/type))))
|
||
|
|
; (get-lambda-value (call-arg (node-parent ref) set/value))
|
||
|
|
; (error "peculiar lambda cell ~S" variable))))
|
||
|
|
|
||
|
|
;-------------------------------------------------------------------------------
|
||
|
|
; Attaching and detaching arguments to calls
|
||
|
|
|
||
|
|
; Make ARGS the arguments of call node PARENT. ARGS may contain #f.
|
||
|
|
|
||
|
|
(define (attach-call-args parent args)
|
||
|
|
(let ((len (call-arg-count parent)))
|
||
|
|
(let loop ((args args) (i 0))
|
||
|
|
(cond ((null? args)
|
||
|
|
(if (< i (- len 1))
|
||
|
|
(bug '"too few arguments added to node ~S" parent))
|
||
|
|
(values))
|
||
|
|
((>= i len)
|
||
|
|
(bug '"too many arguments added to node ~S" parent))
|
||
|
|
(else
|
||
|
|
(if (car args)
|
||
|
|
(attach parent i (car args)))
|
||
|
|
(loop (cdr args) (+ 1 i)))))))
|
||
|
|
|
||
|
|
; Remove all of the arguments of NODE.
|
||
|
|
|
||
|
|
(define (remove-call-args node)
|
||
|
|
(let ((len (call-arg-count node)))
|
||
|
|
(do ((i 1 (+ i 1)))
|
||
|
|
((>= i len))
|
||
|
|
(if (not (empty? (call-arg node i)))
|
||
|
|
(erase (detach (call-arg node i)))))
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
; Replace the arguments of call node NODE with NEW-ARGS.
|
||
|
|
|
||
|
|
(define (replace-call-args node new-args)
|
||
|
|
(let ((len (length new-args)))
|
||
|
|
(remove-call-args node)
|
||
|
|
(if (n= len (call-arg-count node))
|
||
|
|
(let ((new (make-vector len empty))
|
||
|
|
(old (call-args node)))
|
||
|
|
(set-call-args! node new)))
|
||
|
|
(attach-call-args node new-args)))
|
||
|
|
|
||
|
|
; Remove all arguments to CALL that are EMPTY?. COUNT is the number of
|
||
|
|
; non-EMPTY? arguments.
|
||
|
|
|
||
|
|
(define (remove-null-arguments call count)
|
||
|
|
(let ((old (call-args call))
|
||
|
|
(new (make-vector count empty)))
|
||
|
|
(let loop ((i 0) (j 0))
|
||
|
|
(cond ((>= j count)
|
||
|
|
(values))
|
||
|
|
((not (empty? (vector-ref old i)))
|
||
|
|
(set-node-index! (vector-ref old i) j)
|
||
|
|
(vector-set! new j (vector-ref old i))
|
||
|
|
(loop (+ i 1) (+ j 1)))
|
||
|
|
(else
|
||
|
|
(loop (+ i 1) j))))
|
||
|
|
(set-call-args! call new)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
; Remove all but the first COUNT arguments from CALL.
|
||
|
|
|
||
|
|
(define (shorten-call-args call count)
|
||
|
|
(let ((old (call-args call))
|
||
|
|
(new (make-vector count empty)))
|
||
|
|
(vector-replace new old count)
|
||
|
|
(do ((i (+ count 1) (+ i 1)))
|
||
|
|
((>= i (vector-length old)))
|
||
|
|
(erase (vector-ref old i)))
|
||
|
|
(set-call-args! call new)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
; Insert ARG as the INDEXth argument to CALL.
|
||
|
|
|
||
|
|
(define (insert-call-arg call index arg)
|
||
|
|
(let* ((old (call-args call))
|
||
|
|
(len (vector-length old))
|
||
|
|
(new (make-vector (+ 1 len) empty)))
|
||
|
|
(vector-replace new old index)
|
||
|
|
(do ((i index (+ i 1)))
|
||
|
|
((>= i len))
|
||
|
|
(vector-set! new (+ i 1) (vector-ref old i))
|
||
|
|
(set-node-index! (vector-ref old i) (+ i 1)))
|
||
|
|
(set-call-args! call new)
|
||
|
|
(attach call index arg)
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
; Remove the INDEXth argument to CALL.
|
||
|
|
|
||
|
|
(define (remove-call-arg call index)
|
||
|
|
(let* ((old (call-args call))
|
||
|
|
(len (- (vector-length old) 1))
|
||
|
|
(new (make-vector len)))
|
||
|
|
(vector-replace new old index)
|
||
|
|
(if (node? (vector-ref old index))
|
||
|
|
(erase (detach (vector-ref old index))))
|
||
|
|
(do ((i index (+ i 1)))
|
||
|
|
((>= i len))
|
||
|
|
(vector-set! new i (vector-ref old (+ i 1)))
|
||
|
|
(set-node-index! (vector-ref new i) i))
|
||
|
|
(set-call-args! call new)
|
||
|
|
(if (< index (call-exits call))
|
||
|
|
(set-call-exits! call (- (call-exits call) 1)))
|
||
|
|
(values)))
|
||
|
|
|
||
|
|
; Add ARG to the end of CALL's arguments.
|
||
|
|
|
||
|
|
(define (append-call-arg call arg)
|
||
|
|
(insert-call-arg call (call-arg-count call) arg))
|
||
|
|
|
||
|
|
; Replace CALL with the body of its continuation.
|
||
|
|
|
||
|
|
(define (remove-body call)
|
||
|
|
(if (n= 1 (call-exits call))
|
||
|
|
(bug "removing a call with ~D exits" (call-exits call))
|
||
|
|
(replace-body call (detach-body (lambda-body (call-arg call 0))))))
|
||
|
|
|
||
|
|
; Avoiding N-Ary Procedures
|
||
|
|
; These are used in the expansion of the LET-NODES macro.
|
||
|
|
|
||
|
|
(define (attach-two-call-args node a0 a1)
|
||
|
|
(attach node 0 a0)
|
||
|
|
(attach node 1 a1))
|
||
|
|
|
||
|
|
(define (attach-three-call-args node a0 a1 a2)
|
||
|
|
(attach node 0 a0)
|
||
|
|
(attach node 1 a1)
|
||
|
|
(attach node 2 a2))
|
||
|
|
|
||
|
|
(define (attach-four-call-args node a0 a1 a2 a3)
|
||
|
|
(attach node 0 a0)
|
||
|
|
(attach node 1 a1)
|
||
|
|
(attach node 2 a2)
|
||
|
|
(attach node 3 a3))
|
||
|
|
|
||
|
|
(define (attach-five-call-args node a0 a1 a2 a3 a4)
|
||
|
|
(attach node 0 a0)
|
||
|
|
(attach node 1 a1)
|
||
|
|
(attach node 2 a2)
|
||
|
|
(attach node 3 a3)
|
||
|
|
(attach node 4 a4))
|
||
|
|
|
||
|
|
;-------------------------------------------------------------------------------
|
||
|
|
; Bind VARS to VALUES using letrec at CALL. If CALL is already a letrec
|
||
|
|
; call, just add to it, otherwise make a new one.
|
||
|
|
|
||
|
|
(define (put-in-letrec vars values call)
|
||
|
|
(cond ((eq? 'letrec2 (primop-id (call-primop call)))
|
||
|
|
(let ((binder (node-parent call)))
|
||
|
|
(mark-changed call)
|
||
|
|
(for-each (lambda (var)
|
||
|
|
(set-variable-binder! var binder))
|
||
|
|
vars)
|
||
|
|
(set-lambda-variables! binder
|
||
|
|
(append (lambda-variables binder) vars))
|
||
|
|
(for-each (lambda (value)
|
||
|
|
(append-call-arg call value))
|
||
|
|
values)))
|
||
|
|
(else
|
||
|
|
(move-body
|
||
|
|
call
|
||
|
|
(lambda (call)
|
||
|
|
(let-nodes ((c (letrec1 1 l2))
|
||
|
|
(l2 ((x #f) . vars) (letrec2 1 l3 (* x) . values))
|
||
|
|
(l3 () call))
|
||
|
|
c))))))
|
||
|
|
|
||
|
|
;-------------------------------------------------------------------------------
|
||
|
|
; Changing lambda-nodes' variable lists
|
||
|
|
|
||
|
|
(define (remove-lambda-variable l-node index)
|
||
|
|
(remove-variable l-node (list-ref (lambda-variables l-node) index)))
|
||
|
|
|
||
|
|
(define (remove-variable l-node var)
|
||
|
|
(if (used? var)
|
||
|
|
(bug '"cannot remove referenced variable ~s" var))
|
||
|
|
(erase-variable var)
|
||
|
|
(let ((vars (lambda-variables l-node)))
|
||
|
|
(if (eq? (car vars) var)
|
||
|
|
(set-lambda-variables! l-node (cdr vars))
|
||
|
|
(do ((vars vars (cdr vars)))
|
||
|
|
((eq? (cadr vars) var)
|
||
|
|
(set-cdr! vars (cddr vars)))))))
|
||
|
|
|
||
|
|
; Remove all of L-NODES' unused variables.
|
||
|
|
|
||
|
|
(define (remove-unused-variables l-node)
|
||
|
|
(set-lambda-variables! l-node
|
||
|
|
(filter! (lambda (v)
|
||
|
|
(cond ((used? v)
|
||
|
|
#t)
|
||
|
|
(else
|
||
|
|
(erase-variable v)
|
||
|
|
#f)))
|
||
|
|
(lambda-variables l-node))))
|
||
|
|
|
||
|
|
;------------------------------------------------------------------------------
|
||
|
|
; Substituting Values For Variables
|
||
|
|
|
||
|
|
; Substitute VAL for VAR. If DETACH? is true then VAL should be detached
|
||
|
|
; and so can be used instead of a copy for the first substitution.
|
||
|
|
;
|
||
|
|
; If VAL is a reference to a variable named V, it was probably introduced by
|
||
|
|
; the CPS conversion code. In that case, the variable is renamed with the
|
||
|
|
; name of VAR. This helps considerably when debugging the compiler.
|
||
|
|
|
||
|
|
(define (substitute var val detach?)
|
||
|
|
(if (and (reference-node? val)
|
||
|
|
(eq? 'v (variable-name (reference-variable val)))
|
||
|
|
(not (global-variable? (reference-variable val))))
|
||
|
|
(set-variable-name! (reference-variable val)
|
||
|
|
(variable-name var)))
|
||
|
|
(let ((refs (variable-refs var)))
|
||
|
|
(set-variable-refs! var '())
|
||
|
|
(cond ((not (null? refs))
|
||
|
|
(for-each (lambda (ref)
|
||
|
|
(replace ref (copy-node-tree val)))
|
||
|
|
(if detach? (cdr refs) refs))
|
||
|
|
(if detach? (replace (car refs) (detach val))))
|
||
|
|
(detach?
|
||
|
|
(erase (detach val))))))
|
||
|
|
|
||
|
|
; Walk the tree NODE replacing references to variables in OLD-VARS with
|
||
|
|
; the corresponding variables in NEW-VARS. Uses VARIABLE-FLAG to mark
|
||
|
|
; the variables being replaced.
|
||
|
|
|
||
|
|
(define (substitute-vars-in-node-tree node old-vars new-vars)
|
||
|
|
(for-each (lambda (old new)
|
||
|
|
(set-variable-flag! old new))
|
||
|
|
old-vars
|
||
|
|
new-vars)
|
||
|
|
(let tree-walk ((node node))
|
||
|
|
(cond ((lambda-node? node)
|
||
|
|
(walk-vector tree-walk (call-args (lambda-body node))))
|
||
|
|
((call-node? node)
|
||
|
|
(walk-vector tree-walk (call-args node)))
|
||
|
|
((and (reference-node? node)
|
||
|
|
(variable-flag (reference-variable node)))
|
||
|
|
=> (lambda (new)
|
||
|
|
(replace node (make-reference-node new))))))
|
||
|
|
(for-each (lambda (old)
|
||
|
|
(set-variable-flag! old #f))
|
||
|
|
old-vars))
|
||
|
|
|
||
|
|
; Replaces the call node CALL with VALUE.
|
||
|
|
; (<proc> <exit> . <args>) => (<exit> <value>)
|
||
|
|
|
||
|
|
(define (replace-call-with-value call value)
|
||
|
|
(cond ((n= 1 (call-exits call))
|
||
|
|
(bug '"can only substitute for call with one exit ~s" call))
|
||
|
|
(else
|
||
|
|
(let ((cont (detach (call-arg call 0))))
|
||
|
|
(set-call-exits! call 0)
|
||
|
|
(replace-call-args call (if value (list cont value) (list cont)))
|
||
|
|
(set-call-primop! call (get-primop (enum primop let)))))))
|
||
|
|
|
||
|
|
;------------------------------------------------------------------------------
|
||
|
|
; Copying Node Trees
|
||
|
|
|
||
|
|
; Copy the node-tree NODE. This dispatches on the type of NODE.
|
||
|
|
; Variables which have been copied have the copy in the node-flag field.
|
||
|
|
|
||
|
|
(define (copy-node-tree node)
|
||
|
|
(let ((new (cond ((lambda-node? node)
|
||
|
|
(copy-lambda node))
|
||
|
|
((reference-node? node)
|
||
|
|
(let ((var (reference-variable node)))
|
||
|
|
(cond ((and (variable-binder var)
|
||
|
|
(variable-flag var))
|
||
|
|
=> make-reference-node)
|
||
|
|
(else
|
||
|
|
(make-reference-node var)))))
|
||
|
|
((call-node? node)
|
||
|
|
(copy-call node))
|
||
|
|
((literal-node? node)
|
||
|
|
(copy-literal-node node)))))
|
||
|
|
new))
|
||
|
|
|
||
|
|
; Copy a lambda node and its variables. The variables' copies are put in
|
||
|
|
; their VARIABLE-FLAG while the lambda's body is being copied.
|
||
|
|
|
||
|
|
(define (copy-lambda node)
|
||
|
|
(let* ((vars (map (lambda (var)
|
||
|
|
(if var
|
||
|
|
(let ((new (copy-variable var)))
|
||
|
|
(set-variable-flag! var new)
|
||
|
|
new)
|
||
|
|
#f))
|
||
|
|
(lambda-variables node)))
|
||
|
|
(new-node (make-lambda-node (lambda-name node)
|
||
|
|
(lambda-type node)
|
||
|
|
vars)))
|
||
|
|
(attach-body new-node (copy-call (lambda-body node)))
|
||
|
|
(set-lambda-protocol! new-node (lambda-protocol node))
|
||
|
|
(set-lambda-source! new-node (lambda-source node))
|
||
|
|
(for-each (lambda (var)
|
||
|
|
(if var (set-variable-flag! var #f)))
|
||
|
|
(lambda-variables node))
|
||
|
|
new-node))
|
||
|
|
|
||
|
|
(define (copy-call node)
|
||
|
|
(let ((new-node (make-call-node (call-primop node)
|
||
|
|
(call-arg-count node)
|
||
|
|
(call-exits node))))
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((>= i (call-arg-count node)))
|
||
|
|
(attach new-node i (copy-node-tree (call-arg node i))))
|
||
|
|
(set-call-source! new-node (call-source node))
|
||
|
|
new-node))
|
||
|
|
|
||
|
|
;------------------------------------------------------------------------------
|
||
|
|
; Checking the scoping of identifers
|
||
|
|
|
||
|
|
; Mark all ancestors of N with FLAG
|
||
|
|
|
||
|
|
(define (mark-ancestors n flag)
|
||
|
|
(do ((n n (node-parent n)))
|
||
|
|
((not (node? n)) (values))
|
||
|
|
(set-node-flag! n flag)))
|
||
|
|
|
||
|
|
; Does N have an ancestor with a non-#f flag?
|
||
|
|
|
||
|
|
(define (marked-ancestor? n)
|
||
|
|
(do ((n n (node-parent n)))
|
||
|
|
((or (not (node? n))
|
||
|
|
(node-flag n))
|
||
|
|
(node? n))))
|
||
|
|
|
||
|
|
; Does N have an ancestor with a #f flag?
|
||
|
|
|
||
|
|
(define (unmarked-ancestor? n)
|
||
|
|
(do ((n n (node-parent n)))
|
||
|
|
((or (not (node? n))
|
||
|
|
(not (node-flag n)))
|
||
|
|
(node? n))))
|
||
|
|
|
||
|
|
; Is ANC? an ancestor of NODE?
|
||
|
|
|
||
|
|
(define (node-ancestor? anc? node)
|
||
|
|
(set-node-flag! anc? #t)
|
||
|
|
(let ((okay? (marked-ancestor? node)))
|
||
|
|
(set-node-flag! anc? #f)
|
||
|
|
okay?))
|
||
|
|
|
||
|
|
; Find the lowest ancestor of N that has a non-#f flag
|
||
|
|
|
||
|
|
(define (marked-ancestor n)
|
||
|
|
(do ((n n (node-parent n)))
|
||
|
|
((or (not (node? n))
|
||
|
|
(node-flag n))
|
||
|
|
(if (node? n) n #f))))
|
||
|
|
|
||
|
|
; Mark the ancestors of START with #f, stopping when END is reached
|
||
|
|
|
||
|
|
(define (unmark-ancestors-to start end)
|
||
|
|
(do ((node start (node-parent node)))
|
||
|
|
((eq? node end))
|
||
|
|
(set-node-flag! node #f)))
|
||
|
|
|
||
|
|
; Return the lowest node that is above all NODES
|
||
|
|
|
||
|
|
(define (least-common-ancestor nodes)
|
||
|
|
(mark-ancestors (car nodes) #t)
|
||
|
|
(let loop ((nodes (cdr nodes)) (top (car nodes)))
|
||
|
|
(cond ((null? nodes)
|
||
|
|
(mark-ancestors top #f)
|
||
|
|
top)
|
||
|
|
(else
|
||
|
|
(let ((new (marked-ancestor (car nodes))))
|
||
|
|
(unmark-ancestors-to top new)
|
||
|
|
(loop (cdr nodes) new))))))
|
||
|
|
|
||
|
|
; Can TO be moved to FROM without taking variables out of scope.
|
||
|
|
; This first marks all of the ancestors of FROM, and then unmarks all of the
|
||
|
|
; ancestors of TO. The net result is to mark every node that is above FROM but
|
||
|
|
; not above TO. Then if any reference-node below FROM references a variable
|
||
|
|
; with a marked binder, that node, and thus FROM itself, cannot legally be
|
||
|
|
; moved to TO.
|
||
|
|
|
||
|
|
; This is not currently used anywhere, and it doesn't know about trivial
|
||
|
|
; calls.
|
||
|
|
|
||
|
|
(define (hoistable-node? from to)
|
||
|
|
(let ((from (if (call-node? from)
|
||
|
|
(node-parent (nontrivial-ancestor from))
|
||
|
|
from)))
|
||
|
|
(mark-ancestors (node-parent from) #t)
|
||
|
|
(mark-ancestors to #f)
|
||
|
|
(let ((okay? (let label ((n from))
|
||
|
|
(cond ((lambda-node? n)
|
||
|
|
(let* ((vec (call-args (lambda-body n)))
|
||
|
|
(c (vector-length vec)))
|
||
|
|
(let loop ((i 0))
|
||
|
|
(cond ((>= i c) #t)
|
||
|
|
((label (vector-ref vec i))
|
||
|
|
(loop (+ i 1)))
|
||
|
|
(else #f)))))
|
||
|
|
((reference-node? n)
|
||
|
|
(let ((b (variable-binder (reference-variable n))))
|
||
|
|
(or (not b) (not (node-flag b)))))
|
||
|
|
(else #t)))))
|
||
|
|
(mark-ancestors (node-parent from) #f)
|
||
|
|
okay?)))
|
||
|
|
|
||
|
|
; Mark all of the lambda nodes which bind variables referenced below NODE.
|
||
|
|
|
||
|
|
(define (mark-binders node)
|
||
|
|
(let label ((n node))
|
||
|
|
(cond ((lambda-node? n)
|
||
|
|
(walk-vector label (call-args (lambda-body n))))
|
||
|
|
((reference-node? n)
|
||
|
|
(let ((b (variable-binder (reference-variable n))))
|
||
|
|
(if b (set-node-flag! b #f))))))
|
||
|
|
(values))
|
||
|
|
|
||
|
|
|
||
|
|
;------------------------------------------------------------------------------
|
||
|
|
; For each lambda-node L this sets (PARENT L) to be the enclosing PROC node
|
||
|
|
; of L and, if L is a PROC node, sets (KIDS L) to be the lambda nodes it
|
||
|
|
; encloses.
|
||
|
|
|
||
|
|
(define (find-scoping lambdas parent set-parent! kids set-kids!)
|
||
|
|
(receive (procs others)
|
||
|
|
(partition-list proc-lambda? lambdas)
|
||
|
|
(for-each (lambda (l)
|
||
|
|
(set-parent! l #f)
|
||
|
|
(set-kids! l '()))
|
||
|
|
procs)
|
||
|
|
(for-each (lambda (l)
|
||
|
|
(set-parent! l #f))
|
||
|
|
others)
|
||
|
|
(letrec ((set-lambda-parent!
|
||
|
|
(lambda (l)
|
||
|
|
(cond ((parent l)
|
||
|
|
=> identity)
|
||
|
|
((proc-ancestor l)
|
||
|
|
=> (lambda (p)
|
||
|
|
(let ((p (if (proc-lambda? p)
|
||
|
|
p
|
||
|
|
(set-lambda-parent! p))))
|
||
|
|
(set-kids! p (cons l (kids p)))
|
||
|
|
(set-parent! l p)
|
||
|
|
p)))
|
||
|
|
(else #f)))))
|
||
|
|
(for-each set-lambda-parent! lambdas))
|
||
|
|
(values procs others)))
|
||
|
|
|
||
|
|
(define (proc-ancestor node)
|
||
|
|
(let ((p (node-parent node)))
|
||
|
|
(if (not (node? p))
|
||
|
|
#f
|
||
|
|
(let ((node (do ((p p (node-parent p)))
|
||
|
|
((lambda-node? p)
|
||
|
|
p))))
|
||
|
|
(do ((node node (node-parent (node-parent node))))
|
||
|
|
((proc-lambda? node)
|
||
|
|
node))))))
|
||
|
|
|
||
|
|
(define (no-free-references? node)
|
||
|
|
(if (call-node? node)
|
||
|
|
(error "NO-FREE-REFERENCES only works on value nodes: ~S" node))
|
||
|
|
(let label ((node node))
|
||
|
|
(cond ((reference-node? node)
|
||
|
|
(let ((b (variable-binder (reference-variable node))))
|
||
|
|
(or (not b)
|
||
|
|
(node-flag b))))
|
||
|
|
((lambda-node? node)
|
||
|
|
(set-node-flag! node #t)
|
||
|
|
(let* ((vec (call-args (lambda-body node)))
|
||
|
|
(res (let loop ((i (- (vector-length vec) 1)))
|
||
|
|
(cond ((< i 0) #t)
|
||
|
|
((not (label (vector-ref vec i))) #f)
|
||
|
|
(else (loop (- i 1)))))))
|
||
|
|
(set-node-flag! node #f)
|
||
|
|
res))
|
||
|
|
(else
|
||
|
|
#t))))
|
||
|
|
|
||
|
|
(define (node-type node)
|
||
|
|
(cond ((literal-node? node)
|
||
|
|
(literal-type node))
|
||
|
|
((reference-node? node)
|
||
|
|
(variable-type (reference-variable node)))
|
||
|
|
((lambda-node? node)
|
||
|
|
(lambda-node-type node))
|
||
|
|
((and (call-node? node)
|
||
|
|
(primop-trivial? (call-primop node)))
|
||
|
|
(trivial-call-return-type node))
|
||
|
|
(else
|
||
|
|
(error "node ~S does not represent a value" node))))
|
||
|
|
|
||
|
|
;----------------------------------------------------------------
|
||
|
|
; Debugging utilities
|
||
|
|
|
||
|
|
(define (show-simplified node)
|
||
|
|
(let loop ((n node) (r '()))
|
||
|
|
(if (node? n)
|
||
|
|
(loop (node-parent n) (cons (node-simplified? n) r))
|
||
|
|
(reverse r))))
|
||
|
|
|
||
|
|
(define (show-flag node)
|
||
|
|
(let loop ((n node) (r '()))
|
||
|
|
(if (node? n)
|
||
|
|
(loop (node-parent n) (cons (node-flag n) r))
|
||
|
|
(reverse r))))
|
||
|
|
|
||
|
|
(define (reset-simplified node)
|
||
|
|
(let loop ((n node))
|
||
|
|
(cond ((node? n)
|
||
|
|
(set-node-simplified?! n #f)
|
||
|
|
(loop (node-parent n))))))
|