[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 10/13: Slot allocation and bytecode compilation from CPS
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 10/13: Slot allocation and bytecode compilation from CPS2. |
|
Date: |
Wed, 22 Jul 2015 15:32:29 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 910054bfbc628843235db3a9d315986280f09bcd
Author: Andy Wingo <address@hidden>
Date: Wed Jul 22 17:01:19 2015 +0200
Slot allocation and bytecode compilation from CPS2.
* module/language/cps2/compile-bytecode.scm: New file.
* module/language/cps2/slot-allocation.scm: New file.
* module/Makefile.am: Add new files.
---
module/Makefile.am | 2 +
module/language/cps2/compile-bytecode.scm | 433 +++++++++++++
module/language/cps2/slot-allocation.scm | 995 +++++++++++++++++++++++++++++
3 files changed, 1430 insertions(+), 0 deletions(-)
diff --git a/module/Makefile.am b/module/Makefile.am
index c1c3e5c..801f466 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -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 \
diff --git a/module/language/cps2/compile-bytecode.scm
b/module/language/cps2/compile-bytecode.scm
new file mode 100644
index 0000000..a39c9f2
--- /dev/null
+++ b/module/language/cps2/compile-bytecode.scm
@@ -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))
diff --git a/module/language/cps2/slot-allocation.scm
b/module/language/cps2/slot-allocation.scm
new file mode 100644
index 0000000..48f5a1f
--- /dev/null
+++ b/module/language/cps2/slot-allocation.scm
@@ -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))))))
- [Guile-commits] 04/13: CPS1 slot-allocation simplification, (continued)
- [Guile-commits] 04/13: CPS1 slot-allocation simplification, Andy Wingo, 2015/07/22
- [Guile-commits] 05/13: More slot-allocation simplification, Andy Wingo, 2015/07/22
- [Guile-commits] 03/13: Utils refactors, Andy Wingo, 2015/07/22
- [Guile-commits] 07/13: Fix bad return shuffles for multiply-used $kreceive conts, Andy Wingo, 2015/07/22
- [Guile-commits] 01/13: Reify primitives in CPS2, Andy Wingo, 2015/07/22
- [Guile-commits] 09/13: Fix CPS2 compute-successors, Andy Wingo, 2015/07/22
- [Guile-commits] 06/13: Fix error printing some wrong-num-args backtraces, Andy Wingo, 2015/07/22
- [Guile-commits] 02/13: Add intset-prev and intset-fold-right, Andy Wingo, 2015/07/22
- [Guile-commits] 11/13: Compile CPS2 directly to bytecode, Andy Wingo, 2015/07/22
- [Guile-commits] 08/13: intset-intersect bugfix, Andy Wingo, 2015/07/22
- [Guile-commits] 10/13: Slot allocation and bytecode compilation from CPS2.,
Andy Wingo <=
- [Guile-commits] 12/13: Remove CPS1 language, Andy Wingo, 2015/07/22
- [Guile-commits] 13/13: Rename CPS2 to CPS, Andy Wingo, 2015/07/22