; Copyright (c) 1993-1999 by Richard Kelsey. See file COPYING.
; Code to turn PROC lambdas into JUMP lambdas.
(define (integrate-jump-procs!)
(receive (hits useless)
(find-jump-procs (filter proc-lambda? (make-lambda-list)) find-calls)
(remove-unused-procedures! useless)
(for-each (lambda (p)
(procs->jumps (cdr p)
(map bound-to-variable (cdr p))
(car p)))
hits)
(not (and (null? hits) (null? useless)))))
; Make a call graph with extra nodes inserted for continuations:
;
; If F calls G tail-recursively, add an edge F->G
; If F calls G ... with continuation K, add a node K and edges F->K, K->G ...
;
; Then FIND-JOINS will return a list of the nodes that are passed two or
; more distinct continuations. The rest can be merged with their callers.
;
; Need a root node, so make one that points to all procs with unknown calls.
(define-record-type node :node
(really-make-node proc cont successors join? merged?)
node?
(proc node-proc) ; lambda node (or #f for continuation holders)
(cont node-cont) ; lambda node (or #f for procs)
(successors node-successors set-node-successors!)
(temp node-temp set-node-temp!)
(join? node-join? set-node-join?!)
(merged? node-merged? set-node-merged?!))
(define (make-node proc cont)
(really-make-node proc cont '() #f #f))
(define-record-discloser :node
(lambda (node)
(list 'node (node-proc node) (node-cont node))))
(define (add-child! parent child)
(if (not (memq? child (node-successors parent)))
(set-node-successors! parent (cons child (node-successors parent)))))
; We want to find subsets of ALL-PROCS such that all elements of a subset
; are always called with the same continuation. (PROC->USES <proc>) returns
; the references to <proc> that are calls, or #f if there are references that
; are not calls.
;
; We proceed as follows:
; 1. Partition the procs depending on whether all their calls are known or not.
; 2. Build a call graph:
; Nodes represent either procedures or continuations. If there is a
; tail-recursive call to procedure B in procedure A, then there is an
; edge from A to B. For continuation C such that there is a call in
; procedure A to procedure B with that continuation, there are edges
; from A to C and from C to B.
; In other words, it is a call graph where the edges that represent
; non-tail-recursive calls are replaced by two edges, with a node for
; the continuation in between.
; There is a special root node (representing `outside'), that has
; edges to the nodes representing procedures whose call sites have not
; been identified.
; 3. Determine the dominance frontiers in the graph.
; 4. Find the nodes in the graph that are reachable from more than one
; continuation (the joins).
; 5. Starting from each node that represents a continuation (the joins,
; procs whose calls aren't known, and the continuations themselves),
; find the set of nodes reachable from that node without going through
; some other continuation node.
(define (find-jump-procs all-procs proc->uses)
(for-each (lambda (l)
(set-lambda-block! l (make-node l #f)))
all-procs)
(receive (known unknown)
(partition-list calls-known? all-procs)
(let ((root (make-node #f #f))
(conts-cell (list '()))
(known-blocks (map lambda-block known))
(procs-cell (list (map lambda-block unknown))))
(note-calls! known conts-cell procs-cell proc->uses)
(let ((unknown-blocks (car procs-cell))
(conts (car conts-cell)))
(set-node-successors! root unknown-blocks)
(graph->ssa-graph! root node-successors node-temp set-node-temp!)
(let ((joins (find-joins (append conts unknown-blocks) node-temp)))
(for-each (lambda (n)
(set-node-join?! n #t))
joins)
(let* ((mergable (filter-map find-mergable
(append joins unknown-blocks conts)))
(useless (filter (lambda (p)
(not (or (node-join? (lambda-block p))
(node-merged? (lambda-block p)))))
known)))
(for-each (lambda (p)
(set-lambda-block! p #f))
all-procs)
(values mergable useless)))))))
; Walk KNOWN-PROCS adding edges to the call graph.
(define (note-calls! known-procs conts-cell procs-cell proc->uses)
(for-each (lambda (proc)
(for-each (lambda (ref)
(note-call! (lambda-block proc)
ref
conts-cell procs-cell))
(proc->uses proc)))
known-procs))
; Add an edge from the node containing REF to PROC-NODE. Tail calls add an
; edge directly from the calling node, non-tail calls add an edge from the
; successor to the calling node that represents the call's continuation.
(define (note-call! proc-node ref conts-cell procs-cell)
(let ((caller (get-lambda-block (containing-procedure ref) procs-cell)))
(add-child! (if (calls-this-primop? (node-parent ref) 'tail-call)
caller
(get-cont-block caller
(call-arg (node-parent ref) 0)
conts-cell))
proc-node)))
; Get the block for lambda-node PROC, making a new one if necessary.
(define (get-lambda-block proc procs-cell)
(let ((block (lambda-block proc)))
(if (node? block)
block
(let ((new (make-node proc #f)))
(set-lambda-block! proc new)
(set-car! procs-cell (cons new (car procs-cell)))
new))))
; Get the successor to CALLER containing CONT, making it if necessary.
(define (get-cont-block caller cont conts-cell)
(or (any (lambda (node)
(and (node-cont node)
(node-equal? cont (node-cont node))))
(node-successors caller))
(let ((cont-node (make-node #f cont)))
(set-car! conts-cell (cons cont-node (car conts-cell)))
(add-child! caller cont-node)
cont-node)))
;----------------
(define (find-mergable node)
(let ((mergable (really-find-mergable node)))
(if (null? mergable)
#f
(cons (or (node-cont node)
(car (variable-refs (car (lambda-variables (node-proc node))))))
mergable))))
(define (really-find-mergable node)
(let recur ((nodes (node-successors node)) (res '()))
(if (null? nodes)
res
(recur (cdr nodes)
(let ((node (car nodes)))
(cond ((or (node-join? node) ; gets two or more continuations
(node-merged? node) ; already merged
(node-cont node)) ; different continuation
res)
; ((node-cont node) ; not a lambda
; (recur (node-successors node) res))
(else
(set-node-merged?! node #t)
(recur (node-successors node)
(cons (node-proc node) res)))))))))
;=============================================================================;
; Part 2. PROCS is a list of procedures that are only called by each other;
; with no entry point they are useless and can be removed.
(define (remove-unused-procedures! procs)
(for-each (lambda (proc)
(let ((var (bound-to-variable proc)))
(if (not var)
(bug "known procedure has no variable ~S" proc))
(format #t "Removing unused procedure: ~S~%"
(variable-name var)) ; would LAMBDA-NAME be better?
(mark-changed (node-parent proc))
(detach-bound-value var proc)
(erase proc)))
procs))
;=============================================================================;
; Part 3. Turn JUMP-PROCS from procs to jumps. CONT is the continuation they
; all receive, and is also turned into a jump.
; This creates a LETREC to bind all CONT and any of JUMP-PROCS that are
; passed CONT directly and are bound abouve the LCA of all calls to JUMP-PROCS
; that use CONT. Then every jump-proc is changed from a proc lambda to a
; jump lambda and has its continuation removed. Returns are replaced with
; jumps to CONT. If CONT is not a variable some protocol adjustment may be
; required.
(define (procs->jumps jump-procs vars cont)
(receive (called-vars called-procs lca)
(find-cont-uses cont vars jump-procs)
(let ((proc (containing-procedure cont))
(lca (if (call-node? lca) lca (node-parent lca)))
(cvar (if (lambda-node? cont)
(make-variable 'w (node-type cont))
#f)))
(receive (called-vars called-procs)
(bound-above? lca called-vars called-procs)
(for-each detach-bound-value called-vars called-procs)
(cond ((lambda-node? cont)
(determine-continuation-protocol cont jump-procs)
(move cont (lambda (ignore) (make-literal-node '#f '#f)))
(put-in-letrec (cons cvar called-vars)
(cons cont called-procs)
lca)
(change-lambda-type cont 'jump))
(else
(put-in-letrec called-vars called-procs lca))))
(for-each proc-calls->jumps jump-procs)
(for-each (lambda (p)
(let* ((v (car (lambda-variables p)))
(refs (variable-refs v)))
(set-variable-refs! v '())
(for-each (lambda (r)
(if (lambda-node? cont)
(return->jump (node-parent r) cvar cont)
(replace r (make-reference-node
(car (lambda-variables proc))))))
refs)
(remove-variable p v)))
jump-procs)
(values))))
; Returns those of VALS and VARS where there is a call to the variable that
; passes CONT as a continuation, or where the variable is not bound. The
; third values returned is the least-common-ancestor of all calls to VARS
; that use CONT.
(define (find-cont-uses cont vars vals)
(let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()) (uses '()))
(if (null? vars)
(values r-vars r-vals (least-common-ancestor uses))
(let ref-loop ((refs (variable-refs (car vars))) (my-uses uses))
(cond ((not (null? refs))
(ref-loop (cdr refs)
(if (node-equal? cont
(call-arg (node-parent (car refs)) 0))
(cons (car refs) my-uses)
my-uses)))
((and (variable-binder (car vars))
(eq? my-uses uses))
(loop (cdr vars) (cdr vals) r-vars r-vals uses))
(else
(loop (cdr vars) (cdr vals)
(cons (car vars) r-vars)
(cons (car vals) r-vals)
my-uses)))))))
; Return the list of VARS and VALS where the variable is either global
; or bound above CALL.
(define (bound-above? call vars vals)
(set-node-flag! call #t)
(let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()))
(cond ((null? vars)
(set-node-flag! call #f)
(values r-vars r-vals))
((and (variable-binder (car vars))
(marked-ancestor (variable-binder (car vars))))
(loop (cdr vars) (cdr vals) r-vars r-vals))
(else
(loop (cdr vars) (cdr vals)
(cons (car vars) r-vars)
(cons (car vals) r-vals))))))
(define (detach-bound-value var node)
(if (variable-binder var)
(let ((binder (variable-binder var))
(parent (node-parent node))
(index (node-index node)))
(set-lambda-variables! binder (delq! var (lambda-variables binder)))
(detach node)
(remove-call-arg parent index))))
; Turn all calls to PROC into jumps.
(define (proc-calls->jumps proc)
(for-each (lambda (n)
(call->jump (node-parent n)))
(find-calls proc))
(change-lambda-type proc 'jump))
; Change a call to a jump by changing the primop and removing the continuation.
(define (call->jump call)
(case (primop-id (call-primop call))
((call tail-call)
(set-call-primop! call (get-primop (enum primop jump)))
(remove-call-arg call 0))
(else
(bug "odd call primop ~S" (call-primop call)))))
; Change a return to a jump. VAR is a variable bound to JUMP, the lambda
; being jumped to.
(define (return->jump call var jump)
(case (primop-id (call-primop call))
((return)
(set-call-primop! call (get-primop (enum primop jump)))
(replace (call-arg call 0) (make-reference-node var)))
(else
(bug "odd return primop ~S" (call-primop call)))))