mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Slot allocation and bytecode compilation from CPS2.

Browse source 
* module/language/cps2/compile-bytecode.scm: New file.
* module/language/cps2/slot-allocation.scm: New file.
* module/Makefile.am: Add new files.
This commit is contained in:
Andy Wingo 2015-07-22 17:01:19 +02:00
parent 16d92c566f
commit 910054bfbc
3 changed files with 1430 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/Makefile.am
View file

@ -134,6 +134,7 @@ CPS_LANG_SOURCES = \
CPS2_LANG_SOURCES = \
language/cps2.scm \
language/cps2/closure-conversion.scm \
language/cps2/compile-bytecode.scm \
language/cps2/compile-cps.scm \
language/cps2/constructors.scm \
language/cps2/contification.scm \
@ -148,6 +149,7 @@ CPS2_LANG_SOURCES = \
language/cps2/optimize.scm \
language/cps2/simplify.scm \
language/cps2/self-references.scm \
language/cps2/slot-allocation.scm \
language/cps2/spec.scm \
language/cps2/specialize-primcalls.scm \
language/cps2/split-rec.scm \

433
module/language/cps2/compile-bytecode.scm Normal file
View file

@ -0,0 +1,433 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; Compiling CPS to bytecode. The result is in the bytecode language,
;;; which happens to be an ELF image as a bytecode.
;;;
;;; Code:
(define-module (language cps2 compile-bytecode)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps2)
#:use-module (language cps primitives)
#:use-module (language cps2 slot-allocation)
#:use-module (language cps2 utils)
#:use-module (language cps2 closure-conversion)
#:use-module (language cps2 optimize)
#:use-module (language cps2 reify-primitives)
#:use-module (language cps2 renumber)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system vm assembler)
#:export (compile-bytecode))
(define (kw-arg-ref args kw default)
(match (memq kw args)
((_ val . _) val)
(_ default)))
(define (intmap-for-each f map)
(intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
(define (intmap-select map set)
(persistent-intmap
(intset-fold
(lambda (k out)
(intmap-add! out k (intmap-ref map k)))
set
empty-intmap)))
(define (compile-function cps asm)
(let ((allocation (allocate-slots cps))
(frame-size #f))
(define (maybe-slot sym)
(lookup-maybe-slot sym allocation))
(define (slot sym)
(lookup-slot sym allocation))
(define (constant sym)
(lookup-constant-value sym allocation))
(define (maybe-mov dst src)
(unless (= dst src)
(emit-mov asm dst src)))
(define (compile-tail label exp)
;; There are only three kinds of expressions in tail position:
;; tail calls, multiple-value returns, and single-value returns.
(match exp
(($ $call proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-tail-call asm (1+ (length args))))
(($ $callk k proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-tail-call-label asm (1+ (length args)) k))
(($ $values ())
(emit-reset-frame asm 1)
(emit-return-values asm))
(($ $values (arg))
(if (maybe-slot arg)
(emit-return asm (slot arg))
(begin
(emit-load-constant asm 1 (constant arg))
(emit-return asm 1))))
(($ $values args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-reset-frame asm (1+ (length args)))
(emit-return-values asm))
(($ $primcall 'return (arg))
(emit-return asm (slot arg)))))
(define (compile-value label exp dst)
(match exp
(($ $values (arg))
(maybe-mov dst (slot arg)))
(($ $const exp)
(emit-load-constant asm dst exp))
(($ $closure k 0)
(emit-load-static-procedure asm dst k))
(($ $closure k nfree)
(emit-make-closure asm dst k nfree))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-cached-toplevel-box asm dst (constant scope) (constant name)
(constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?))
(emit-cached-module-box asm dst (constant mod) (constant name)
(constant public?) (constant bound?)))
(($ $primcall 'resolve (name bound?))
(emit-resolve asm dst (constant bound?) (slot name)))
(($ $primcall 'free-ref (closure idx))
(emit-free-ref asm dst (slot closure) (constant idx)))
(($ $primcall 'vector-ref (vector index))
(emit-vector-ref asm dst (slot vector) (slot index)))
(($ $primcall 'make-vector (length init))
(emit-make-vector asm dst (slot length) (slot init)))
(($ $primcall 'make-vector/immediate (length init))
(emit-make-vector/immediate asm dst (constant length) (slot init)))
(($ $primcall 'vector-ref/immediate (vector index))
(emit-vector-ref/immediate asm dst (slot vector) (constant index)))
(($ $primcall 'allocate-struct (vtable nfields))
(emit-allocate-struct asm dst (slot vtable) (slot nfields)))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
(emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
(($ $primcall 'struct-ref (struct n))
(emit-struct-ref asm dst (slot struct) (slot n)))
(($ $primcall 'struct-ref/immediate (struct n))
(emit-struct-ref/immediate asm dst (slot struct) (constant n)))
(($ $primcall 'builtin-ref (name))
(emit-builtin-ref asm dst (constant name)))
(($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s8-ref (bv idx))
(emit-bv-s8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s16-ref (bv idx))
(emit-bv-s16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u32-ref (bv idx val))
(emit-bv-u32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s32-ref (bv idx val))
(emit-bv-s32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u64-ref (bv idx val))
(emit-bv-u64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s64-ref (bv idx val))
(emit-bv-s64-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f32-ref (bv idx val))
(emit-bv-f32-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-f64-ref (bv idx val))
(emit-bv-f64-ref asm dst (slot bv) (slot idx)))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name)))
(emit-text asm `((,inst ,dst ,@(map slot args))))))))
(define (compile-effect label exp k)
(match exp
(($ $values ()) #f)
(($ $prompt escape? tag handler)
(match (intmap-ref cps handler)
(($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation)))
(emit-prompt asm (slot tag) escape? proc-slot receive-args)
(emit-br asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
(emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
(match (intmap-ref cps khandler-body)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size)
(emit-br asm khandler-body)))))
(($ $primcall 'cache-current-module! (sym scope))
(emit-cache-current-module! asm (slot sym) (constant scope)))
(($ $primcall 'free-set! (closure idx value))
(emit-free-set! asm (slot closure) (slot value) (constant idx)))
(($ $primcall 'box-set! (box value))
(emit-box-set! asm (slot box) (slot value)))
(($ $primcall 'struct-set! (struct index value))
(emit-struct-set! asm (slot struct) (slot index) (slot value)))
(($ $primcall 'struct-set!/immediate (struct index value))
(emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
(($ $primcall 'vector-set! (vector index value))
(emit-vector-set! asm (slot vector) (slot index) (slot value)))
(($ $primcall 'vector-set!/immediate (vector index value))
(emit-vector-set!/immediate asm (slot vector) (constant index)
(slot value)))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(($ $primcall 'set-cdr! (pair value))
(emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value))
(emit-define! asm (slot sym) (slot value)))
(($ $primcall 'push-fluid (fluid val))
(emit-push-fluid asm (slot fluid) (slot val)))
(($ $primcall 'pop-fluid ())
(emit-pop-fluid asm))
(($ $primcall 'wind (winder unwinder))
(emit-wind asm (slot winder) (slot unwinder)))
(($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s8-set! (bv idx val))
(emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s16-set! (bv idx val))
(emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u32-set! (bv idx val))
(emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s32-set! (bv idx val))
(emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u64-set! (bv idx val))
(emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s64-set! (bv idx val))
(emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f32-set! (bv idx val))
(emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-f64-set! (bv idx val))
(emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'unwind ())
(emit-unwind asm))))
(define (compile-values label exp syms)
(match exp
(($ $values args)
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label)
(define (unary op sym)
(cond
((eq? kt next-label)
(op asm (slot sym) #t kf))
(else
(op asm (slot sym) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(define (binary op a b)
(cond
((eq? kt next-label)
(op asm (slot a) (slot b) #t kf))
(else
(op asm (slot a) (slot b) #f kt)
(unless (eq? kf next-label)
(emit-br asm kf)))))
(match exp
(($ $values (sym))
(call-with-values (lambda ()
(lookup-maybe-constant-value sym allocation))
(lambda (has-const? val)
(if has-const?
(if val
(unless (eq? kt next-label)
(emit-br asm kt))
(unless (eq? kf next-label)
(emit-br asm kf)))
(unary emit-br-if-true sym)))))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
(($ $primcall 'char? (a)) (unary emit-br-if-char a))
(($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
(($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
(($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
(($ $primcall 'string? (a)) (unary emit-br-if-string a))
(($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
(($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a))
(($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a))
;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm.
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
(($ $primcall '< (a b)) (binary emit-br-if-< a b))
(($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
(($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
(nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves label allocation))
(emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot
(lookup-dead-slot-map label allocation))
(cond
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
(match (lookup-parallel-moves k allocation)
((((? (lambda (src) (= src (1+ proc-slot))) src)
. dst)) dst)
(_ #f)))
;; The usual case: one required live return value, ignoring
;; any additional values.
=> (lambda (dst)
(emit-receive asm dst proc-slot frame-size)))
(else
(unless (and (zero? nreq) rest-var)
(emit-receive-values asm proc-slot (->bool rest-var) nreq))
(when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
((src . dst) (emit-mov asm dst src)))
(lookup-parallel-moves k allocation))
(emit-reset-frame asm frame-size)))))
(match exp
(($ $call proc args)
(do-call proc args
(lambda (asm proc-slot nargs)
(emit-call asm proc-slot nargs))))
(($ $callk k proc args)
(do-call proc args
(lambda (asm proc-slot nargs)
(emit-call-label asm proc-slot nargs k))))))
(define (compile-expression label k exp)
(let* ((fallthrough? (= k (1+ label))))
(define (maybe-emit-jump)
(unless fallthrough?
(emit-br asm k)))
(match (intmap-ref cps k)
(($ $ktail)
(compile-tail label exp))
(($ $kargs (name) (sym))
(let ((dst (maybe-slot sym)))
(when dst
(compile-value label exp dst)))
(maybe-emit-jump))
(($ $kargs () ())
(match exp
(($ $branch kt exp)
(compile-test label exp kt k (1+ label)))
(_
(compile-effect label exp k)
(maybe-emit-jump))))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
(($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req)
(and rest
(match (intmap-ref cps kargs)
(($ $kargs names (_ ... rest)) rest))))
(unless (and fallthrough? (= kargs (1+ k)))
(emit-br asm kargs))))))
(define (compile-cont label cont)
(match cont
(($ $kfun src meta self tail clause)
(when src
(emit-source asm src))
(emit-begin-program asm label meta))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt)
(let ((first? (match (intmap-ref cps (1- label))
(($ $kfun) #t)
(_ #f)))
(kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
kw)))
(unless first?
(emit-end-arity asm))
(emit-label asm label)
(set! frame-size (lookup-nlocals label allocation))
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
frame-size alt)))
(($ $kargs names vars ($ $continue k src exp))
(emit-label asm label)
(for-each (lambda (name var)
(let ((slot (maybe-slot var)))
(when slot
(emit-definition asm name slot))))
names vars)
(when src
(emit-source asm src))
(compile-expression label k exp))
(($ $kreceive arity kargs)
(emit-label asm label))
(($ $ktail)
(emit-end-arity asm)
(emit-end-program asm))))
(intmap-for-each compile-cont cps)))
(define (emit-bytecode exp env opts)
(let ((asm (make-assembler)))
(intmap-for-each (lambda (kfun body)
(compile-function (intmap-select exp body) asm))
(compute-reachable-functions exp 0))
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))
(define (lower-cps exp opts)
(set! exp (optimize-higher-order-cps exp opts))
(set! exp (convert-closures exp))
(set! exp (optimize-first-order-cps exp opts))
(set! exp (reify-primitives exp))
(renumber exp))
(define (compile-bytecode exp env opts)
(set! exp (lower-cps exp opts))
(emit-bytecode exp env opts))

995
module/language/cps2/slot-allocation.scm Normal file
View file

@ -0,0 +1,995 @@
;; Continuation-passing style (CPS) intermediate language (IL)
;; 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;;
;;; A module to assign stack slots to variables in a CPS term.
;;;
;;; Code:
(define-module (language cps2 slot-allocation)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (language cps2)
#:use-module (language cps2 utils)
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:export (allocate-slots
lookup-slot
lookup-maybe-slot
lookup-constant-value
lookup-maybe-constant-value
lookup-nlocals
lookup-call-proc-slot
lookup-parallel-moves
lookup-dead-slot-map))
(define-record-type $allocation
(make-allocation slots constant-values call-allocs shuffles frame-sizes)
allocation?
;; A map of VAR to slot allocation. A slot allocation is an integer,
;; if the variable has been assigned a slot.
;;
(slots allocation-slots)
;; A map of VAR to constant value, for variables with constant values.
;;
(constant-values allocation-constant-values)
;; A map of LABEL to /call allocs/, for expressions that continue to
;; $kreceive continuations: non-tail calls and $prompt expressions.
;;
;; A call alloc contains two pieces of information: the call's /proc
;; slot/ and a /dead slot map/. The proc slot indicates the slot of a
;; procedure in a procedure call, or where the procedure would be in a
;; multiple-value return.
;;
;; The dead slot map indicates, what slots should be ignored by GC
;; when marking the frame. A dead slot map is a bitfield, as an
;; integer.
;;
(call-allocs allocation-call-allocs)
;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals
;; into position for a $call, $callk, or $values, or shuffle returned
;; values back into place in a $kreceive.
;;
;; A set of moves is expressed as an ordered list of (SRC . DST)
;; moves, where SRC and DST are slots. This may involve a temporary
;; variable.
;;
(shuffles allocation-shuffles)
;; The number of locals for a $kclause.
;;
(frame-sizes allocation-frame-sizes))
(define-record-type $call-alloc
(make-call-alloc proc-slot dead-slot-map)
call-alloc?
(proc-slot call-alloc-proc-slot)
(dead-slot-map call-alloc-dead-slot-map))
(define (lookup-maybe-slot var allocation)
(intmap-ref (allocation-slots allocation) var (lambda (_) #f)))
(define (lookup-slot var allocation)
(intmap-ref (allocation-slots allocation) var))
(define *absent* (list 'absent))
(define (lookup-constant-value var allocation)
(let ((value (intmap-ref (allocation-constant-values allocation) var
(lambda (_) *absent*))))
(when (eq? value *absent*)
(error "Variable does not have constant value" var))
value))
(define (lookup-maybe-constant-value var allocation)
(let ((value (intmap-ref (allocation-constant-values allocation) var
(lambda (_) *absent*))))
(if (eq? value *absent*)
(values #f #f)
(values #t value))))
(define (lookup-call-alloc k allocation)
(intmap-ref (allocation-call-allocs allocation) k))
(define (lookup-call-proc-slot k allocation)
(or (call-alloc-proc-slot (lookup-call-alloc k allocation))
(error "Call has no proc slot" k)))
(define (lookup-parallel-moves k allocation)
(intmap-ref (allocation-shuffles allocation) k))
(define (lookup-dead-slot-map k allocation)
(or (call-alloc-dead-slot-map (lookup-call-alloc k allocation))
(error "Call has no dead slot map" k)))
(define (lookup-nlocals k allocation)
(intmap-ref (allocation-frame-sizes allocation) k))
(define (intset-pop set)
(match (intset-next set)
(#f (values set #f))
(i (values (intset-remove set i) i))))
(define (solve-flow-equations succs in out kill gen subtract add meet)
"Find a fixed point for flow equations for SUCCS, where IN and OUT are
the initial conditions as intmaps with one key for every node in SUCCS.
KILL and GEN are intmaps indicating the state that is killed or defined
at every node, and SUBTRACT, ADD, and MEET operates on that state."
(define (visit label in out)
(let* ((in-1 (intmap-ref in label))
(kill-1 (intmap-ref kill label))
(gen-1 (intmap-ref gen label))
(out-1 (intmap-ref out label))
(out-1* (add (subtract in-1 kill-1) gen-1)))
(if (eq? out-1 out-1*)
(values empty-intset in out)
(let ((out (intmap-replace! out label out-1*)))
(call-with-values
(lambda ()
(intset-fold (lambda (succ in changed)
(let* ((in-1 (intmap-ref in succ))
(in-1* (meet in-1 out-1*)))
(if (eq? in-1 in-1*)
(values in changed)
(values (intmap-replace! in succ in-1*)
(intset-add changed succ)))))
(intmap-ref succs label) in empty-intset))
(lambda (in changed)
(values changed in out)))))))
(let run ((worklist (intmap-keys succs)) (in in) (out out))
(call-with-values (lambda () (intset-pop worklist))
(lambda (worklist popped)
(if popped
(call-with-values (lambda () (visit popped in out))
(lambda (changed in out)
(run (intset-union worklist changed) in out)))
(values (persistent-intmap in)
(persistent-intmap out)))))))
(define-syntax-rule (persistent-intmap2 exp)
(call-with-values (lambda () exp)
(lambda (a b)
(values (persistent-intmap a) (persistent-intmap b)))))
(define (compute-defs-and-uses cps)
"Return two LABEL->VAR... maps indicating values defined at and used
by a label, respectively."
(define (vars->intset vars)
(fold (lambda (var set) (intset-add set var)) empty-intset vars))
(persistent-intmap2
(intmap-fold
(lambda (label cont defs uses)
(define (get-defs k)
(match (intmap-ref cps k)
(($ $kargs names vars) (vars->intset vars))
(_ empty-intset)))
(define (return d u)
(values (intmap-add! defs label d)
(intmap-add! uses label u)))
(match cont
(($ $kfun src meta self)
(return (intset self) empty-intset))
(($ $kargs _ _ ($ $continue k src exp))
(match exp
((or ($ $const) ($ $closure))
(return (get-defs k) empty-intset))
(($ $call proc args)
(return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $callk _ proc args)
(return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $primcall name args)
(return (get-defs k) (vars->intset args)))
(($ $branch kt ($ $primcall name args))
(return empty-intset (vars->intset args)))
(($ $branch kt ($ $values args))
(return empty-intset (vars->intset args)))
(($ $values args)
(return (get-defs k) (vars->intset args)))
(($ $prompt escape? tag handler)
(return empty-intset (intset tag)))))
(($ $kclause arity body alt)
(return (get-defs body) empty-intset))
(($ $kreceive arity kargs)
(return (get-defs kargs) empty-intset))
(($ $ktail)
(return empty-intset empty-intset))))
cps
empty-intmap
empty-intmap)))
(define (compute-reverse-control-flow-order preds)
"Return a LABEL->ORDER bijection where ORDER is a contiguous set of
integers starting from 0 and incrementing in sort order."
;; This is more involved than forward control flow because not all
;; live labels are reachable from the tail.
(persistent-intmap
(fold2 (lambda (component order n)
(intset-fold (lambda (label order n)
(values (intmap-add! order label n)
(1+ n)))
component order n))
(reverse (compute-sorted-strongly-connected-components preds))
empty-intmap 0)))
(define* (add-prompt-control-flow-edges conts succs #:key complete?)
"For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
body continuation in the prompt."
(define (intset-filter pred set)
(intset-fold (lambda (i set)
(if (pred i) set (intset-remove set i)))
set
set))
(define (intset-any pred set)
(intset-fold (lambda (i res)
(if (or res (pred i)) #t res))
set
#f))
(define (visit-prompt label handler succs)
;; FIXME: It isn't correct to use all continuations reachable from
;; the prompt, because that includes continuations outside the
;; prompt body. This point is moot if the handler's control flow
;; joins with the the body, as is usually but not always the case.
;;
;; One counter-example is when the handler contifies an infinite
;; loop; in that case we compute a too-large prompt body. This
;; error is currently innocuous, but we should fix it at some point.
;;
;; The fix is to end the body at the corresponding "pop" primcall,
;; if any.
(let ((body (intset-subtract (compute-function-body conts label)
(compute-function-body conts handler))))
(define (out-or-back-edge? label)
;; Most uses of visit-prompt-control-flow don't need every body
;; continuation, and would be happy getting called only for
;; continuations that postdominate the rest of the body. Unless
;; you pass #:complete? #t, we only invoke F on continuations
;; that can leave the body, or on back-edges in loops.
;;
;; You would think that looking for the final "pop" primcall
;; would be sufficient, but that is incorrect; it's possible for
;; a loop in the prompt body to be contified, and that loop need
;; not continue to the pop if it never terminates. The pop could
;; even be removed by DCE, in that case.
(intset-any (lambda (succ)
(or (not (intset-ref body succ))
(<= succ label)))
(intmap-ref succs label)))
(intset-fold (lambda (pred succs)
(intmap-replace succs pred handler intset-add))
(if complete? body (intset-filter out-or-back-edge? body))
succs)))
(intmap-fold
(lambda (label cont succs)
(match cont
(($ $kargs _ _
($ $continue _ _ ($ $prompt escape? tag handler)))
(visit-prompt label handler succs))
(_ succs)))
conts
succs))
(define (rename-keys map old->new)
(persistent-intmap
(intmap-fold (lambda (k v out)
(intmap-add! out (intmap-ref old->new k) v))
map
empty-intmap)))
(define (rename-intset set old->new)
(intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old)))
set empty-intset))
(define (rename-graph graph old->new)
(persistent-intmap
(intmap-fold (lambda (pred succs out)
(intmap-add! out
(intmap-ref old->new pred)
(rename-intset succs old->new)))
graph
empty-intmap)))
(define (compute-live-variables cps defs uses)
"Compute and return two values mapping LABEL->VAR..., where VAR... are
the definitions that are live before and after LABEL, as intsets."
(let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps)))
(preds (invert-graph succs))
(old->new (compute-reverse-control-flow-order preds)))
(call-with-values
(lambda ()
(let ((init (rename-keys
(intmap-map (lambda (k v) empty-intset) preds)
old->new)))
(solve-flow-equations (rename-graph preds old->new)
init init
(rename-keys defs old->new)
(rename-keys uses old->new)
intset-subtract intset-union intset-union)))
(lambda (in out)
;; As a reverse control-flow problem, the values flowing into a
;; node are actually the live values after the node executes.
;; Funny, innit? So we return them in the reverse order.
(let ((new->old (invert-bijection old->new)))
(values (rename-keys out new->old)
(rename-keys in new->old)))))))
(define (compute-needs-slot cps defs uses)
(define (get-defs k) (intmap-ref defs k))
(define (get-uses label) (intmap-ref uses label))
(intmap-fold
(lambda (label cont needs-slot)
(intset-union
needs-slot
(match cont
(($ $kargs _ _ ($ $continue k src exp))
(let ((defs (get-defs label)))
(define (defs+* uses)
(intset-union defs uses))
(define (defs+ use)
(intset-add defs use))
(match exp
(($ $const)
empty-intset)
(($ $primcall 'free-ref (closure slot))
(defs+ closure))
(($ $primcall 'free-set! (closure slot value))
(defs+* (intset closure value)))
(($ $primcall 'cache-current-module! (mod . _))
(defs+ mod))
(($ $primcall 'cached-toplevel-box _)
defs)
(($ $primcall 'cached-module-box _)
defs)
(($ $primcall 'resolve (name bound?))
(defs+ name))
(($ $primcall 'make-vector/immediate (len init))
(defs+ init))
(($ $primcall 'vector-ref/immediate (v i))
(defs+ v))
(($ $primcall 'vector-set!/immediate (v i x))
(defs+* (intset v x)))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
(defs+ vtable))
(($ $primcall 'struct-ref/immediate (s n))
(defs+ s))
(($ $primcall 'struct-set!/immediate (s n x))
(defs+* (intset s x)))
(($ $primcall 'builtin-ref (idx))
defs)
(_
(defs+* (get-uses label))))))
(($ $kreceive arity k)
;; Only allocate results of function calls to slots if they are
;; used.
empty-intset)
(($ $kclause arity body alternate)
(get-defs label))
(($ $kfun src meta self)
(intset self))
(($ $ktail)
empty-intset))))
cps
empty-intset))
(define (compute-lazy-vars cps live-in live-out defs needs-slot)
"Compute and return a set of vars whose allocation can be delayed
until their use is seen. These are \"lazy\" vars. A var is lazy if its
uses are calls, it is always dead after the calls, and if the uses flow
to the definition. A flow continues across a node iff the node kills no
values that need slots, and defines only lazy vars. Calls also kill
flows; there's no sense in trying to juggle a pending frame while there
is an active call."
(define (list->intset list)
(persistent-intset
(fold (lambda (i set) (intset-add! set i)) empty-intset list)))
(let* ((succs (compute-successors cps))
(gens (intmap-map
(lambda (label cont)
(match cont
(($ $kargs _ _ ($ $continue _ _ ($ $call proc args)))
(intset-subtract (intset-add (list->intset args) proc)
(intmap-ref live-out label)))
(($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args)))
(intset-subtract (intset-add (list->intset args) proc)
(intmap-ref live-out label)))
(_ #f)))
cps))
(kills (intmap-map
(lambda (label in)
(let* ((out (intmap-ref live-out label))
(killed (intset-subtract in out))
(killed-slots (intset-intersect killed needs-slot)))
(and (eq? killed-slots empty-intset)
;; Kill output variables that need slots.
(intset-intersect (intmap-ref defs label)
needs-slot))))
live-in))
(preds (invert-graph succs))
(old->new (compute-reverse-control-flow-order preds)))
(define (subtract lazy kill)
(cond
((eq? lazy empty-intset)
lazy)
((not kill)
empty-intset)
((and lazy (eq? empty-intset (intset-subtract kill lazy)))
(intset-subtract lazy kill))
(else
empty-intset)))
(define (add live gen) (or gen live))
(define (meet in out)
;; Initial in is #f.
(if in (intset-intersect in out) out))
(call-with-values
(lambda ()
(let ((succs (rename-graph preds old->new))
(in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new))
(out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new))
;(out (rename-keys gens old->new))
(kills (rename-keys kills old->new))
(gens (rename-keys gens old->new)))
(solve-flow-equations succs in out kills gens subtract add meet)))
(lambda (in out)
;; A variable is lazy if its uses reach its definition.
(intmap-fold (lambda (label out lazy)
(match (intmap-ref cps label)
(($ $kargs names vars)
(let ((defs (list->intset vars)))
(intset-union lazy (intset-intersect out defs))))
(_ lazy)))
(rename-keys out (invert-bijection old->new))
empty-intset)))))
(define (find-first-zero n)
;; Naive implementation.
(let lp ((slot 0))
(if (logbit? slot n)
(lp (1+ slot))
slot)))
(define (find-first-trailing-zero n)
(let lp ((slot (let lp ((count 2))
(if (< n (ash 1 (1- count)))
count
;; Grow upper bound slower than factor 2 to avoid
;; needless bignum allocation on 32-bit systems
;; when there are more than 16 locals.
(lp (+ count (ash count -1)))))))
(if (or (zero? slot) (logbit? (1- slot) n))
slot
(lp (1- slot)))))
(define (integers from count)
(if (zero? count)
'()
(cons from (integers (1+ from) (1- count)))))
(define (solve-parallel-move src dst tmp)
"Solve the parallel move problem between src and dst slot lists, which
are comparable with eqv?. A tmp slot may be used."
;; This algorithm is taken from: "Tilting at windmills with Coq:
;; formal verification of a compilation algorithm for parallel moves"
;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
(define (split-move moves reg)
(let loop ((revhead '()) (tail moves))
(match tail
(((and s+d (s . d)) . rest)
(if (eqv? s reg)
(cons d (append-reverse revhead rest))
(loop (cons s+d revhead) rest)))
(_ #f))))
(define (replace-last-source reg moves)
(match moves
((moves ... (s . d))
(append moves (list (cons reg d))))))
(let loop ((to-move (map cons src dst))
(being-moved '())
(moved '())
(last-source #f))
;; 'last-source' should always be equivalent to:
;; (and (pair? being-moved) (car (last being-moved)))
(match being-moved
(() (match to-move
(() (reverse moved))
(((and s+d (s . d)) . t1)
(if (or (eqv? s d) ; idempotent
(not s)) ; src is a constant and can be loaded directly
(loop t1 '() moved #f)
(loop t1 (list s+d) moved s)))))
(((and s+d (s . d)) . b)
(match (split-move to-move d)
((r . t1) (loop t1 (acons d r being-moved) moved last-source))
(#f (match b
(() (loop to-move '() (cons s+d moved) #f))
(_ (if (eqv? d last-source)
(loop to-move
(replace-last-source tmp b)
(cons s+d (acons d tmp moved))
tmp)
(loop to-move b (cons s+d moved) last-source))))))))))
(define (compute-shuffles cps slots call-allocs live-in)
(define (add-live-slot slot live-slots)
(logior live-slots (ash 1 slot)))
(define (get-cont label)
(intmap-ref cps label))
(define (get-slot var)
(intmap-ref slots var (lambda (_) #f)))
(define (get-slots vars)
(let lp ((vars vars))
(match vars
((var . vars) (cons (get-slot var) (lp vars)))
(_ '()))))
(define (get-proc-slot label)
(call-alloc-proc-slot (intmap-ref call-allocs label)))
(define (compute-live-slots label)
(intset-fold (lambda (var live)
(match (get-slot var)
(#f live)
(slot (add-live-slot slot live))))
(intmap-ref live-in label)
0))
;; Although some parallel moves may proceed without a temporary slot,
;; in general one is needed. That temporary slot must not be part of
;; the source or destination sets, and that slot should not correspond
;; to a live variable. Usually the source and destination sets are a
;; subset of the union of the live sets before and after the move.
;; However for stack slots that don't have names -- those slots that
;; correspond to function arguments 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)))
(define (parallel-move src-slots dst-slots tmp-slot)
(solve-parallel-move src-slots dst-slots tmp-slot))
(define (compute-receive-shuffles label proc-slot)
(match (get-cont label)
(($ $kreceive arity kargs)
(let* ((results (match (get-cont kargs)
(($ $kargs names vars) vars)))
(value-slots (integers (1+ proc-slot) (length results)))
(result-slots (get-slots results))
;; Filter out unused results.
(value-slots (filter-map (lambda (val result) (and result val))
value-slots result-slots))
(result-slots (filter (lambda (x) x) result-slots))
(live (compute-live-slots kargs)))
(parallel-move value-slots
result-slots
(compute-tmp-slot live value-slots))))))
(define (add-call-shuffles label k args shuffles)
(match (get-cont k)
(($ $ktail)
(let* ((live (compute-live-slots label))
(tail-slots (integers 0 (length args)))
(moves (parallel-move (get-slots args)
tail-slots
(compute-tmp-slot live tail-slots))))
(intmap-add! shuffles label moves)))
(($ $kreceive)
(let* ((live (compute-live-slots label))
(proc-slot (get-proc-slot label))
(call-slots (integers proc-slot (length args)))
(arg-moves (parallel-move (get-slots args)
call-slots
(compute-tmp-slot live call-slots))))
(intmap-add! (intmap-add! shuffles label arg-moves)
k (compute-receive-shuffles k proc-slot))))))
(define (add-values-shuffles label k args shuffles)
(match (get-cont k)
(($ $ktail)
(let* ((live (compute-live-slots label))
(src-slots (get-slots args))
(dst-slots (integers 1 (length args)))
(moves (parallel-move src-slots dst-slots
(compute-tmp-slot live dst-slots))))
(intmap-add! shuffles label moves)))
(($ $kargs _ dst-vars)
(let* ((live (logior (compute-live-slots label)
(compute-live-slots k)))
(src-slots (get-slots args))
(dst-slots (get-slots dst-vars))
(moves (parallel-move src-slots dst-slots
(compute-tmp-slot live '()))))
(intmap-add! shuffles label moves)))))
(define (add-prompt-shuffles label k handler shuffles)
(intmap-add! shuffles handler
(compute-receive-shuffles handler (get-proc-slot label))))
(define (compute-shuffles label cont shuffles)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $call proc args)
(add-call-shuffles label k (cons proc args) shuffles))
(($ $callk _ proc args)
(add-call-shuffles label k (cons proc args) shuffles))
(($ $values args)
(add-values-shuffles label k args shuffles))
(($ $prompt escape? tag handler)
(add-prompt-shuffles label k handler shuffles))
(_ shuffles)))
(_ shuffles)))
(persistent-intmap
(intmap-fold compute-shuffles cps empty-intmap)))
(define (compute-frame-sizes cps slots call-allocs shuffles)
;; Minimum frame has one slot: the closure.
(define minimum-frame-size 1)
(define (get-shuffles label)
(intmap-ref shuffles label))
(define (get-proc-slot label)
(match (intmap-ref call-allocs label (lambda (_) #f))
(#f 0) ;; Tail call.
(($ $call-alloc proc-slot) proc-slot)))
(define (max-size var size)
(match (intmap-ref slots var (lambda (_) #f))
(#f size)
(slot (max size (1+ slot)))))
(define (max-size* vars size)
(fold max-size size vars))
(define (shuffle-size moves size)
(match moves
(() size)
(((src . dst) . moves)
(shuffle-size moves (max size (1+ src) (1+ dst))))))
(define (call-size label nargs size)
(shuffle-size (get-shuffles label)
(max (+ (get-proc-slot label) nargs) size)))
(define (measure-cont label cont frame-sizes clause size)
(match cont
(($ $kfun)
(values #f #f #f))
(($ $kclause)
(let ((frame-sizes (if clause
(intmap-add! frame-sizes clause size)
empty-intmap)))
(values frame-sizes label minimum-frame-size)))
(($ $kargs names vars ($ $continue k src exp))
(values frame-sizes clause
(let ((size (max-size* vars size)))
(match exp
(($ $call proc args)
(call-size label (1+ (length args)) size))
(($ $callk _ proc args)
(call-size label (1+ (length args)) size))
(($ $values args)
(shuffle-size (get-shuffles label) size))
(_ size)))))
(($ $kreceive)
(values frame-sizes clause
(shuffle-size (get-shuffles label) size)))
(($ $ktail)
(values (intmap-add! frame-sizes clause size) #f #f))))
(persistent-intmap (intmap-fold measure-cont cps #f #f #f)))
(define (allocate-args cps)
(intmap-fold (lambda (label cont slots)
(match cont
(($ $kfun src meta self)
(intmap-add! slots self 0))
(($ $kclause arity body alt)
(match (intmap-ref cps body)
(($ $kargs names vars)
(let lp ((vars vars) (slots slots) (n 1))
(match vars
(() slots)
((var . vars)
(let ((n (if (<= 253 n 255) 256 n)))
(lp vars
(intmap-add! slots var n)
(1+ n)))))))))
(_ slots)))
cps empty-intmap))
(define-inlinable (add-live-slot slot live-slots)
(logior live-slots (ash 1 slot)))
(define-inlinable (kill-dead-slot slot live-slots)
(logand live-slots (lognot (ash 1 slot))))
(define-inlinable (compute-slot live-slots hint)
;; 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
(let ((slot (find-first-zero live-slots)))
(if (or (< slot 253) (> slot 255))
slot
(+ 256 (find-first-zero (ash live-slots -256)))))))
(define (allocate-lazy-vars cps slots call-allocs live-in lazy)
(define (compute-live-slots slots label)
(intset-fold (lambda (var live)
(match (intmap-ref slots var (lambda (_) #f))
(#f live)
(slot (add-live-slot slot live))))
(intmap-ref live-in label)
0))
(define (allocate var hint slots live)
(match (and hint (intmap-ref slots var (lambda (_) #f)))
(#f (if (intset-ref lazy var)
(let ((slot (compute-slot live hint)))
(values (intmap-add! slots var slot)
(add-live-slot slot live)))
(values slots live)))
(slot (values slots (add-live-slot slot live)))))
(define (allocate* vars hints slots live)
(match (vector vars hints)
(#(() ()) slots)
(#((var . vars) (hint . hints))
(let-values (((slots live) (allocate var hint slots live)))
(allocate* vars hints slots live)))))
(define (get-proc-slot label)
(match (intmap-ref call-allocs label (lambda (_) #f))
(#f 0)
(call (call-alloc-proc-slot call))))
(define (allocate-call label args slots)
(allocate* args (integers (get-proc-slot label) (length args))
slots (compute-live-slots slots label)))
(define (allocate-values label k args slots)
(match (intmap-ref cps k)
(($ $ktail)
(allocate* args (integers 1 (length args))
slots (compute-live-slots slots label)))
(($ $kargs names vars)
(allocate* args
(map (cut intmap-ref slots <> (lambda (_) #f)) vars)
slots (compute-live-slots slots label)))))
(define (allocate-lazy label cont slots)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(match exp
(($ $call proc args)
(allocate-call label (cons proc args) slots))
(($ $callk _ proc args)
(allocate-call label (cons proc args) slots))
(($ $values args)
(allocate-values label k args slots))
(_ slots)))
(_
slots)))
;; Sweep right to left to visit uses before definitions.
(persistent-intmap
(intmap-fold-right allocate-lazy cps slots)))
(define (allocate-slots cps)
(let*-values (((defs uses) (compute-defs-and-uses cps))
((live-in live-out) (compute-live-variables cps defs uses))
((constants) (compute-constant-values cps))
((needs-slot) (compute-needs-slot cps defs uses))
((lazy) (compute-lazy-vars cps live-in live-out defs
needs-slot)))
(define (empty-live-slots)
#b0)
(define (compute-call-proc-slot live-slots)
(+ 2 (find-first-trailing-zero live-slots)))
(define (compute-prompt-handler-proc-slot live-slots)
(if (zero? live-slots)
0
(1- (find-first-trailing-zero live-slots))))
(define (get-cont label)
(intmap-ref cps label))
(define (get-slot slots var)
(intmap-ref slots var (lambda (_) #f)))
(define (get-slots slots vars)
(let lp ((vars vars))
(match vars
((var . vars) (cons (get-slot slots var) (lp vars)))
(_ '()))))
(define (compute-live-slots* slots label live-vars)
(intset-fold (lambda (var live)
(match (get-slot slots var)
(#f live)
(slot (add-live-slot slot live))))
(intmap-ref live-vars label)
0))
(define (compute-live-in-slots slots label)
(compute-live-slots* slots label live-in))
(define (compute-live-out-slots slots label)
(compute-live-slots* slots label live-out))
(define (allocate var hint slots live)
(cond
((not (intset-ref needs-slot var))
(values slots live))
((get-slot slots var)
=> (lambda (slot)
(values slots (add-live-slot slot live))))
((and (not hint) (intset-ref lazy var))
(values slots live))
(else
(let ((slot (compute-slot live hint)))
(values (intmap-add! slots var slot)
(add-live-slot slot live))))))
(define (allocate* vars hints slots live)
(match (vector vars hints)
(#(() ()) (values slots live))
(#((var . vars) (hint . hints))
(call-with-values (lambda () (allocate var hint slots live))
(lambda (slots live)
(allocate* vars hints slots live))))))
(define (allocate-defs label vars slots)
(let ((live (compute-live-in-slots slots label))
(live-vars (intmap-ref live-in label)))
(let lp ((vars vars) (slots slots) (live live))
(match vars
(() (values slots live))
((var . vars)
(call-with-values (lambda () (allocate var #f slots live))
(lambda (slots live)
(lp vars slots
(let ((slot (get-slot slots var)))
(if (and slot (not (intset-ref live-vars var)))
(kill-dead-slot slot live)
live))))))))))
;; PRE-LIVE are the live slots coming into the term. POST-LIVE
;; is the subset of PRE-LIVE that is still live after the term
;; uses its inputs.
(define (allocate-call label k args slots call-allocs pre-live)
(match (get-cont k)
(($ $ktail)
(let ((tail-slots (integers 0 (length args))))
(values (allocate* args tail-slots slots pre-live)
call-allocs)))
(($ $kreceive arity kargs)
(let*-values
(((post-live) (compute-live-out-slots slots label))
((proc-slot) (compute-call-proc-slot post-live))
((call-slots) (integers proc-slot (length args)))
((slots pre-live) (allocate* args call-slots slots pre-live))
;; Allow the first result to be hinted by its use, but
;; hint the remaining results to stay in place. This
;; strikes a balance between avoiding shuffling,
;; especially for unused extra values, and avoiding frame
;; size growth due to sparse locals.
((slots result-live)
(match (get-cont kargs)
(($ $kargs () ())
(values slots post-live))
(($ $kargs (_ . _) (_ . results))
(let ((result-slots (integers (+ proc-slot 2)
(length results))))
(allocate* results result-slots slots post-live)))))
((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
(lognot post-live)))
((call) (make-call-alloc proc-slot dead-slot-map)))
(values slots
(intmap-add! call-allocs label call))))))
(define (allocate-values label k args slots call-allocs)
(match (get-cont k)
(($ $ktail)
(values slots call-allocs))
(($ $kargs (_) (dst))
;; When there is only one value in play, we allow the dst to be
;; hinted (see compute-lazy-vars). If the src doesn't have a
;; slot, then the actual slot for the dst would end up being
;; decided by the call that args it. Because we don't know the
;; slot, we can't really compute the parallel moves in that
;; case, so just bail and rely on the bytecode emitter to
;; handle the one-value case specially.
(match args
((src)
(let ((post-live (compute-live-out-slots slots label)))
(values (allocate dst (get-slot slots src) slots post-live)
call-allocs)))))
(($ $kargs _ dst-vars)
(let ((src-slots (get-slots slots args))
(post-live (compute-live-out-slots slots label)))
(values (allocate* dst-vars src-slots slots post-live)
call-allocs)))))
(define (allocate-prompt label k handler slots call-allocs)
(match (get-cont handler)
(($ $kreceive arity kargs)
(let*-values
(((handler-live) (compute-live-in-slots slots handler))
((proc-slot) (compute-prompt-handler-proc-slot handler-live))
((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
(lognot handler-live)))
((result-vars) (match (get-cont kargs)
(($ $kargs names vars) vars)))
((value-slots) (integers (1+ proc-slot) (length result-vars)))
((slots result-live) (allocate* result-vars value-slots
slots handler-live)))
(values slots
(intmap-add! call-allocs label
(make-call-alloc proc-slot dead-slot-map)))))))
(define (allocate-cont label cont slots call-allocs)
(match cont
(($ $kargs names vars ($ $continue k src exp))
(let-values (((slots live) (allocate-defs label vars slots)))
(match exp
(($ $call proc args)
(allocate-call label k (cons proc args) slots call-allocs live))
(($ $callk _ proc args)
(allocate-call label k (cons proc args) slots call-allocs live))
(($ $values args)
(allocate-values label k args slots call-allocs))
(($ $prompt escape? tag handler)
(allocate-prompt label k handler slots call-allocs))
(_
(values slots call-allocs)))))
(_
(values slots call-allocs))))
(call-with-values (lambda ()
(let ((slots (allocate-args cps)))
(intmap-fold allocate-cont cps slots empty-intmap)))
(lambda (slots calls)
(let* ((slots (allocate-lazy-vars cps slots calls live-in lazy))
(shuffles (compute-shuffles cps slots calls live-in))
(frame-sizes (compute-frame-sizes cps slots calls shuffles)))
(make-allocation slots constants calls shuffles frame-sizes))))))