suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: make interp layer safe-for-space

Browse Source 
Fix the fallback interpreter (which is used for the "outside" of a
module that is too big to compile) so that it's safe-for-space.

This change is unlikely to repair any immediate problems, but space
safety problems are difficult to detect and avoid when the underling
implementation is not safe-for-space so fixing the interpreter is
likely worthwhie in the long run.
This commit is contained in:
Matthew Flatt 2018-12-01 16:49:10 -07:00
parent 74abc61f03
commit 37929f2191
9 changed files with 945 additions and 332 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
racket/src/cs/Makefile
View File

@ -13,9 +13,6 @@ COMPRESS_COMP = # --compress
# Controls whether Racket layers are built with expression-level debugging:
DEBUG_COMP = # --debug
# Controls whether Rumble is built as unsafe:
RUMBLE_UNSAFE_COMP = --unsafe
COMPILE_FILE = $(SCHEME) --script compile-file.ss $(UNSAFE_COMP) $(COMPRESS_COMP) $(DEBUG_COMP) --dest "$(BUILDDIR)"
COMPILE_FILE_DEPS = compile-file.ss include.ss place-register.ss
@ -285,7 +282,7 @@ RUMBLE_SRCS = rumble/define.ss \
../racket/src/schvers.h
$(BUILDDIR)rumble.so: $(RUMBLE_DEPS) rumble.sls $(RUMBLE_SRCS) $(COMPILE_FILE_DEPS)
$(COMPILE_FILE) $(RUMBLE_UNSAFE_COMP) rumble.sls $(RUMBLE_DEPS)
$(COMPILE_FILE) rumble.sls $(RUMBLE_DEPS)
$(BUILDDIR)chezpart.so: chezpart.sls $(COMPILE_FILE_DEPS)
$(COMPILE_FILE) chezpart.sls

15
racket/src/cs/README.txt
View File

@ -137,7 +137,8 @@ Racket-on-Chez currently supports two compilation modes:
Set `PLT_CS_COMPILE_LIMIT` to set the maximum size of forms to
compile before falling back to interpreted "bytecode". The default
is 10000.
is 10000. Setting `PLT_CS_COMPILE_LIMIT` to 0 effectively turns
the implementation into a pure interpreter.
* JIT mode --- The compiled form of a module is an S-expression where
individual `lambda`s are compiled on demand.
@ -485,17 +486,9 @@ configuration:
* `UNSAFE_COMP` is enabled in "Makefile" --- currently on by default.
Effectiveness: Matters the most for "rumble.so", which has its own
setting, but otherwise by itself affects a from-source
`racket/base` expansion by about 5%. See also the interaction with
`compile-as-independent?`.
* `RUMBLE_UNSAFE_COMP` is enabled in "Makefile" --- applies to
"rumble.so" even if `UNSAFE_COMP` is disabled.
Effectiveness: Can mean a 10-20% improvement in loading
`racket/base` from source. Since the Rumble implementation is in
pretty good shape, `RUMBLE_UNSAFE_COMP` is enabled by default.
`racket/base` from source. Since the implementation is in pretty
good shape, `UNSAFE_COMP` is enabled by default.
* `compile-as-independent?` is #f in "expander.sls" --- currently set
to #f by default. See "Development Mode" above for more

24
racket/src/cs/rumble/error.ss
View File

@ -310,6 +310,18 @@
upper-bound
#f)]))
(define (arguments->context-string args)
(cond
[(null? args) ""]
[else
(apply string-append
"\n arguments...: "
(let loop ([args args])
(cond
[(null? args) '()]
[else (cons (string-append "\n " (error-value->string (car args)))
(loop (cdr args)))])))]))
(define/who (raise-arity-error name arity . args)
(check who (lambda (p) (or (symbol? name) (procedure? name)))
:contract "(or/c symbol? procedure?)"
@ -328,9 +340,11 @@
"arity mismatch;\n"
" the expected number of arguments does not match the given number\n"
(expected-arity-string arity)
" given: " (number->string (length args)))
" given: " (number->string (length args))
(arguments->context-string args))
(current-continuation-marks))))
(define/who (raise-arity-mask-error name mask . args)
(check who (lambda (p) (or (symbol? name) (procedure? name)))
:contract "(or/c symbol? procedure?)"
@ -361,11 +375,15 @@
" expected number of values not received\n"
" received: " (number->string (length args)) "\n"
" expected: " (number->string num-expected-args)
(or where ""))
(or where "")
(arguments->context-string args))
(current-continuation-marks))))
(define (raise-binding-result-arity-error expected-args args)
(raise-result-arity-error #f (length expected-args) "\n at: local-binding form" args))
(apply raise-result-arity-error #f
(length expected-args)
"\n at: local-binding form"
args))
(define raise-unsupported-error
(case-lambda

5
racket/src/cs/rumble/intmap.ss
View File

@ -219,7 +219,10 @@
[x4 (fxior x3 (fxsrl x3 4))]
[x5 (fxior x4 (fxsrl x4 8))]
[x6 (fxior x5 (fxsrl x5 16))]
[x7 (fxior x6 (fxsrl x6 32))])
[x7 (meta-cond
[(> (fixnum-width) 32)
(fxior x6 (fxsrl x6 32))]
[else x6])])
(fxxor x7 (fxsrl x7 1))))
;; basic utils

154
racket/src/cs/rumble/unsafe.ss
View File

@ -1,92 +1,98 @@
(define unsafe-car #3%car)
(define unsafe-cdr #3%cdr)
(define unsafe-list-tail #3%list-tail)
(define unsafe-list-ref #3%list-ref)
;; Sometimes helpful for debugging: flip #t to #f to make
;; some unsafe primitives safe.
(meta-cond
[#t (define-syntax-rule (unsafe-primitive id) #3%id)]
[else (define-syntax-rule (unsafe-primitive id) id)])
(define unsafe-char=? #3%char=?)
(define unsafe-char<? #3%char<?)
(define unsafe-char>? #3%char>?)
(define unsafe-char>=? #3%char>=?)
(define unsafe-char<=? #3%char<=?)
(define unsafe-char->integer #3%char->integer)
(define unsafe-car (unsafe-primitive car))
(define unsafe-cdr (unsafe-primitive cdr))
(define unsafe-list-tail (unsafe-primitive list-tail))
(define unsafe-list-ref (unsafe-primitive list-ref))
(define unsafe-fx+ #3%fx+)
(define unsafe-fx- #3%fx-)
(define unsafe-fx* #3%fx*)
(define unsafe-fxquotient #3%fxquotient)
(define unsafe-fxremainder #3%fxremainder)
(define unsafe-fxmodulo #3%fxmodulo)
(define unsafe-fxabs #3%fxabs)
(define unsafe-fxand #3%fxand)
(define unsafe-fxior #3%fxior)
(define unsafe-fxxor #3%fxxor)
(define unsafe-fxnot #3%fxnot)
(define unsafe-fxrshift #3%fxarithmetic-shift-right)
(define unsafe-fxlshift #3%fxarithmetic-shift-left)
(define unsafe-char=? (unsafe-primitive char=?))
(define unsafe-char<? (unsafe-primitive char<?))
(define unsafe-char>? (unsafe-primitive char>?))
(define unsafe-char>=? (unsafe-primitive char>=?))
(define unsafe-char<=? (unsafe-primitive char<=?))
(define unsafe-char->integer (unsafe-primitive char->integer))
(define unsafe-fx= #3%fx=)
(define unsafe-fx< #3%fx<)
(define unsafe-fx> #3%fx>)
(define unsafe-fx>= #3%fx>=)
(define unsafe-fx<= #3%fx<=)
(define unsafe-fxmin #3%fxmin)
(define unsafe-fxmax #3%fxmax)
(define unsafe-fx+ (unsafe-primitive fx+))
(define unsafe-fx- (unsafe-primitive fx-))
(define unsafe-fx* (unsafe-primitive fx*))
(define unsafe-fxquotient (unsafe-primitive fxquotient))
(define unsafe-fxremainder (unsafe-primitive fxremainder))
(define unsafe-fxmodulo (unsafe-primitive fxmodulo))
(define unsafe-fxabs (unsafe-primitive fxabs))
(define unsafe-fxand (unsafe-primitive fxand))
(define unsafe-fxior (unsafe-primitive fxior))
(define unsafe-fxxor (unsafe-primitive fxxor))
(define unsafe-fxnot (unsafe-primitive fxnot))
(define unsafe-fxrshift (unsafe-primitive fxarithmetic-shift-right))
(define unsafe-fxlshift (unsafe-primitive fxarithmetic-shift-left))
(define unsafe-fl+ #3%fl+)
(define unsafe-fl- #3%fl-)
(define unsafe-fl* #3%fl*)
(define unsafe-fl/ #3%fl/)
(define unsafe-flabs #3%flabs)
(define unsafe-fx= (unsafe-primitive fx=))
(define unsafe-fx< (unsafe-primitive fx<))
(define unsafe-fx> (unsafe-primitive fx>))
(define unsafe-fx>= (unsafe-primitive fx>=))
(define unsafe-fx<= (unsafe-primitive fx<=))
(define unsafe-fxmin (unsafe-primitive fxmin))
(define unsafe-fxmax (unsafe-primitive fxmax))
(define unsafe-fl= #3%fl=)
(define unsafe-fl< #3%fl<)
(define unsafe-fl> #3%fl>)
(define unsafe-fl>= #3%fl>=)
(define unsafe-fl<= #3%fl<=)
(define unsafe-flmin #3%flmin)
(define unsafe-flmax #3%flmax)
(define unsafe-fl+ (unsafe-primitive fl+))
(define unsafe-fl- (unsafe-primitive fl-))
(define unsafe-fl* (unsafe-primitive fl*))
(define unsafe-fl/ (unsafe-primitive fl/))
(define unsafe-flabs (unsafe-primitive flabs))
(define unsafe-fx->fl #3%fixnum->flonum)
(define unsafe-fl->fx #3%flonum->fixnum)
(define unsafe-fl= (unsafe-primitive fl=))
(define unsafe-fl< (unsafe-primitive fl<))
(define unsafe-fl> (unsafe-primitive fl>))
(define unsafe-fl>= (unsafe-primitive fl>=))
(define unsafe-fl<= (unsafe-primitive fl<=))
(define unsafe-flmin (unsafe-primitive flmin))
(define unsafe-flmax (unsafe-primitive flmax))
(define unsafe-flround #3%flround)
(define unsafe-flfloor #3%flfloor)
(define unsafe-flceiling #3%flceiling)
(define unsafe-fltruncate #3%fltruncate)
(define unsafe-fx->fl (unsafe-primitive fixnum->flonum))
(define unsafe-fl->fx (unsafe-primitive flonum->fixnum))
(define unsafe-flsin #3%flsin)
(define unsafe-flcos #3%flcos)
(define unsafe-fltan #3%fltan)
(define unsafe-flasin #3%flasin)
(define unsafe-flacos #3%flacos)
(define unsafe-flatan #3%flatan)
(define unsafe-fllog #3%fllog)
(define unsafe-flexp #3%flexp)
(define unsafe-flsqrt #3%flsqrt)
(define unsafe-flexpt #3%flexpt)
(define unsafe-flround (unsafe-primitive flround))
(define unsafe-flfloor (unsafe-primitive flfloor))
(define unsafe-flceiling (unsafe-primitive flceiling))
(define unsafe-fltruncate (unsafe-primitive fltruncate))
(define unsafe-flsin (unsafe-primitive flsin))
(define unsafe-flcos (unsafe-primitive flcos))
(define unsafe-fltan (unsafe-primitive fltan))
(define unsafe-flasin (unsafe-primitive flasin))
(define unsafe-flacos (unsafe-primitive flacos))
(define unsafe-flatan (unsafe-primitive flatan))
(define unsafe-fllog (unsafe-primitive fllog))
(define unsafe-flexp (unsafe-primitive flexp))
(define unsafe-flsqrt (unsafe-primitive flsqrt))
(define unsafe-flexpt (unsafe-primitive flexpt))
(define (unsafe-flrandom gen) (random gen))
(define unsafe-vector*-length #3%vector-length)
(define unsafe-vector*-ref #3%vector-ref)
(define unsafe-vector*-set! #3%vector-set!)
(define unsafe-vector*-cas! #3%vector-cas!)
(define unsafe-vector*-length (unsafe-primitive vector-length))
(define unsafe-vector*-ref (unsafe-primitive vector-ref))
(define unsafe-vector*-set! (unsafe-primitive vector-set!))
(define unsafe-vector*-cas! (unsafe-primitive vector-cas!))
(define unsafe-unbox* #3%unbox)
(define unsafe-set-box*! #3%set-box!)
(define unsafe-box*-cas! #3%box-cas!)
(define unsafe-unbox* (unsafe-primitive unbox))
(define unsafe-set-box*! (unsafe-primitive set-box!))
(define unsafe-box*-cas! (unsafe-primitive box-cas!))
(define unsafe-bytes-length #3%bytevector-length)
(define unsafe-bytes-ref #3%bytevector-u8-ref)
(define unsafe-bytes-set! #3%bytevector-u8-set!)
(define unsafe-bytes-length (unsafe-primitive bytevector-length))
(define unsafe-bytes-ref (unsafe-primitive bytevector-u8-ref))
(define unsafe-bytes-set! (unsafe-primitive bytevector-u8-set!))
(define unsafe-string-length #3%string-length)
(define unsafe-string-ref #3%string-ref)
(define unsafe-string-set! #3%string-set!)
(define unsafe-string-length (unsafe-primitive string-length))
(define unsafe-string-ref (unsafe-primitive string-ref))
(define unsafe-string-set! (unsafe-primitive string-set!))
(define unsafe-fxvector-length #3%fxvector-length)
(define unsafe-fxvector-ref #3%fxvector-ref)
(define unsafe-fxvector-set! #3%fxvector-set!)
(define unsafe-fxvector-length (unsafe-primitive fxvector-length))
(define unsafe-fxvector-ref (unsafe-primitive fxvector-ref))
(define unsafe-fxvector-set! (unsafe-primitive fxvector-set!))
(define (unsafe-s16vector-ref cptr k)
(let ([mem (cpointer-memory cptr)])

7
racket/src/schemify/interp-match.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base
(require (for-syntax racket/base)
racket/unsafe/ops)
(require (for-syntax racket/base))
;; All patterns for an interpreter matcher are vectors,
;; and each vector element is an unquote or a symbol
@ -26,7 +25,7 @@
[i (in-naturals)])
(syntax-case e (unquote)
[,id #'#t]
[s #`(eq? 's (unsafe-vector*-ref v #,i))])))]))
[s #`(eq? 's (vector*-ref v #,i))])))]))
(define-syntax (let-vars stx)
(syntax-case stx ()
@ -37,5 +36,5 @@
[,id #t]
[_ #f]))
(syntax-case e (unquote)
[,id #`[id (unsafe-vector*-ref v #,i)]]))
[,id #`[id (vector*-ref v #,i)]]))
. body)]))

168
racket/src/schemify/interp-stack.rkt Normal file
View File

@ -0,0 +1,168 @@
#lang racket/base
(require "intmap.rkt")
;; Stack for "interpreter.rkt"
(provide empty-stack
stack-count
stack-ref
stack-set
stack-remove
push-stack
(struct-out stack-info)
stack->pos
stack-info-branch
stack-info-merge!
stack-info-forget!
stack-info-non-tail!)
;; ------------------------------------------------------------
;; Run-time stack
(define empty-stack empty-intmap)
(define (stack-count stack)
(intmap-count stack))
;; Returns a `value` if `tail?` is true, and
;; returns `(values stack value)` if `tail?` is #f.
;; A box for `i` indicates that it's the last use of
;; the accessed binding, so the binding should be
;; removed.
(define (stack-ref stack i [tail? #f])
(cond
[(box? i)
(let ([i (unbox* i)])
(if tail?
(intmap-ref stack i)
(values (intmap-remove stack i)
(intmap-ref stack i))))]
[else
(if tail?
(intmap-ref stack i)
(values stack (intmap-ref stack i)))]))
(define (stack-set stack i v)
(define s (intmap-set stack i v))
s)
(define (stack-remove stack i)
(intmap-remove stack i))
(define (push-stack stack pos vals mask)
(define rest? (negative? mask))
(define count (if rest?
(integer-length mask)
(sub1 (integer-length mask))))
(let loop ([pos pos] [vals vals] [count count] [stack stack])
(cond
[(zero? count)
(if rest?
(stack-set stack pos vals)
stack)]
[else
(loop (add1 pos) (cdr vals) (sub1 count)
(stack-set stack pos (car vals)))])))
;; ------------------------------------------------------------
;; Compile-time stack information
(struct stack-info (capture-depth ; boundary for the enclosing function in compile-time env
closure-map ; hash table to collect variables byond boundary to capture
[use-map #:mutable] ; table of uses; an entry here means the binding is used later
[local-use-map #:mutable] ; subset of `use-map` used to tracked needed merging for branches
[non-tail-at-depth #:mutable])) ; stack depth at non-tail call (that needs space safety)
;; Map a compile-time environment coordinate `i` to a run-time access
;; index. If this this access is the last one --- which is the first
;; lookup of `i`, since the compiler works from the end toward earlier
;; expressions --- then probably return a box, which will trigger a
;; removal of the binding after the lookup at run time.
(define (stack->pos i stk-i #:nonuse? [nonuse? #f])
(define capture-depth (stack-info-capture-depth stk-i))
(define pos
(cond
[(not capture-depth) i]
[(i . >= . capture-depth)
(- i capture-depth)]
[(hash-ref (stack-info-closure-map stk-i) i #f)
=> (lambda (pos) pos)]
[else
;; Count backwards from -1 to represent closure elements
(define cmap (stack-info-closure-map stk-i))
(define pos (- -1 (hash-count cmap)))
(hash-set! cmap i pos)
pos]))
(cond
[nonuse? pos]
[else
;; Record the use of this position. If it's the last use (i.e.,
;; first from the end), then box the position, which means "clear
;; after retreiving" and implements space safety.
(define use-map (stack-info-use-map stk-i))
(cond
[(or (not use-map)
(hash-ref use-map pos #f))
pos]
[else
(when use-map
(set-stack-info-use-map! stk-i (hash-set use-map pos #t)))
(define local-use-map (stack-info-local-use-map stk-i))
(when local-use-map
(set-stack-info-local-use-map! stk-i (hash-set local-use-map pos #t)))
;; We only need to remove from the environment if there's a
;; non-tail call later where the binding would be retained
;; across the call
(if (i . < . (stack-info-non-tail-at-depth stk-i))
(box pos)
pos)])]))
;; Create a fresh tracking record for one branch among many
(define (stack-info-branch stk-i)
(stack-info (stack-info-capture-depth stk-i)
(stack-info-closure-map stk-i)
(stack-info-use-map stk-i)
#hasheq()
(stack-info-non-tail-at-depth stk-i)))
;; Merge branches back together, returning the set of all bindings
;; that has last uses across all branches. The returned information
;; is useful to make sure that all branches are updated to clear the
;; same set of bindings.
(define (stack-info-merge! stk-i branch-stk-is)
(define all-clear (make-hasheq))
(for ([branch-stk-i (in-list branch-stk-is)])
(for ([pos (in-hash-keys (stack-info-local-use-map branch-stk-i))])
(hash-set! all-clear pos #t)
(define use-map (stack-info-use-map stk-i))
(when use-map
(set-stack-info-use-map! stk-i (hash-set use-map pos #t)))
(define local-use-map (stack-info-local-use-map stk-i))
(when local-use-map
(set-stack-info-local-use-map! stk-i (hash-set local-use-map pos #t)))
(set-stack-info-non-tail-at-depth! stk-i
(max (stack-info-non-tail-at-depth stk-i)
(stack-info-non-tail-at-depth branch-stk-i)))))
all-clear)
;; Indicate that some bindings are "popped" from the stack, which
;; means that they no longer count as used, etc.
(define (stack-info-forget! stk-i stack-depth start-pos len)
(set-stack-info-non-tail-at-depth! stk-i
(min (stack-info-non-tail-at-depth stk-i)
stack-depth))
(when (stack-info-use-map stk-i)
(for ([i (in-range len)])
(define pos (+ start-pos i))
(define use-map (stack-info-use-map stk-i))
(set-stack-info-use-map! stk-i (hash-remove use-map pos))
(define local-use-map (stack-info-local-use-map stk-i))
(when local-use-map
(set-stack-info-local-use-map! stk-i (hash-remove local-use-map pos))))))
;; Record the current stack depth at a non-tail call.
(define (stack-info-non-tail! stk-i stack-depth)
(set-stack-info-non-tail-at-depth! stk-i
(max (stack-info-non-tail-at-depth stk-i)
stack-depth)))

765
racket/src/schemify/interpret.rkt
View File

@ -1,9 +1,10 @@
#lang racket/base
(require racket/unsafe/undefined
racket/unsafe/ops
racket/fixnum
"match.rkt"
"wrap.rkt"
"interp-match.rkt")
"interp-match.rkt"
"interp-stack.rkt")
;; Interpreter for the output of "jitify". This little interpreter is
;; useful to avoid going through a more heavyweight `eval` or
@ -12,29 +13,49 @@
;; outer layer, it can implement that layer more efficiently and
;; compactly.
;; The interpreter operates on its own "bytecode" format, so
;; `interpretable-jitified-linklet` compiles to that format, and
;; `interpret-linklet` runs it.
;; The interpreter is safe-for-space. It uses flat closures, a
;; persistent mapping from indices to values for the environment, and
;; explicit operations to remove mappings from the environment as
;; needed to implement space safety.
(provide interpretable-jitified-linklet
interpret-linklet)
(struct indirect (stack element))
(struct indirect-checked indirect ())
(struct indirect (pos element))
(struct boxed (pos))
(struct boxed/check boxed ())
(define (interpretable-jitified-linklet linklet-e strip-annotations)
;; Return a compiled linklet in two parts: a vector expression for
;; constants to be run once, and a expression for the linklet body.
;; A compiled expression uses a list as a stack for local variables,
;; where the coldest element is is a vector of constants, and the
;; 1th slot is a vector of linklet arguments for imports and
;; exports, and the 2nd slot is a vector for top-level variables. We
;; don't have to worry about continuations, because linklet bodies
;; are constrained.
;;
;; Bindings in the environment are represented as positions that
;; count from the coldest end of the stack; that position relative
;; to the hottest end can be computed from the current stack depth.
(define (stack->pos stack-depth i)
(- stack-depth i 1))
;; Conceptually, the run-time environment is implemented as a list,
;; and identifiers are mapped to positions in that list, where 0
;; corresponds to the last element of the list and more deeply
;; nested bindings are pushed on to the front. The `stack-depth` at
;; compile time corresponds to the length of that list. The
;; compile-time environment maps names to those coordinates. But
;; those coodinates are shifted for closure capture, where negative
;; positions are used to access elements of the closure.
;; At run time, instead of a list, the "stack" is implemented as a
;; persistent map, but the position keys for that mapping are still
;; contiguous integers shifted from the compile-time coordinates. A
;; `stack-info` record at compile time manages the translation from
;; environment coordinates to run-time positions.
;; The compilation pass is responsible not only for turning names
;; into run-time positions, but also for tracking the last use of a
;; variable, so its mapping can be removed at runtime to preserve
;; space safety. To compute last use, the compiler must always work
;; from the end expressions toward starting expressions. That's why
;; `compile-list` compiles later expressions before earlier ones in
;; the list, for example.
(define (start linklet-e)
(match linklet-e
[`(lambda . ,_)
@ -45,7 +66,8 @@
num-body-vars
compiled-body)]
[`(let* ,bindings ,body)
(let loop ([bindings bindings] [pos 0] [env '#hasheq()] [accum '()])
(define bindings-stk-i (stack-info #f #hasheq() #f #f 0))
(let loop ([bindings bindings] [elem 0] [env '#hasheq()] [accum '()])
(cond
[(null? bindings)
(define-values (compiled-body num-body-vars)
@ -56,47 +78,60 @@
[else
(let ([binding (car bindings)])
(loop (cdr bindings)
(add1 pos)
(hash-set env (car binding) (indirect 0 pos))
(cons (compile-expr (cadr binding) env 1)
(fx+ elem 1)
(hash-set env (car binding) (indirect 0 elem))
(cons (compile-expr (cadr binding) env 1 bindings-stk-i #t)
accum)))]))]))
(define (compile-linklet-body v env stack-depth)
(match v
[`(lambda ,args . ,body)
;; The `args` here are linklet import and export variables
(define num-args (length args))
(define args-env
(for/fold ([env env]) ([arg (in-list args)]
[i (in-naturals)])
(hash-set env arg (indirect stack-depth i))))
(define body-vars-index (add1 stack-depth))
(hash-set env arg (+ stack-depth i))))
(define body-vars-index (+ num-args stack-depth))
;; Gather all the names that have `define`s, and build up the
;; enviornment that has them consceptually pushed after the
;; import and export variables.
(define-values (body-env num-body-vars)
(for/fold ([env args-env] [num-body-vars 0]) ([e (in-wrap-list body)])
(let loop ([e e] [env env] [num-body-vars num-body-vars])
(match e
[`(define ,id . ,_)
(values (hash-set env (unwrap id) (indirect body-vars-index num-body-vars))
(values (hash-set env (unwrap id) (boxed (+ body-vars-index num-body-vars)))
(add1 num-body-vars))]
[`(define-values ,ids . ,_)
(for/fold ([env env] [num-body-vars num-body-vars]) ([id (in-wrap-list ids)])
(values (hash-set env (unwrap id) (indirect body-vars-index num-body-vars))
(values (hash-set env (unwrap id) (boxed (+ body-vars-index num-body-vars)))
(add1 num-body-vars)))]
[`(begin . ,body)
(for/fold ([env env] [num-body-vars num-body-vars]) ([e (in-wrap-list body)])
(loop e env num-body-vars))]
[`,_ (values env num-body-vars)]))))
(values (compile-top-body body body-env (+ 2 stack-depth))
(define body-stack-depth (+ num-body-vars num-args stack-depth))
;; This `stack-info` is mutated as expressiones are compiled,
;; because that's more convenient than threading it through as
;; both an argument and a result
(define stk-i (stack-info #f #hasheq() #f #f 0))
(define new-body
(compile-top-body body body-env body-stack-depth stk-i))
(values new-body
num-body-vars)]))
;; Like `compile-body`, but flatten top-level `begin`s
(define (compile-top-body body env stack-depth)
(define (compile-top-body body env stack-depth stk-i)
(define bs (let loop ([body body])
(match body
[`() '()]
[`((begin ,subs ...) . ,rest)
(loop (append subs rest))]
[`(,e . ,rest)
(cons (compile-expr e env stack-depth)
(loop rest))])))
(define new-rest (loop rest))
(cons (compile-expr e env stack-depth stk-i #t)
new-rest)])))
(cond
[(null? bs) '#(void)]
[(and (pair? bs) (null? (cdr bs)))
@ -104,56 +139,91 @@
[else
(list->vector (cons 'begin bs))]))
(define (compile-body body env stack-depth)
(define (compile-body body env stack-depth stk-i tail?)
(match body
[`(,e) (compile-expr e env stack-depth)]
[`(,e) (compile-expr e env stack-depth stk-i tail?)]
[`,_
(list->vector
(cons 'begin
(for/list ([e (in-wrap-list body)])
(compile-expr e env stack-depth))))]))
(cons 'begin (compile-list body env stack-depth stk-i tail?)))]))
(define (compile-expr e env stack-depth)
(define (compile-list body env stack-depth stk-i tail?)
(let loop ([body body])
(cond
[(null? body) '()]
[else
(define rest-body (wrap-cdr body))
(define new-rest (loop rest-body))
(cons (compile-expr (wrap-car body) env stack-depth stk-i (and tail? rest-body))
new-rest)])))
(define (compile-expr e env stack-depth stk-i tail?)
(match e
[`(lambda ,ids . ,body)
(define-values (body-env count rest?)
(args->env ids env stack-depth))
(vector 'lambda (count->mask count rest?) (compile-body body body-env (+ stack-depth count)))]
(define cmap (make-hasheq))
(define body-stack-depth (+ stack-depth count))
;; A fresh `stack-info` reflects how a flat closure shifts the
;; coordinates of the variables that it captures; captured
;; variables are added to `cmap` as they are discovered
(define body-stk-i (stack-info stack-depth cmap #hasheq() #f 0))
(define new-body (compile-body body body-env body-stack-depth body-stk-i #t))
(define rev-cmap (for/hasheq ([(i pos) (in-hash cmap)]) (values (- -1 pos) i)))
(vector 'lambda
(count->mask count rest?)
(wrap-property e 'inferred-name)
(for/vector #:length (hash-count cmap) ([i (in-range (hash-count cmap))])
(stack->pos (hash-ref rev-cmap i) stk-i))
new-body)]
[`(case-lambda [,idss . ,bodys] ...)
(define lams (for/list ([ids (in-list idss)]
[body (in-list bodys)])
(compile-expr `(lambda ,ids . ,body) env stack-depth)))
(compile-expr `(lambda ,ids . ,body) env stack-depth stk-i tail?)))
(define mask (for/fold ([mask 0]) ([lam (in-list lams)])
(bitwise-ior mask (interp-match lam [#(lambda ,mask) mask]))))
(list->vector (list* 'case-lambda mask lams))]
(define name (wrap-property e 'inferred-name))
(list->vector (list* 'case-lambda mask name lams))]
[`(let ([,ids ,rhss] ...) . ,body)
(define len (length ids))
(define body-env
(for/fold ([env env]) ([id (in-list ids)]
[i (in-naturals)])
(hash-set env (unwrap id) (+ stack-depth i))))
(vector 'let
(for/vector #:length len ([rhs (in-list rhss)])
(compile-expr rhs env stack-depth))
(compile-body body body-env (+ stack-depth len)))]
[`(letrec . ,_) (compile-letrec e env stack-depth)]
[`(letrec* . ,_) (compile-letrec e env stack-depth)]
(define body-stack-depth (+ stack-depth len))
(define new-body (compile-body body body-env body-stack-depth stk-i tail?))
(define pos (stack->pos stack-depth stk-i #:nonuse? #t))
(stack-info-forget! stk-i stack-depth pos len)
(define new-rhss (list->vector
(compile-list rhss env stack-depth stk-i #f)))
(vector 'let pos new-rhss new-body)]
[`(letrec . ,_) (compile-letrec e env stack-depth stk-i tail?)]
[`(letrec* . ,_) (compile-letrec e env stack-depth stk-i tail?)]
[`(begin . ,vs)
(compile-body vs env stack-depth)]
(compile-body vs env stack-depth stk-i tail?)]
[`(begin0 ,e . ,vs)
(vector 'begin0 (compile-expr e env stack-depth) (compile-body vs env stack-depth))]
(define new-body (compile-body vs env stack-depth stk-i #f))
(vector 'begin0
(compile-expr e env stack-depth stk-i #f)
new-body)]
[`(pariah ,e)
(compile-expr e env stack-depth)]
(compile-expr e env stack-depth stk-i tail?)]
[`(if ,tst ,thn ,els)
(define then-stk-i (stack-info-branch stk-i))
(define else-stk-i (stack-info-branch stk-i))
(define new-then (compile-expr thn env stack-depth then-stk-i tail?))
(define new-else (compile-expr els env stack-depth else-stk-i tail?))
(define all-clear (stack-info-merge! stk-i (list then-stk-i else-stk-i)))
(vector 'if
(compile-expr tst env stack-depth)
(compile-expr thn env stack-depth)
(compile-expr els env stack-depth))]
(compile-expr tst env stack-depth stk-i #f)
(add-clears new-then then-stk-i all-clear)
(add-clears new-else else-stk-i all-clear))]
[`(with-continuation-mark ,key ,val ,body)
(define new-body (compile-expr body env stack-depth stk-i tail?))
(define new-val (compile-expr val env stack-depth stk-i #f))
(vector 'wcm
(compile-expr key env stack-depth)
(compile-expr val env stack-depth)
(compile-expr body env stack-depth))]
(compile-expr key env stack-depth stk-i #f)
new-val
new-body)]
[`(quote ,v)
(let ([v (strip-annotations v)])
;; Protect with `quote` any value that looks like an
@ -165,9 +235,9 @@
(vector 'quote v)
v))]
[`(set! ,id ,rhs)
(compile-assignment id rhs env stack-depth)]
(compile-assignment id rhs env stack-depth stk-i)]
[`(define ,id ,rhs)
(compile-assignment id rhs env stack-depth)]
(compile-assignment id rhs env stack-depth stk-i)]
[`(define-values ,ids ,rhs)
(define gen-ids (for/list ([id (in-list ids)])
(gensym (unwrap id))))
@ -179,44 +249,65 @@
[gen-id (in-list gen-ids)])
`(set! ,id ,gen-id)))))
env
stack-depth)]
stack-depth
stk-i
tail?)]
[`(call-with-values ,proc1 (lambda ,ids . ,body))
(compile-expr `(call-with-values ,proc1 (case-lambda
[,ids . ,body]))
env
stack-depth)]
stack-depth
stk-i
tail?)]
[`(call-with-values (lambda () . ,body) (case-lambda [,idss . ,bodys] ...))
(define body-stk-is (for/list ([body (in-list bodys)])
(stack-info-branch stk-i)))
(define initial-new-clauses
(for/list ([ids (in-list idss)]
[body (in-list bodys)]
[body-stk-i (in-list body-stk-is)])
(define-values (new-env count rest?)
(args->env ids env stack-depth))
(define new-stack-depth (+ stack-depth count))
(define new-body (compile-body body new-env new-stack-depth body-stk-i tail?))
(define pos (stack->pos stack-depth body-stk-i #:nonuse? #t))
(stack-info-forget! body-stk-i stack-depth pos count)
(vector (count->mask count rest?)
new-body)))
(define all-clear (stack-info-merge! stk-i body-stk-is))
(vector 'cwv
(compile-body body env stack-depth)
(for/list ([ids (in-list idss)]
[body (in-list bodys)])
(define-values (new-env count rest?)
(args->env ids env stack-depth))
(vector (count->mask count rest?)
(compile-body body new-env (+ stack-depth count)))))]
(compile-body body env stack-depth stk-i #f)
(stack->pos stack-depth stk-i #:nonuse? #t)
(match e
[`(,_ ,_ ,receiver) (wrap-property receiver 'inferred-name)])
(for/list ([initial-new-clause (in-list initial-new-clauses)]
[body-stk-i (in-list body-stk-is)])
(define body (vector-ref initial-new-clause 1))
(vector (vector-ref initial-new-clause 0)
(add-clears body body-stk-i all-clear))))]
[`(call-with-module-prompt (lambda () . ,body))
(vector 'cwmp0 (compile-body body env stack-depth))]
(vector 'cwmp0 (compile-body body env stack-depth stk-i tail?))]
[`(call-with-module-prompt (lambda () . ,body) ',ids ',constances ,vars ...)
(vector 'cwmp
(compile-body body env stack-depth)
(compile-body body env stack-depth stk-i tail?)
ids
constances
(for/list ([var (in-list vars)])
(compile-expr var env stack-depth)))]
(compile-list vars env stack-depth stk-i #f))]
[`(variable-set! ,dest-id ,e ',constance)
(define dest-var (hash-ref env (unwrap dest-id)))
(define new-expr (compile-expr e env stack-depth stk-i #f))
(vector 'set-variable!
(stack->pos stack-depth (indirect-stack dest-var)) (indirect-element dest-var)
(compile-expr e env stack-depth)
(stack->pos dest-var stk-i)
new-expr
constance)]
[`(variable-ref ,id)
(define var (hash-ref env (unwrap id)))
(vector 'ref-variable/checked (stack->pos stack-depth (indirect-stack var)) (indirect-element var))]
(vector 'ref-variable/checked (stack->pos var stk-i))]
[`(variable-ref/no-check ,id)
(define var (hash-ref env (unwrap id)))
(vector 'ref-variable (stack->pos stack-depth (indirect-stack var)) (indirect-element var))]
[`(#%app ,_ ...) (compile-apply (wrap-cdr e) env stack-depth)]
[`(,rator ,_ ...) (compile-apply e env stack-depth)]
(vector 'ref-variable (stack->pos var stk-i))]
[`(#%app ,_ ...) (compile-apply (wrap-cdr e) env stack-depth stk-i tail?)]
[`(,rator ,_ ...) (compile-apply e env stack-depth stk-i tail?)]
[`,id
(define u (unwrap id))
(define var (hash-ref env u #f))
@ -226,45 +317,55 @@
(vector 'quote u)
u)]
[(indirect? var)
(define pos (stack->pos stack-depth (indirect-stack var)))
(define pos (stack->pos (indirect-pos var) stk-i))
(define elem (indirect-element var))
(if (indirect-checked? var)
(vector 'ref-indirect/checked pos elem u)
(cons pos elem))]
(cons pos elem)]
[(boxed? var)
(define pos (stack->pos (boxed-pos var) stk-i))
(if (boxed/check? var)
(vector 'unbox/checked pos u)
(vector 'unbox pos))]
[else
(stack->pos stack-depth var)])]))
(stack->pos var stk-i)])]))
(define (compile-letrec e env stack-depth)
(define (compile-letrec e env stack-depth stk-i tail?)
(match e
[`(,_ ([,ids ,rhss] ...) . ,body)
(define (make-env indirect)
(define count (length ids))
(define (make-env boxed)
(for/fold ([env env]) ([id (in-list ids)]
[i (in-naturals)])
(hash-set env (unwrap id) (indirect stack-depth i))))
(define rhs-env (make-env indirect-checked))
(define body-env (make-env indirect))
(define body-stack-depth (add1 stack-depth))
(vector 'letrec
(for/vector #:length (length ids) ([rhs (in-list rhss)])
(compile-expr rhs rhs-env body-stack-depth))
(compile-body body body-env body-stack-depth))]))
(hash-set env (unwrap id) (boxed (+ (- count i 1) stack-depth)))))
(define rhs-env (make-env boxed/check))
(define body-env (make-env boxed))
(define body-stack-depth (+ stack-depth count))
(define new-body (compile-body body body-env body-stack-depth stk-i tail?))
(define new-rhss (list->vector
(compile-list rhss rhs-env body-stack-depth stk-i #F)))
(define pos (stack->pos stack-depth stk-i #:nonuse? #t))
(stack-info-forget! stk-i stack-depth pos count)
(vector 'letrec pos new-rhss new-body)]))
(define (compile-apply es env stack-depth)
(list->vector (cons 'app
(for/list ([e (in-wrap-list es)])
(compile-expr e env stack-depth)))))
(define (compile-assignment id rhs env stack-depth)
(define compiled-rhs (compile-expr rhs env stack-depth))
(define (compile-apply es env stack-depth stk-i tail?)
(define new-es (compile-list es env stack-depth stk-i #f))
(unless tail?
(stack-info-non-tail! stk-i stack-depth))
(list->vector (cons 'app new-es)))
(define (compile-assignment id rhs env stack-depth stk-i)
(define compiled-rhs (compile-expr rhs env stack-depth stk-i #f))
(define u (unwrap id))
(define var (hash-ref env u))
(cond
[(indirect? var)
(define s (stack->pos stack-depth (indirect-stack var)))
(define s (stack->pos (indirect-pos var) stk-i))
(define e (indirect-element var))
(if (indirect-checked? var)
(vector 'set!-indirect/checked s e compiled-rhs u)
(vector 'set!-indirect s e compiled-rhs))]
(vector 'set!-indirect s e compiled-rhs)]
[(boxed? var)
(define s (stack->pos (boxed-pos var) stk-i))
(if (boxed/check? var)
(vector 'set!-boxed/checked s compiled-rhs u)
(vector 'set!-boxed s compiled-rhs u))]
[else (error 'compile "unexpected set!")]))
(define (args->env ids env stack-depth)
@ -279,210 +380,403 @@
(add1 count)
#t)])))
(define (add-clears e stk-i all-clear)
(define local-use-map (stack-info-local-use-map stk-i))
(define clears
(for/list ([pos (in-hash-keys all-clear)]
#:unless (hash-ref local-use-map pos #f))
pos))
(cond
[(null? clears) e]
[else (vector 'clear clears e)]))
(start linklet-e))
;; ----------------------------------------
(define (interpret-linklet b primitives variable-ref variable-ref/no-check variable-set!
(define (interpret-linklet b ; compiled form
primitives ; hash of symbol -> value
;; the implementation of variables:
variable-ref variable-ref/no-check variable-set!
;; to create a procedure with a specific arity mask:
make-arity-wrapper-procedure)
(interp-match
b
[#(,consts ,num-body-vars ,b)
(let ([consts (and consts
(let ([vec (make-vector (vector-length consts))])
(define stack (list vec))
(let ([vec (make-vector (vector*-length consts))])
(define stack (stack-set empty-stack 0 vec))
(for ([b (in-vector consts)]
[i (in-naturals)])
(vector-set! vec i (interpret-expr b stack primitives void void void void))
vec)
vec))])
(lambda args
(define body-vec (make-vector num-body-vars unsafe-undefined))
(define base-stack (if consts (list consts) null))
(define stack (list* body-vec (list->vector args) base-stack))
(define start-stack (if consts
(stack-set empty-stack 0 consts)
empty-stack))
(define args-stack (for/fold ([stack start-stack]) ([arg (in-list args)]
[i (in-naturals (if consts 1 0))])
(stack-set stack i arg)))
(define post-args-pos (stack-count args-stack))
(define stack (for/fold ([stack args-stack]) ([i (in-range num-body-vars)])
(stack-set stack (+ i post-args-pos) (box unsafe-undefined))))
(interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set!
make-arity-wrapper-procedure)))]))
make-arity-wrapper-procedure)))]))
(define (interpret-expr b stack primitives variable-ref variable-ref/no-check variable-set!
make-arity-wrapper-procedure)
(define (interpret b stack)
;; Returns `result ...` when `tail?` is #t, and
;; returns `(values stack result ...)` when `tail?` is #f.
;; An updated "stack" is returned because bindings are
;; removed from the stack on their last uses (where there is
;; a non-tail call after the last use)
(define (interpret b stack [tail? #f])
(cond
[(integer? b) (list-ref stack b)]
[(pair? b) (vector-ref (list-ref stack (car b)) (cdr b))]
[(symbol? b) (hash-ref primitives b)]
[(integer? b) (stack-ref stack b tail?)]
[(box? b) (stack-ref stack b tail?)]
[(pair? b)
(define-values (new-stack vec) (stack-ref stack (car b)))
(define val (vector*-ref vec (cdr b)))
(if tail?
val
(values new-stack val))]
[(symbol? b)
(define val (hash-ref primitives b))
(if tail?
val
(values stack val))]
[(vector? b)
(interp-match
b
[#(app ,rator-b)
(define len (vector-length b))
(define rator (interpret rator-b stack))
(define len (vector*-length b))
(define-values (rand-stack rator) (interpret rator-b stack))
(define-syntax-rule (add-value stack app)
(call-with-values
(lambda () app)
(case-lambda
[(v) (values stack v)]
[vs (apply values stack vs)])))
(cond
[(eq? len 2)
(rator)]
(if tail?
(rator)
(add-value stack (rator)))]
[(eq? len 3)
(rator
(interpret (unsafe-vector*-ref b 2) stack))]
(define-values (stack rand) (interpret (vector*-ref b 2) rand-stack))
(if tail?
(rator rand)
(add-value stack (rator rand)))]
[(eq? len 4)
(rator
(interpret (unsafe-vector*-ref b 2) stack)
(interpret (unsafe-vector*-ref b 3) stack))]
(define-values (stack1 rand1) (interpret (vector*-ref b 2) rand-stack))
(define-values (stack2 rand2) (interpret (vector*-ref b 3) stack1))
(if tail?
(rator rand1 rand2)
(add-value stack (rator rand1 rand2)))]
[else
(apply (interpret rator-b stack)
(for/list ([b (in-vector b 2)])
(interpret b stack)))])]
[#(quote ,v) v]
[#(ref-indirect/checked ,s ,e ,name)
(define v (vector-ref (list-ref stack s) e))
(check-not-unsafe-undefined v name)]
[#(ref-variable ,s ,e)
(variable-ref/no-check (vector-ref (list-ref stack s) e))]
[#(ref-variable/checked ,s ,e)
(variable-ref (vector-ref (list-ref stack s) e))]
[#(let ,rhss ,b)
(define len (vector-length rhss))
(let loop ([i 0] [new-stack stack])
(if (= i len)
(interpret b new-stack)
(loop (add1 i) (cons (interpret (unsafe-vector*-ref rhss i) stack)
new-stack))))]
[#(letrec ,rhss ,b)
(define len (vector-length rhss))
(define frame-vec (make-vector len unsafe-undefined))
(define new-stack (cons frame-vec stack))
(let loop ([i 0])
(if (= i len)
(interpret b new-stack)
(begin
(vector-set! frame-vec i (interpret (vector-ref rhss i) new-stack))
(loop (add1 i)))))]
[#(begin)
(define last (sub1 (vector-length b)))
(let loop ([i 1])
(if (= i last)
(interpret (unsafe-vector*-ref b i) stack)
(begin
(interpret (unsafe-vector*-ref b i) stack)
(loop (add1 i)))))]
[#(begin0 ,b0)
(define last (sub1 (unsafe-vector-length b)))
(begin0
(interpret b0 stack)
(let loop ([i 2])
(interpret (unsafe-vector*-ref b i) stack)
(unless (= i last)
(loop (add1 i)))))]
[#(if ,tst ,thn ,els)
(if (interpret tst stack)
(interpret thn stack)
(interpret els stack))]
[#(wcm ,key ,val ,body)
(with-continuation-mark
(interpret key stack)
(interpret val stack)
(interpret body stack))]
[#(cwv ,b ,clauses)
(define vs (call-with-values (lambda () (interpret b stack)) list))
(define len (length vs))
(let loop ([clauses clauses])
(define-values (stack rev-rands)
(for/fold ([stack rand-stack] [rev-rands null]) ([b (in-vector b 2)])
(define-values (new-stack v) (interpret b stack))
(values new-stack (cons v rev-rands))))
(define rands (reverse rev-rands))
(if tail?
(apply rator rands)
(add-value stack (apply rator rands)))])]
[#(quote ,v)
(if tail?
v
(values stack v))]
[#(unbox ,s)
(define-values (new-stack bx) (stack-ref stack s))
(define val (unbox* bx))
(if tail?
val
(values new-stack val))]
[#(unbox/checked ,s ,name)
(define-values (new-stack bx) (stack-ref stack s))
(define v (unbox* bx))
(define val (check-not-unsafe-undefined v name))
(if tail?
val
(values new-stack val))]
[#(ref-variable ,s)
(define-values (new-stack var) (stack-ref stack s))
(define val (variable-ref/no-check var))
(if tail?
val
(values new-stack val))]
[#(ref-variable/checked ,s)
(define-values (new-stack var) (stack-ref stack s))
(define val (variable-ref var))
(if tail?
val
(values new-stack val))]
[#(let ,pos ,rhss ,b)
(define len (vector*-length rhss))
(define body-stack
(let loop ([i 0] [stack stack])
(cond
[(fx= i len) stack]
[else
(define-values (new-stack val) (interpret (vector*-ref rhss i) stack))
(stack-set (loop (fx+ i 1) new-stack) (fx+ i pos) val)])))
(interpret b body-stack tail?)]
[#(letrec ,pos ,rhss ,b)
(define len (vector*-length rhss))
(define-values (body-stack boxes)
(for/fold ([stack stack] [boxes null]) ([i (in-range len)])
(define bx (box unsafe-undefined))
(values (stack-set stack (fx+ (fx- len i 1) pos) bx)
(cons bx boxes))))
(let loop ([i 0] [stack body-stack] [boxes boxes])
(cond
[(null? clauses) (error 'call-with-values "arity error")]
[(fx= i len)
(interpret b stack tail?)]
[else
(define-values (new-stack val) (interpret (vector*-ref rhss i) stack))
(set-box! (car boxes) val)
(loop (fx+ i 1) new-stack (cdr boxes))]))]
[#(begin)
(define last (fx- (vector*-length b) 1))
(let loop ([i 1] [stack stack])
(cond
[(fx= i last)
(interpret (vector*-ref b i) stack tail?)]
[else
(call-with-values
(lambda () (interpret (vector*-ref b i) stack))
(case-lambda
[(new-stack val) (loop (fx+ i 1) new-stack)]
[(new-stack . vals) (loop (fx+ i 1) new-stack)]))]))]
[#(begin0 ,b0)
(define last (fx- (vector*-length b) 1))
(call-with-values
(lambda () (interpret b0 stack))
(lambda (stack . vals)
(let loop ([i 2] [stack stack])
(define new-stack
(call-with-values
(lambda () (interpret (vector*-ref b i) stack))
(case-lambda
[(new-stack val) new-stack]
[(new-stack . vals) new-stack])))
(if (fx= i last)
(if tail?
(apply values vals)
(apply values new-stack vals))
(loop (fx+ i 1) new-stack)))))]
[#(clear ,clears ,e)
(let loop ([clears clears] [stack stack])
(cond
[(null? clears)
(interpret e stack tail?)]
[else
(loop (cdr clears) (stack-remove stack (car clears)))]))]
[#(if ,tst ,thn ,els)
(define-values (new-stack val) (interpret tst stack))
(if val
(interpret thn new-stack tail?)
(interpret els new-stack tail?))]
[#(wcm ,key ,val ,body)
(define-values (k-stack k-val) (interpret key stack))
(define-values (v-stack v-val) (interpret val k-stack))
(with-continuation-mark
k-val
v-val
(interpret body v-stack tail?))]
[#(cwv ,b ,pos ,name ,clauses)
(define-values (new-stack vs)
(call-with-values
(lambda () (interpret b stack))
(lambda (stack . vals) (values stack vals))))
(define len (length vs))
(let loop ([clauses clauses] [full-mask 0])
(cond
[(null? clauses)(apply raise-arity-mask-error (or name '|#<procedure>|) full-mask vs)]
[else
(interp-match
(car clauses)
[#(,mask ,b)
(if (matching-argument-count? mask len)
(interpret b (push-stack stack vs mask))
(loop (cdr clauses)))])]))]
(interpret b (push-stack new-stack pos vs mask) tail?)
(loop (cdr clauses) (fxior mask full-mask)))])]))]
[#(cwmp0 ,b)
(unless tail? (error 'interpret "expect call-with-module-prompt in tail position"))
((hash-ref primitives 'call-with-module-prompt)
(lambda () (interpret b stack)))]
(lambda () (interpret b stack #t)))]
[#(cwmp ,b ,ids ,constances ,var-es)
(unless tail? (error 'interpret "expect call-with-module-prompt in tail position"))
(apply (hash-ref primitives 'call-with-module-prompt)
(lambda () (interpret b stack))
(lambda () (interpret b stack #t))
ids
constances
(for/list ([e (in-list var-es)])
(interpret e stack)))]
[#(lambda ,mask ,b)
(make-arity-wrapper-procedure
(lambda args
(if (matching-argument-count? mask (length args))
(interpret b (push-stack stack args mask))
(error 'lambda "arity error: ~s" args)))
mask
#f)]
[#(case-lambda ,mask)
(define n (vector-length b))
(make-arity-wrapper-procedure
(lambda args
(define len (length args))
(let loop ([i 2])
(interpret e stack #t)))]
[#(lambda ,mask ,name ,close-vec ,_)
(define-values (new-stack captured) (capture-closure close-vec stack))
(define val
(make-arity-wrapper-procedure
(lambda args
(cond
[(= i n) (error 'case-lambda "arity error: ~s")]
[(matching-argument-count? mask (length args))
(apply-function b captured args)]
[else
(interp-match
(unsafe-vector*-ref b i)
[#(lambda ,mask ,b)
(if (matching-argument-count? mask len)
(interpret b (push-stack stack args mask))
(loop (add1 i)))])])))
mask
#f)]
[#(set-variable! ,s ,e ,b ,c)
(variable-set! (vector-ref (list-ref stack s) e)
(interpret b stack)
c)]
(apply raise-arity-mask-error (or name '|#<procedure>|) mask args)]))
mask
name))
(if tail?
val
(values new-stack val))]
[#(case-lambda ,mask ,name)
(define n (vector*-length b))
(define-values (new-stack captureds)
(let loop ([i 3] [stack stack])
(cond
[(fx= i n) (values stack '())]
[else
(define-values (rest-stack rest-captureds) (loop (fx+ i 1) stack))
(define-values (new-stack captured)
(interp-match
(vector*-ref b i)
[#(lambda ,mask ,name ,close-vec) (capture-closure close-vec rest-stack)]))
(values new-stack (cons captured rest-captureds))])))
(define val
(make-arity-wrapper-procedure
(lambda args
(define len (length args))
(let loop ([i 3] [captureds captureds] [full-mask 0])
(cond
[(fx= i n)
(apply raise-arity-mask-error (or name '|#<procedure>|) full-mask args)]
[else
(define one-b (vector*-ref b i))
(interp-match
one-b
[#(lambda ,mask)
(if (matching-argument-count? mask len)
(apply-function one-b (car captureds) args)
(loop (fx+ i 1) (cdr captureds) (fxior full-mask mask)))])])))
mask
#f))
(if tail?
val
(values new-stack val))]
[#(set-variable! ,s ,b ,c)
(define-values (var-stack var) (stack-ref stack s))
(define-values (val-stack val) (interpret b var-stack))
(variable-set! var val c)
(if tail?
(void)
(values val-stack (void)))]
[#(set!-indirect ,s ,e ,b)
(unsafe-vector*-set! (list-ref stack s) e (interpret b stack))]
[#(set!-indirect/checked ,s ,e ,b ,name)
(define v (interpret b stack))
(define vec (list-ref stack s))
(check-not-unsafe-undefined/assign (unsafe-vector*-ref vec e) name)
(unsafe-vector*-set! vec e v)])]
[else b]))
(define-values (vec-stack vec) (stack-ref stack s))
(define-values (val-stack val) (interpret b vec-stack))
(vector*-set! vec e val)
(if tail?
(void)
(values val-stack (void)))]
[#(set!-boxed ,s ,b ,name)
(define-values (bx-stack bx) (stack-ref stack s))
(define-values (v-stack v) (interpret b bx-stack))
(set-box*! bx v)
(if tail?
(void)
(values v-stack (void)))]
[#(set!-boxed/checked ,s ,b ,name)
(define-values (bx-stack bx) (stack-ref stack s))
(define-values (v-stack v) (interpret b bx-stack))
(check-not-unsafe-undefined/assign (unbox* bx) name)
(set-box*! bx v)
(if tail?
(void)
(values v-stack (void)))])]
[else (if tail?
b
(values stack b))]))
(define (matching-argument-count? mask len)
(bitwise-bit-set? mask len))
(define (capture-closure close-vec stack)
(define len (vector*-length close-vec))
(let loop ([i 0] [stack stack] [captured empty-stack])
(cond
[(= i len) (values stack captured)]
[else
(define-values (val-stack val) (stack-ref stack (vector*-ref close-vec i)))
(loop (add1 i)
val-stack
(stack-set captured (- -1 i) val))])))
(interpret b stack))
(define (apply-function b captured args)
(interp-match
b
[#(lambda ,mask ,name ,close-vec ,b)
(interpret b (push-stack captured 0 args mask) #t)]))
;; mask has a single bit set or all bits above some bit
(define (push-stack stack vals mask)
(define rest? (negative? mask))
(define count (if rest?
(integer-length mask)
(sub1 (integer-length mask))))
(let loop ([stack stack] [vals vals] [count count])
(cond
[(zero? count)
(if rest? (cons vals stack) stack)]
[else
(loop (cons (car vals) stack) (cdr vals) (sub1 count))])))
(cond
[(vector? b)
(interp-match
b
[#(begin)
(define last (sub1 (vector*-length b)))
(let loop ([i 1])
(define e (vector*-ref b i))
(cond
[(= i last)
(interpret e stack #t)]
[else
(interpret e stack #t)
(loop (add1 i))]))]
[#()
(interpret b stack #t)])]
[else
(interpret b stack #t)]))
;; ----------------------------------------
(define (count->mask count rest?)
(if rest?
(bitwise-xor -1 (sub1 (arithmetic-shift 1 (sub1 count))))
(arithmetic-shift 1 count)))
(define (matching-argument-count? mask len)
(bitwise-bit-set? mask len))
;; ----------------------------------------
(module+ main
(require racket/pretty)
(define primitives (hash 'list list
'vector vector
'add1 add1
'values values
'continuation-mark-set-first continuation-mark-set-first))
(struct var ([val #:mutable]) #:transparent)
(define b
(interpretable-jitified-linklet '(let* ([s "string"])
(lambda (x two-box)
(define other 5)
(begin
(define f (lambda (y)
(vector x y)))
(let ([z y])
(vector x z))))
(define g (case-lambda
[() no]
[ys
(vector x ys)])))
(define h (lambda (t x y a b)
(list (if t (list x a) (list y b))
(list a b))))
(define h2 (lambda (t x)
(if t
x
(let ([y 10])
y))))
(define h3 (lambda (t x)
(let ([y (let ([z 0])
z)])
(list x y (let ([z 2])
z)))))
(define-values (one two) (values 100 200))
(variable-set! two-box two 'constant)
(letrec ([ok 'ok])
@ -495,7 +789,8 @@
one two (variable-ref two-box)
(continuation-mark-set-first #f 'x 'no))))))
values))
(define l (interpret-linklet b primitives unbox unbox (lambda (b v c)
(set-box! b v))
(pretty-print b)
(define l (interpret-linklet b primitives var-val var-val (lambda (b v c)
(set-var-val! b v))
(lambda (proc mask name) proc)))
(l 'the-x (box #f)))
(l 'the-x (var #f)))

134
racket/src/schemify/intmap.rkt Normal file
View File

@ -0,0 +1,134 @@
#lang racket/base
(require racket/fixnum
(for-syntax racket/base))
;; Simplified version of Jon Zeppieri's intmap
;; implementation for Racket-on-Chez.
;; This one always has fixnum keys, doens't have
;; to hash, doesn't have to deal with collisions,
;; and doesn't need a wrapper to distinguish
;; the type and record the comparison function.
(provide empty-intmap
intmap-count
intmap-ref
intmap-set
intmap-remove)
(define empty-intmap #f)
(struct Br (count prefix mask left right) #:transparent)
(struct Lf (key value) #:transparent)
(define (intmap-count t)
(cond
[(not t) #f]
[(Br? t) (Br-count t)]
[else 1]))
(define (intmap-ref t key)
(cond
[(Br? t)
(if (fx<= key (Br-prefix t))
(intmap-ref (Br-left t) key)
(intmap-ref (Br-right t) key))]
[(Lf? t)
(if (fx= key (Lf-key t))
(Lf-value t)
(not-found key))]
[else (not-found key)]))
(define (not-found key)
(error 'intmap-ref "not found: ~e" key))
(define (intmap-set t key val)
(cond
[(Br? t)
(let ([p (Br-prefix t)]
[m (Br-mask t)])
(cond
[(not (match-prefix? key p m))
(join key (Lf key val) p t)]
[(fx<= key p)
(br p m (intmap-set (Br-left t) key val) (Br-right t))]
[else
(br p m (Br-left t) (intmap-set (Br-right t) key val))]))]
[(Lf? t)
(let ([j (Lf-key t)])
(cond
[(not (fx= j key))
(join key (Lf key val) j t)]
[else
(Lf key val)]))]
[else
(Lf key val)]))
(define (join p0 t0 p1 t1)
(let* ([m (branching-bit p0 p1)]
[p (mask p0 m)])
(if (fx<= p0 p1)
(br p m t0 t1)
(br p m t1 t0))))
(define (intmap-remove t key)
(cond
[(Br? t)
(let ([p (Br-prefix t)]
[m (Br-mask t)])
(cond
[(not (match-prefix? key p m))
t]
[(fx<= key p)
(br/check-left p m (intmap-remove (Br-left t) key) (Br-right t))]
[else
(br/check-right p m (Br-left t) (intmap-remove (Br-right t) key))]))]
[(Lf? t)
(if (fx= key (Lf-key t))
#f
t)]
[else
#f]))
;; bit twiddling
(define-syntax-rule (match-prefix? h p m)
(fx= (mask h m) p))
(define-syntax-rule (mask h m)
(fxand (fxior h (fx- m 1)) (fxnot m)))
(define-syntax-rule (branching-bit p m)
(highest-set-bit (fxxor p m)))
(define-syntax (if-64-bit? stx)
(syntax-case stx ()
[(_ 64-mode 32-mode)
(if (eqv? 64 (system-type 'word))
#'64-mode
#'32-mode)]))
(define-syntax-rule (highest-set-bit x1)
(let* ([x2 (fxior x1 (fxrshift x1 1))]
[x3 (fxior x2 (fxrshift x2 2))]
[x4 (fxior x3 (fxrshift x3 4))]
[x5 (fxior x4 (fxrshift x4 8))]
[x6 (fxior x5 (fxrshift x5 16))]
[x7 (if-64-bit?
(fxior x6 (fxrshift x6 3))
x6)])
(fxxor x7 (fxrshift x7 1))))
;; basic utils
(define (br p m l r)
(let ([c (fx+ (intmap-count l) (intmap-count r))])
(Br c p m l r)))
(define (br/check-left p m l r)
(if l
(br p m l r)
r))
(define (br/check-right p m l r)
(if r
(br p m l r)
l))