mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 04:40:29 +02:00
9514dc7b95
* libguile/vm-engine.c (ursh/immediate, ulsh/immediate): New ops. * module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations) (compute-needs-slot): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/compile-bytecode.scm (compile-function): * module/system/vm/assembler.scm: * module/language/cps/types.scm: Add support for new ops, and specialize ursh and ulsh.
1038 lines
41 KiB
Scheme
1038 lines
41 KiB
Scheme
;; 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 cps 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 cps)
|
|
#:use-module (language cps utils)
|
|
#:use-module (language cps intmap)
|
|
#:use-module (language cps intset)
|
|
#:export (allocate-slots
|
|
lookup-slot
|
|
lookup-maybe-slot
|
|
lookup-representation
|
|
lookup-constant-value
|
|
lookup-maybe-constant-value
|
|
lookup-nlocals
|
|
lookup-call-proc-slot
|
|
lookup-parallel-moves
|
|
lookup-slot-map))
|
|
|
|
(define-record-type $allocation
|
|
(make-allocation slots representations 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 representation. A representation is 'scm, 'f64,
|
|
;; 'u64, or 's64.
|
|
;;
|
|
(representations allocation-representations)
|
|
|
|
;; 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 slot-map)
|
|
call-alloc?
|
|
(proc-slot call-alloc-proc-slot)
|
|
(slot-map call-alloc-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 (lookup-representation var allocation)
|
|
(intmap-ref (allocation-representations 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-slot-map k allocation)
|
|
(or (call-alloc-slot-map (lookup-call-alloc k allocation))
|
|
(error "Call has no slot map" k)))
|
|
|
|
(define (lookup-nlocals k allocation)
|
|
(intmap-ref (allocation-frame-sizes allocation) k))
|
|
|
|
(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))
|
|
(init (persistent-intmap (intmap-fold
|
|
(lambda (old new init)
|
|
(intmap-add! init new empty-intset))
|
|
old->new empty-intmap))))
|
|
(call-with-values
|
|
(lambda ()
|
|
(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 (or 'load-f64 'load-u64 'load-s64) (val))
|
|
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 (or 'add/immediate 'sub/immediate
|
|
'uadd/immediate 'usub/immediate 'umul/immediate
|
|
'ursh/immediate 'ulsh/immediate)
|
|
(x y))
|
|
(defs+ 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)))
|
|
(($ $kargs _ _ ($ $continue k _($ $values args)))
|
|
(match (intmap-ref cps k)
|
|
(($ $ktail) (list->intset args))
|
|
(_ #f)))
|
|
(_ #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))
|
|
(init (persistent-intmap
|
|
(intmap-fold
|
|
(lambda (old new in)
|
|
(intmap-add! in new #f))
|
|
old->new empty-intmap)))
|
|
(kills (rename-keys kills old->new))
|
|
(gens (rename-keys gens old->new)))
|
|
(solve-flow-equations succs init init 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.
|
|
(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)
|
|
(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)
|
|
(if (and hint (not (logbit? hint live-slots)))
|
|
hint
|
|
(find-first-zero live-slots)))
|
|
|
|
(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 (compute-var-representations cps)
|
|
(define (get-defs k)
|
|
(match (intmap-ref cps k)
|
|
(($ $kargs names vars) vars)
|
|
(_ '())))
|
|
(intmap-fold
|
|
(lambda (label cont representations)
|
|
(match cont
|
|
(($ $kargs _ _ ($ $continue k _ exp))
|
|
(match (get-defs k)
|
|
(() representations)
|
|
((var)
|
|
(match exp
|
|
(($ $values (arg))
|
|
(intmap-add representations var
|
|
(intmap-ref representations arg)))
|
|
(($ $primcall (or 'scm->f64 'load-f64
|
|
'bv-f32-ref 'bv-f64-ref
|
|
'fadd 'fsub 'fmul 'fdiv))
|
|
(intmap-add representations var 'f64))
|
|
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
|
|
'bv-length 'vector-length 'string-length
|
|
'uadd 'usub 'umul
|
|
'ulogand 'ulogior 'ulogsub 'ursh 'ulsh
|
|
'uadd/immediate 'usub/immediate 'umul/immediate
|
|
'ursh/immediate 'ulsh/immediate
|
|
'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref))
|
|
(intmap-add representations var 'u64))
|
|
(($ $primcall (or 'scm->s64 'load-s64
|
|
'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref))
|
|
(intmap-add representations var 's64))
|
|
(_
|
|
(intmap-add representations var 'scm))))
|
|
(vars
|
|
(match exp
|
|
(($ $values args)
|
|
(fold (lambda (arg var representations)
|
|
(intmap-add representations var
|
|
(intmap-ref representations arg)))
|
|
representations args vars))))))
|
|
(($ $kfun src meta self)
|
|
(intmap-add representations self 'scm))
|
|
(($ $kclause arity body alt)
|
|
(fold1 (lambda (var representations)
|
|
(intmap-add representations var 'scm))
|
|
(get-defs body) representations))
|
|
(($ $kreceive arity kargs)
|
|
(fold1 (lambda (var representations)
|
|
(intmap-add representations var 'scm))
|
|
(get-defs kargs) representations))
|
|
(($ $ktail) representations)))
|
|
cps
|
|
empty-intmap))
|
|
|
|
(define (allocate-slots cps)
|
|
(let*-values (((defs uses) (compute-defs-and-uses cps))
|
|
((representations) (compute-var-representations 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 slot-desc-dead 0)
|
|
(define slot-desc-live-raw 1)
|
|
(define slot-desc-live-scm 2)
|
|
(define slot-desc-unused 3)
|
|
|
|
(define (compute-slot-map slots live-vars nslots)
|
|
(intset-fold
|
|
(lambda (var slot-map)
|
|
(match (get-slot slots var)
|
|
(#f slot-map)
|
|
(slot
|
|
(let ((desc (match (intmap-ref representations var)
|
|
((or 'u64 'f64 's64) slot-desc-live-raw)
|
|
('scm slot-desc-live-scm))))
|
|
(logior slot-map (ash desc (* 2 slot)))))))
|
|
live-vars 0))
|
|
|
|
(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)))))
|
|
((slot-map) (compute-slot-map slots (intmap-ref live-out label)
|
|
(- proc-slot 2)))
|
|
((call) (make-call-alloc proc-slot 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))
|
|
((slot-map) (compute-slot-map slots (intmap-ref live-in handler)
|
|
(- proc-slot 2)))
|
|
((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 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 representations constants calls
|
|
shuffles frame-sizes))))))
|