;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (srfi srfi-26)
#:use-module (language cps)
#:use-module (language cps dfg)
+ #:use-module (language cps intset)
#:export (allocate-slots
lookup-slot
lookup-maybe-slot
tmp)
(loop to-move b (cons s+d moved) last-source))))))))))
-(define (dead-after-def? def-k v-idx dfa)
- (let ((l (dfa-k-idx dfa def-k)))
- (not (bitvector-ref (dfa-k-in dfa l) v-idx))))
+(define (dead-after-def? k-idx v-idx dfa)
+ (not (intset-ref (dfa-k-in dfa k-idx) v-idx)))
-(define (dead-after-use? use-k v-idx dfa)
- (let ((l (dfa-k-idx dfa use-k)))
- (not (bitvector-ref (dfa-k-out dfa l) v-idx))))
+(define (dead-after-use? k-idx v-idx dfa)
+ (not (intset-ref (dfa-k-out dfa k-idx) v-idx)))
(define (allocate-slots fun dfg)
(let* ((dfa (compute-live-variables fun dfg))
(logand live-slots (lognot (ash 1 slot))))
(define (compute-slot live-slots hint)
- (if (and hint (not (logbit? hint live-slots)))
+ ;; Slots 253-255 are reserved for shuffling; see comments in
+ ;; assembler.scm.
+ (if (and hint (not (logbit? hint live-slots))
+ (or (< hint 253) (> hint 255)))
hint
- (find-first-zero live-slots)))
+ (let ((slot (find-first-zero live-slots)))
+ (if (or (< slot 253) (> slot 255))
+ slot
+ (+ 256 (find-first-zero (ash live-slots -256)))))))
(define (compute-call-proc-slot live-slots)
(+ 2 (find-first-trailing-zero live-slots)))
(define (compute-prompt-handler-proc-slot live-slots)
- (1- (find-first-trailing-zero live-slots)))
+ (if (zero? live-slots)
+ 0
+ (1- (find-first-trailing-zero live-slots))))
(define (recompute-live-slots k nargs)
- (let ((in (dfa-k-in dfa (dfa-k-idx dfa k))))
- (let lp ((v 0) (live-slots (1- (ash 1 (1+ nargs)))))
- (let ((v (bit-position #t in v)))
+ (let ((in (dfa-k-in dfa (label->idx k))))
+ (let lp ((v 0) (live-slots 0))
+ (let ((v (intset-next in v)))
(if v
(let ((slot (vector-ref slots v)))
(lp (1+ v)
;; or to function return values -- it could be that they are out of
;; the computed live set. In that case they need to be adjoined to
;; the live set, used when choosing a temporary slot.
+ ;;
+ ;; Note that although we reserve slots 253-255 for shuffling
+ ;; operands that address less than the full 24-bit range of locals,
+ ;; that reservation doesn't apply here, because this temporary
+ ;; itself is used while doing parallel assignment via "mov", and
+ ;; "mov" does not need shuffling.
(define (compute-tmp-slot live stack-slots)
(find-first-zero (fold add-live-slot live stack-slots)))
(let lp ((n 0))
(when (< n (vector-length usev))
(match (lookup-cont (idx->label n) dfg)
- (($ $kentry src meta self)
+ (($ $kfun src meta self)
(vector-set! defv n (list (dfa-var-idx dfa self))))
(($ $kargs names syms body)
(vector-set! defv n (map (cut dfa-var-idx dfa <>) syms))
(cons proc args))
(($ $primcall name args)
args)
+ (($ $branch kt ($ $primcall name args))
+ args)
+ (($ $branch kt ($ $values args))
+ args)
(($ $values args)
args)
(($ $prompt escape? tag handler)
;; predecessor.
((or (_) ((? kreceive-get-kargs) ...))
(for-each (lambda (var)
- (when (dead-after-def? (idx->label n) var dfa)
+ (when (dead-after-def? n var dfa)
(bitvector-set! needs-slotv var #f)))
(vector-ref defv n)))
(_ #f))
;; frames as soon as it's known that a call will happen. It would
;; be nice to recast this as a proper data-flow problem.
(define (compute-needs-hint!)
- ;; We traverse the graph using reverse-post-order on a forward
- ;; control-flow graph, but we did the live variable analysis in
- ;; the opposite direction -- so the continuation numbers don't
- ;; correspond. This helper adapts them.
- (define (label-idx->dfa-k-idx n)
- (dfa-k-idx dfa (idx->label n)))
-
(define (live-before n)
- (dfa-k-in dfa (label-idx->dfa-k-idx n)))
+ (dfa-k-in dfa n))
(define (live-after n)
- (dfa-k-out dfa (label-idx->dfa-k-idx n)))
+ (dfa-k-out dfa n))
+ (define needs-slot
+ (bitvector->intset needs-slotv))
;; Walk backwards. At a call, compute the set of variables that
;; have allocated slots and are live before but not after. This
(($ $kargs names syms body)
(match (find-expression body)
((or ($ $call) ($ $callk))
- (let ((args (make-bitvector (bitvector-length needs-slotv) #f)))
- (bit-set*! args (live-before n) #t)
- (bit-set*! args (live-after n) #f)
- (bit-set*! args no-slot-needed #f)
- (if (bit-position #t args 0)
- (scan-for-hints (1- n) args)
+ (let* ((args (intset-subtract (live-before n) (live-after n)))
+ (args-needing-slots (intset-intersect args needs-slot)))
+ (if (intset-next args-needing-slots #f)
+ (scan-for-hints (1- n) args-needing-slots)
(scan-for-call (1- n)))))
(_ (scan-for-call (1- n)))))
(_ (scan-for-call (1- n))))))
;; are finished with the scan, we kill uses of the
;; terminator, but leave its definitions.
(match (find-expression body)
- ((or ($ $void) ($ $const) ($ $prim) ($ $fun)
+ ((or ($ $const) ($ $prim) ($ $closure)
($ $primcall) ($ $prompt)
;; If $values has more than one argument, it may
;; use a temporary, which would invalidate our
;; assumptions that slots not allocated are not
;; used.
($ $values (or () (_))))
- (let ((dead (make-bitvector (bitvector-length args) #f)))
- (bit-set*! dead (live-before n) #t)
- (bit-set*! dead (live-after n) #f)
- (bit-set*! dead no-slot-needed #f)
- (if (bit-position #t dead 0)
+ (let ((killed (intset-subtract (live-before n) (live-after n))))
+ (if (intset-next (intset-intersect killed needs-slot) #f)
(finish-hints n (live-before n) args)
(scan-for-hints (1- n) args))))
- ((or ($ $call) ($ $callk) ($ $values))
+ ((or ($ $call) ($ $callk) ($ $values) ($ $branch))
(finish-hints n (live-before n) args))))
;; Otherwise we kill uses of the block entry.
(_ (finish-hints n (live-before (1+ n)) args))))
;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
;; looking for calls.
(define (finish-hints n kill args)
- (bit-invert! args)
- (bit-set*! args kill #t)
- (bit-invert! args)
- (bit-set*! needs-hintv args #t)
+ (let ((new-hints (intset-subtract args kill)))
+ (let lp ((n 0))
+ (let ((n (intset-next new-hints n)))
+ (when n
+ (bitvector-set! needs-hintv n #t)
+ (lp (1+ n))))))
(scan-for-call n))
- (define no-slot-needed
- (make-bitvector (bitvector-length needs-slotv) #f))
-
- (bit-set*! no-slot-needed needs-slotv #t)
- (bit-invert! no-slot-needed)
(scan-for-call (1- label-count)))
(define (allocate-call label k uses pre-live post-live)
(compute-tmp-slot (logior pre-live result-live)
'()))))
(hashq-set! call-allocations label
- (make-call-allocation #f moves #f))))
- (($ $kif) #f)))
+ (make-call-allocation #f moves #f))))))
(define (allocate-prompt label k handler nargs)
(match (lookup-cont handler dfg)
;; definitions dominate uses and a block's dominator will appear
;; before it, in reverse post-order.
(define (visit-clause n nargs live)
- (let lp ((n n) (live live))
+ (let lp ((n n) (live (recompute-live-slots (idx->label n) nargs)))
(define (kill-dead live vars-by-label-idx pred)
(fold (lambda (v live)
(let ((slot (vector-ref slots v)))
- (if (and slot
- (> slot nargs)
- (pred (idx->label n) v dfa))
+ (if (and slot (pred n v dfa))
(kill-dead-slot slot live)
live)))
live
(match (lookup-cont (idx->label n) dfg)
(($ $kclause) n)
(($ $kargs names syms body)
+ (define (compute-k-live k)
+ (match (lookup-predecessors k dfg)
+ ((_) post-live)
+ (_ (recompute-live-slots k nargs))))
(let ((uses (vector-ref usev n)))
(match (find-call body)
(($ $continue k src (or ($ $call) ($ $callk)))
- (allocate-call label k uses live post-live))
+ (allocate-call label k uses live (compute-k-live k)))
(($ $continue k src ($ $primcall)) #t)
(($ $continue k src ($ $values))
- (allocate-values label k uses live post-live))
+ (allocate-values label k uses live (compute-k-live k)))
(($ $continue k src ($ $prompt escape? tag handler))
(allocate-prompt label k handler nargs))
(_ #f)))
(lp (1+ n) post-live))
- ((or ($ $kreceive) ($ $kif) ($ $ktail))
+ ((or ($ $kreceive) ($ $ktail))
(lp (1+ n) post-live)))))))
(define (visit-entry)
(error "Unexpected clause order"))))
(visit-clauses next live))))))
(match (lookup-cont (idx->label 0) dfg)
- (($ $kentry src meta self)
+ (($ $kfun src meta self)
(visit-clauses 1 (allocate-defs! 0 (empty-live-slots))))))
(compute-constants!)
HCoop / bpt / guile.git / blobdiff