#:use-module (srfi srfi-26)
#:use-module (language cps)
#:export (build-cont-table
- build-local-cont-table
lookup-cont
compute-dfg
dfg-cont-table
+ dfg-min-label
+ dfg-label-count
+ dfg-min-var
+ dfg-var-count
lookup-def
lookup-uses
lookup-predecessors
;; Data flow analysis.
compute-live-variables
dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
- dfa-var-idx dfa-var-name dfa-var-sym dfa-var-count
+ dfa-var-idx dfa-var-sym dfa-var-count
print-dfa))
+;; These definitions are here because currently we don't do cross-module
+;; inlining. They can be removed once that restriction is gone.
+(define-inlinable (for-each f l)
+ (unless (list? l)
+ (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
+ (let for-each1 ((l l))
+ (unless (null? l)
+ (f (car l))
+ (for-each1 (cdr l)))))
+
+(define-inlinable (for-each/2 f l1 l2)
+ (unless (= (length l1) (length l2))
+ (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+ (list l2) #f))
+ (let for-each2 ((l1 l1) (l2 l2))
+ (unless (null? l1)
+ (f (car l1) (car l2))
+ (for-each2 (cdr l1) (cdr l2)))))
+
(define (build-cont-table fun)
- (fold-conts (lambda (k cont table)
- (hashq-set! table k cont)
- table)
- (make-hash-table)
- fun))
-
-(define (build-local-cont-table cont)
- (fold-local-conts (lambda (k cont table)
- (hashq-set! table k cont)
- table)
- (make-hash-table)
- cont))
-
-(define (lookup-cont sym conts)
- (let ((res (hashq-ref conts sym)))
- (unless res
- (error "Unknown continuation!" sym (hash-fold acons '() conts)))
- res))
+ (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
+ -1 fun)))
+ (fold-conts (lambda (k cont table)
+ (vector-set! table k cont)
+ table)
+ (make-vector (1+ max-k) #f)
+ fun)))
;; Data-flow graph for CPS: both for values and continuations.
(define-record-type $dfg
- (make-dfg conts blocks use-maps)
+ (make-dfg conts preds defs uses scopes scope-levels
+ min-label label-count min-var var-count)
dfg?
- ;; hash table of sym -> $kif, $kargs, etc
+ ;; vector of label -> $kif, $kargs, etc
(conts dfg-cont-table)
- ;; hash table of sym -> $block
- (blocks dfg-blocks)
- ;; hash table of sym -> $use-map
- (use-maps dfg-use-maps))
-
-(define-record-type $use-map
- (make-use-map name sym def uses)
- use-map?
- (name use-map-name)
- (sym use-map-sym)
- (def use-map-def)
- (uses use-map-uses set-use-map-uses!))
-
-(define-record-type $block
- (%make-block scope scope-level preds succs)
- block?
- (scope block-scope set-block-scope!)
- (scope-level block-scope-level set-block-scope-level!)
- (preds block-preds set-block-preds!)
- (succs block-succs set-block-succs!))
-
-(define (make-block scope scope-level)
- (%make-block scope scope-level '() '()))
+ ;; vector of label -> (pred-label ...)
+ (preds dfg-preds)
+ ;; vector of var -> def-label
+ (defs dfg-defs)
+ ;; vector of var -> (use-label ...)
+ (uses dfg-uses)
+ ;; vector of label -> label
+ (scopes dfg-scopes)
+ ;; vector of label -> int
+ (scope-levels dfg-scope-levels)
+
+ (min-label dfg-min-label)
+ (label-count dfg-label-count)
+ (min-var dfg-min-var)
+ (var-count dfg-var-count))
;; Some analyses assume that the only relevant set of nodes is the set
;; that is reachable from some start node. Others need to include nodes
(when (< n k-count)
(for-each (lambda (succ)
(vector-push! succs n (cfa-k-idx cfa succ)))
- (block-succs (lookup-block (cfa-k-sym cfa n)
- (dfg-blocks dfg))))
+ (lookup-successors (cfa-k-sym cfa n) dfg))
(lp (1+ n))))
;; Iterate cfa backwards, to converge quickly.
((= n (cfa-k-count cfa))
(reverse prompts))
(else
- (match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
+ (match (lookup-cont (cfa-k-sym cfa n) dfg)
(($ $kargs names syms body)
(match (find-expression body)
(($ $prompt escape? tag handler)
(let ((succ (cfa-k-idx cfa succ)))
(or (not (bitvector-ref body succ))
(<= succ n))))
- (block-succs (lookup-block (cfa-k-sym cfa n)
- (dfg-blocks dfg)))))
+ (lookup-successors (cfa-k-sym cfa n) dfg)))
(let lp ((n 0))
(let ((n (bit-position #t body n)))
(when n
(find-prompt-bodies cfa dfg)))
(define* (analyze-control-flow fun dfg #:key reverse? add-handler-preds?)
- (define (build-cfa kentry block-succs block-preds forward-cfa)
- (define (block-accessor accessor)
- (lambda (k)
- (accessor (lookup-block k (dfg-blocks dfg)))))
- (define (reachable-preds mapping accessor)
+ (define (build-cfa kentry lookup-succs lookup-preds forward-cfa)
+ (define (reachable-preds mapping)
;; It's possible for a predecessor to not be in the mapping, if
;; the predecessor is not reachable from the entry node.
(lambda (k)
- (filter-map (cut hashq-ref mapping <>)
- ((block-accessor accessor) k))))
+ (filter-map (cut hashq-ref mapping <>) (lookup-preds k dfg))))
(let* ((order (reverse-post-order
kentry
- (block-accessor block-succs)
+ (lambda (k)
+ ;; RPO numbering is going to visit this list of
+ ;; successors in the order that we give it. Sort
+ ;; it so that all things being equal, we preserve
+ ;; the existing numbering order. This also has the
+ ;; effect of preserving clause order.
+ (let ((succs (lookup-succs k dfg)))
+ (if (or (null? succs) (null? (cdr succs)))
+ succs
+ (sort succs >))))
(if forward-cfa
(lambda (f seed)
(let lp ((n (cfa-k-count forward-cfa)) (seed seed))
(f (cfa-k-sym forward-cfa (1- n)) seed)))))
(lambda (f seed) seed))))
(k-map (make-block-mapping order))
- (preds (convert-predecessors order
- (reachable-preds k-map block-preds)))
+ (preds (convert-predecessors order (reachable-preds k-map)))
(cfa (make-cfa k-map order preds)))
(when add-handler-preds?
;; Any expression in the prompt body could cause an abort to the
(match fun
(($ $fun src meta free
($ $cont kentry
- (and entry
- ($ $kentry self ($ $cont ktail tail) clauses))))
+ (and entry ($ $kentry self ($ $cont ktail tail)))))
(if reverse?
- (build-cfa ktail block-preds block-succs
+ (build-cfa ktail lookup-predecessors lookup-successors
(analyze-control-flow fun dfg #:reverse? #f
#:add-handler-preds? #f))
- (build-cfa kentry block-succs block-preds #f)))))
+ (build-cfa kentry lookup-successors lookup-predecessors #f)))))
;; Dominator analysis.
(define-record-type $dominator-analysis
;; Data-flow analysis.
(define-record-type $dfa
- (make-dfa cfa var-map names syms in out)
+ (make-dfa cfa min-var var-count in out)
dfa?
;; CFA, for its reverse-post-order numbering
(cfa dfa-cfa)
- ;; Hash table mapping var-sym -> var-idx
- (var-map dfa-var-map)
- ;; Vector of var-idx -> name
- (names dfa-names)
- ;; Vector of var-idx -> var-sym
- (syms dfa-syms)
+ ;; Minimum var in this function.
+ (min-var dfa-min-var)
+ ;; Minimum var in this function.
+ (var-count dfa-var-count)
;; Vector of k-idx -> bitvector
(in dfa-in)
;; Vector of k-idx -> bitvector
(cfa-k-count (dfa-cfa dfa)))
(define (dfa-var-idx dfa var)
- (or (hashq-ref (dfa-var-map dfa) var)
- (error "unknown var" var)))
-
-(define (dfa-var-name dfa idx)
- (vector-ref (dfa-names dfa) idx))
+ (let ((idx (- var (dfa-min-var dfa))))
+ (unless (< -1 idx (dfa-var-count dfa))
+ (error "var out of range" var))
+ idx))
(define (dfa-var-sym dfa idx)
- (vector-ref (dfa-syms dfa) idx))
-
-(define (dfa-var-count dfa)
- (vector-length (dfa-syms dfa)))
+ (unless (< -1 idx (dfa-var-count dfa))
+ (error "idx out of range" idx))
+ (+ idx (dfa-min-var dfa)))
(define (dfa-k-in dfa idx)
(vector-ref (dfa-in dfa) idx))
(vector-ref (dfa-out dfa) idx))
(define (compute-live-variables fun dfg)
- (define (make-variable-mapping use-maps)
- (let ((mapping (make-hash-table))
- (n 0))
- (hash-for-each (lambda (sym use-map)
- (hashq-set! mapping sym n)
- (set! n (1+ n)))
- use-maps)
- (values mapping n)))
- (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
- (lambda (var-map nvars)
- (let* ((cfa (analyze-control-flow fun dfg #:reverse? #t
- #:add-handler-preds? #t))
- (syms (make-vector nvars #f))
- (names (make-vector nvars #f))
- (usev (make-vector (cfa-k-count cfa) '()))
- (defv (make-vector (cfa-k-count cfa) '()))
- (live-in (make-vector (cfa-k-count cfa) #f))
- (live-out (make-vector (cfa-k-count cfa) #f)))
- ;; Initialize syms, names, defv, and usev.
- (hash-for-each
- (lambda (sym use-map)
- (match use-map
- (($ $use-map name sym def uses)
- (let ((v (or (hashq-ref var-map sym)
- (error "unknown var" sym))))
- (vector-set! syms v sym)
- (vector-set! names v name)
- (for-each (lambda (def)
- (vector-push! defv (cfa-k-idx cfa def) v))
- (block-preds (lookup-block def (dfg-blocks dfg))))
- (for-each (lambda (use)
- (vector-push! usev (cfa-k-idx cfa use) v))
- uses)))))
- (dfg-use-maps dfg))
-
- ;; Initialize live-in and live-out sets.
- (let lp ((n 0))
- (when (< n (vector-length live-out))
- (vector-set! live-in n (make-bitvector nvars #f))
- (vector-set! live-out n (make-bitvector nvars #f))
- (lp (1+ n))))
-
- ;; Liveness is a reverse data-flow problem, so we give
- ;; compute-maximum-fixed-point a reversed graph, swapping in
- ;; for out, and usev for defv. Note that since we are using
- ;; a reverse CFA, cfa-preds are actually successors, and
- ;; continuation 0 is ktail.
- (compute-maximum-fixed-point (cfa-preds cfa)
- live-out live-in defv usev #t)
-
- (make-dfa cfa var-map names syms live-in live-out)))))
+ (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
+ (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
+ (error "function needs renumbering"))
+ (let* ((min-var (dfg-min-var dfg))
+ (nvars (dfg-var-count dfg))
+ (cfa (analyze-control-flow fun dfg #:reverse? #t
+ #:add-handler-preds? #t))
+ (usev (make-vector (cfa-k-count cfa) '()))
+ (defv (make-vector (cfa-k-count cfa) '()))
+ (live-in (make-vector (cfa-k-count cfa) #f))
+ (live-out (make-vector (cfa-k-count cfa) #f)))
+ (define (var->idx var) (- var min-var))
+ (define (idx->var idx) (+ idx min-var))
+
+ ;; Initialize defv and usev.
+ (let ((defs (dfg-defs dfg))
+ (uses (dfg-uses dfg)))
+ (let lp ((n 0))
+ (when (< n (vector-length defs))
+ (let ((def (vector-ref defs n)))
+ (unless def
+ (error "internal error -- var array not packed"))
+ (for-each (lambda (def)
+ (vector-push! defv (cfa-k-idx cfa def) n))
+ (lookup-predecessors def dfg))
+ (for-each (lambda (use)
+ (vector-push! usev (cfa-k-idx cfa use) n))
+ (vector-ref uses n))
+ (lp (1+ n))))))
+
+ ;; Initialize live-in and live-out sets.
+ (let lp ((n 0))
+ (when (< n (vector-length live-out))
+ (vector-set! live-in n (make-bitvector nvars #f))
+ (vector-set! live-out n (make-bitvector nvars #f))
+ (lp (1+ n))))
+
+ ;; Liveness is a reverse data-flow problem, so we give
+ ;; compute-maximum-fixed-point a reversed graph, swapping in
+ ;; for out, and usev for defv. Note that since we are using
+ ;; a reverse CFA, cfa-preds are actually successors, and
+ ;; continuation 0 is ktail.
+ (compute-maximum-fixed-point (cfa-preds cfa)
+ live-out live-in defv usev #t)
+
+ (make-dfa cfa min-var nvars live-in live-out)))
(define (print-dfa dfa)
(match dfa
- (($ $dfa cfa var-map names syms in out)
+ (($ $dfa cfa min-var in out)
(define (print-var-set bv)
(let lp ((n 0))
(let ((n (bit-position #t bv n)))
(when n
- (format #t " ~A" (vector-ref syms n))
+ (format #t " ~A" (+ n min-var))
(lp (1+ n))))))
(let lp ((n 0))
(when (< n (cfa-k-count cfa))
(newline)
(lp (1+ n)))))))
-(define (visit-fun fun conts blocks use-maps global?)
- (define (add-def! name sym def-k)
- (unless def-k
- (error "Term outside labelled continuation?"))
- (hashq-set! use-maps sym (make-use-map name sym def-k '())))
+(define (visit-fun fun conts preds defs uses scopes scope-levels
+ min-label min-var global?)
+ (define (add-def! var def-k)
+ (vector-set! defs (- var min-var) def-k))
- (define (add-use! sym use-k)
- (match (hashq-ref use-maps sym)
- (#f (error "Symbol out of scope?" sym))
- ((and use-map ($ $use-map name sym def uses))
- (set-use-map-uses! use-map (cons use-k uses)))))
+ (define (add-use! var use-k)
+ (vector-push! uses (- var min-var) use-k))
(define* (declare-block! label cont parent
#:optional (level
- (1+ (lookup-scope-level parent blocks))))
- (hashq-set! conts label cont)
- (hashq-set! blocks label (make-block parent level)))
+ (1+ (vector-ref
+ scope-levels
+ (- parent min-label)))))
+ (vector-set! conts (- label min-label) cont)
+ (vector-set! scopes (- label min-label) parent)
+ (vector-set! scope-levels (- label min-label) level))
(define (link-blocks! pred succ)
- (let ((pred-block (hashq-ref blocks pred))
- (succ-block (hashq-ref blocks succ)))
- (unless (and pred-block succ-block)
- (error "internal error" pred-block succ-block))
- (set-block-succs! pred-block (cons succ (block-succs pred-block)))
- (set-block-preds! succ-block (cons pred (block-preds succ-block)))))
+ (vector-push! preds (- succ min-label) pred))
(define (visit exp exp-k)
- (define (def! name sym)
- (add-def! name sym exp-k))
+ (define (def! sym)
+ (add-def! sym exp-k))
(define (use! sym)
(add-use! sym exp-k))
(define (use-k! k)
(match exp
(($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
- (for-each (lambda (cont k)
- (declare-block! k cont exp-k))
- cont k)
- (for-each visit cont k)
+ (for-each/2 (lambda (cont k)
+ (declare-block! k cont exp-k))
+ cont k)
+ (for-each/2 visit cont k)
(recur body))
(($ $kargs names syms body)
- (for-each def! names syms)
+ (for-each def! syms)
(recur body))
(($ $kif kt kf)
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
- (for-each def! names syms)
- (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
+ (for-each def! syms)
+ (for-each
+ (cut visit-fun <> conts preds defs uses scopes scope-levels
+ min-label min-var global?)
+ funs)
(visit body exp-k))
(($ $continue k src exp)
(($ $fun)
(when global?
- (visit-fun exp conts blocks use-maps global?)))
+ (visit-fun exp conts preds defs uses scopes scope-levels
+ min-label min-var global?)))
(_ #f)))))
(($ $fun src meta free
($ $cont kentry
(and entry
- ($ $kentry self ($ $cont ktail tail) clauses))))
+ ($ $kentry self ($ $cont ktail tail) clause))))
(declare-block! kentry entry #f 0)
- (add-def! #f self kentry)
+ (add-def! self kentry)
(declare-block! ktail tail kentry)
- (for-each
- (match-lambda
- (($ $cont kclause
- (and clause ($ $kclause arity ($ $cont kbody body))))
- (declare-block! kclause clause kentry)
- (link-blocks! kentry kclause)
-
- (declare-block! kbody body kclause)
- (link-blocks! kclause kbody)
-
- (visit body kbody)))
- clauses))))
+ (let lp ((clause clause))
+ (match clause
+ (#f #t)
+ (($ $cont kclause
+ (and clause ($ $kclause arity ($ $cont kbody body)
+ alternate)))
+ (declare-block! kclause clause kentry)
+ (link-blocks! kentry kclause)
+
+ (declare-block! kbody body kclause)
+ (link-blocks! kclause kbody)
+
+ (visit body kbody)
+ (lp alternate)))))))
+
+(define (compute-label-and-var-ranges fun global?)
+ (define (min* a b)
+ (if b (min a b) a))
+ (define-syntax-rule (do-fold global?)
+ ((make-cont-folder global?
+ min-label max-label label-count
+ min-var max-var var-count)
+ (lambda (label cont
+ min-label max-label label-count
+ min-var max-var var-count)
+ (let ((min-label (min* label min-label))
+ (max-label (max label max-label)))
+ (define (visit-letrec body min-var max-var var-count)
+ (match body
+ (($ $letk conts body)
+ (visit-letrec body min-var max-var var-count))
+ (($ $letrec names vars funs body)
+ (visit-letrec body
+ (cond (min-var (fold min min-var vars))
+ ((pair? vars) (fold min (car vars) (cdr vars)))
+ (else min-var))
+ (fold max max-var vars)
+ (+ var-count (length vars))))
+ (($ $continue) (values min-var max-var var-count))))
+ (match cont
+ (($ $kargs names vars body)
+ (call-with-values
+ (lambda ()
+ (if global?
+ (visit-letrec body min-var max-var var-count)
+ (values min-var max-var var-count)))
+ (lambda (min-var max-var var-count)
+ (values min-label max-label (1+ label-count)
+ (cond (min-var (fold min min-var vars))
+ ((pair? vars) (fold min (car vars) (cdr vars)))
+ (else min-var))
+ (fold max max-var vars)
+ (+ var-count (length vars))))))
+ (($ $kentry self)
+ (values min-label max-label (1+ label-count)
+ (min* self min-var) (max self max-var) (1+ var-count)))
+ (_ (values min-label max-label (1+ label-count)
+ min-var max-var var-count)))))
+ fun
+ #f -1 0 #f -1 0))
+ (if global?
+ (do-fold #t)
+ (do-fold #f)))
(define* (compute-dfg fun #:key (global? #t))
- (let* ((conts (make-hash-table))
- (blocks (make-hash-table))
- (use-maps (make-hash-table)))
- (visit-fun fun conts blocks use-maps global?)
- (make-dfg conts blocks use-maps)))
-
-(define (lookup-block k blocks)
- (let ((res (hashq-ref blocks k)))
+ (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
+ (lambda (min-label max-label label-count min-var max-var var-count)
+ (when (or (zero? label-count) (zero? var-count))
+ (error "internal error (no vars or labels for fun?)"))
+ (let* ((nlabels (- (1+ max-label) min-label))
+ (nvars (- (1+ max-var) min-var))
+ (conts (make-vector nlabels #f))
+ (preds (make-vector nlabels '()))
+ (defs (make-vector nvars #f))
+ (uses (make-vector nvars '()))
+ (scopes (make-vector nlabels #f))
+ (scope-levels (make-vector nlabels #f)))
+ (visit-fun fun conts preds defs uses scopes scope-levels
+ min-label min-var global?)
+ (make-dfg conts preds defs uses scopes scope-levels
+ min-label label-count min-var var-count)))))
+
+(define (lookup-cont label dfg)
+ (let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
(unless res
- (error "Unknown continuation!" k (hash-fold acons '() blocks)))
+ (error "Unknown continuation!" label))
res))
-(define (lookup-scope-level k blocks)
- (match (lookup-block k blocks)
- (($ $block _ scope-level) scope-level)))
+(define (lookup-predecessors k dfg)
+ (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
-(define (lookup-use-map sym use-maps)
- (let ((res (hashq-ref use-maps sym)))
- (unless res
- (error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
- res))
+(define (lookup-successors k dfg)
+ (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
+ (visit-cont-successors list cont)))
-(define (lookup-def sym dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map name sym def uses)
- def)))))
+(define (lookup-def var dfg)
+ (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
-(define (lookup-uses sym dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map name sym def uses)
- uses)))))
+(define (lookup-uses var dfg)
+ (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
(define (lookup-block-scope k dfg)
- (block-scope (lookup-block k (dfg-blocks dfg))))
-
-(define (lookup-predecessors k dfg)
- (match (lookup-block k (dfg-blocks dfg))
- (($ $block _ _ preds succs) preds)))
+ (vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg))))
-(define (lookup-successors k dfg)
- (match (lookup-block k (dfg-blocks dfg))
- (($ $block _ _ preds succs) succs)))
+(define (lookup-scope-level k dfg)
+ (vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg))))
(define (find-defining-term sym dfg)
(match (lookup-predecessors (lookup-def sym dfg) dfg)
((def-exp-k)
- (lookup-cont def-exp-k (dfg-cont-table dfg)))
+ (lookup-cont def-exp-k dfg))
(else #f)))
(define (find-call term)
(($ $kargs names syms body) (find-exp body))
(($ $letk conts body) (find-exp body))
(else term)))
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map _ _ def uses)
- (or-map
- (lambda (use)
- (match (find-expression (lookup-cont use conts))
- (($ $call) #f)
- (($ $callk) #f)
- (($ $values) #f)
- (($ $primcall 'free-ref (closure slot))
- (not (eq? sym slot)))
- (($ $primcall 'free-set! (closure slot value))
- (not (eq? sym slot)))
- (($ $primcall 'cache-current-module! (mod . _))
- (eq? sym mod))
- (($ $primcall 'cached-toplevel-box _)
- #f)
- (($ $primcall 'cached-module-box _)
- #f)
- (($ $primcall 'resolve (name bound?))
- (eq? sym name))
- (($ $primcall 'make-vector/immediate (len init))
- (not (eq? sym len)))
- (($ $primcall 'vector-ref/immediate (v i))
- (not (eq? sym i)))
- (($ $primcall 'vector-set!/immediate (v i x))
- (not (eq? sym i)))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
- (not (eq? sym nfields)))
- (($ $primcall 'struct-ref/immediate (s n))
- (not (eq? sym n)))
- (($ $primcall 'struct-set!/immediate (s n x))
- (not (eq? sym n)))
- (($ $primcall 'builtin-ref (idx))
- #f)
- (_ #t)))
- uses))))))
-
-(define (continuation-scope-contains? scope-k k blocks)
- (let ((scope-level (lookup-scope-level scope-k blocks)))
+
+ (or-map
+ (lambda (use)
+ (match (find-expression (lookup-cont use dfg))
+ (($ $call) #f)
+ (($ $callk) #f)
+ (($ $values) #f)
+ (($ $primcall 'free-ref (closure slot))
+ (not (eq? sym slot)))
+ (($ $primcall 'free-set! (closure slot value))
+ (not (eq? sym slot)))
+ (($ $primcall 'cache-current-module! (mod . _))
+ (eq? sym mod))
+ (($ $primcall 'cached-toplevel-box _)
+ #f)
+ (($ $primcall 'cached-module-box _)
+ #f)
+ (($ $primcall 'resolve (name bound?))
+ (eq? sym name))
+ (($ $primcall 'make-vector/immediate (len init))
+ (not (eq? sym len)))
+ (($ $primcall 'vector-ref/immediate (v i))
+ (not (eq? sym i)))
+ (($ $primcall 'vector-set!/immediate (v i x))
+ (not (eq? sym i)))
+ (($ $primcall 'allocate-struct/immediate (vtable nfields))
+ (not (eq? sym nfields)))
+ (($ $primcall 'struct-ref/immediate (s n))
+ (not (eq? sym n)))
+ (($ $primcall 'struct-set!/immediate (s n x))
+ (not (eq? sym n)))
+ (($ $primcall 'builtin-ref (idx))
+ #f)
+ (_ #t)))
+ (vector-ref (dfg-uses dfg) (- sym (dfg-min-var dfg)))))
+
+(define (continuation-scope-contains? scope-k k dfg)
+ (let ((scope-level (lookup-scope-level scope-k dfg)))
(let lp ((k k))
(or (eq? scope-k k)
- (match (lookup-block k blocks)
- (($ $block scope level)
- (and (< scope-level level)
- (lp scope))))))))
+ (and (< scope-level (lookup-scope-level k dfg))
+ (lp (lookup-block-scope k dfg)))))))
(define (continuation-bound-in? k use-k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-block k blocks)
- (($ $block def-k)
- (continuation-scope-contains? def-k use-k blocks))))))
+ (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
(define (variable-free-in? var k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (or-map (lambda (use)
- (continuation-scope-contains? k use blocks))
- (match (lookup-use-map var use-maps)
- (($ $use-map name sym def uses)
- uses))))))
+ (or-map (lambda (use)
+ (continuation-scope-contains? k use dfg))
+ (lookup-uses var dfg)))
;; A continuation is a control point if it has multiple predecessors, or
-;; if its single predecessor has multiple successors.
+;; if its single predecessor does not have a single successor.
(define (control-point? k dfg)
(match (lookup-predecessors k dfg)
((pred)
- (match (lookup-successors pred dfg)
- ((_) #f)
- (_ #t)))
+ (let ((cont (vector-ref (dfg-cont-table dfg)
+ (- pred (dfg-min-label dfg)))))
+ (visit-cont-successors (case-lambda
+ (() #t)
+ ((succ0) #f)
+ ((succ1 succ2) #t))
+ cont)))
(_ #t)))
(define (lookup-bound-syms k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-cont k conts)
- (($ $kargs names syms body)
- syms)))))
+ (match (lookup-cont k dfg)
+ (($ $kargs names syms body)
+ syms)))
HCoop / bpt / guile.git / blobdiff