summaryrefslogtreecommitdiff
path: root/module/language/cps/compile-bytecode.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/compile-bytecode.scm')
-rw-r--r--module/language/cps/compile-bytecode.scm691
1 files changed, 385 insertions, 306 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index f6805f38d..669be8c9b 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -27,11 +27,10 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (language cps)
- #:use-module (language cps primitives)
#:use-module (language cps slot-allocation)
#:use-module (language cps utils)
#:use-module (language cps closure-conversion)
- #:use-module (language cps handle-interrupts)
+ #:use-module (language cps loop-instrumentation)
#:use-module (language cps optimize)
#:use-module (language cps reify-primitives)
#:use-module (language cps renumber)
@@ -39,6 +38,7 @@
#:use-module (language cps intmap)
#:use-module (language cps intset)
#:use-module (system vm assembler)
+ #:use-module (system base types internal)
#:export (compile-bytecode))
(define (kw-arg-ref args kw default)
@@ -100,9 +100,6 @@
(define (slot sym)
(lookup-slot sym allocation))
- (define (constant sym)
- (lookup-constant-value sym allocation))
-
(define (from-sp var)
(- frame-size 1 var))
@@ -113,272 +110,299 @@
(define (compile-tail label exp)
;; There are only three kinds of expressions in tail position:
;; tail calls, multiple-value returns, and single-value returns.
+ (define (maybe-reset-frame nlocals)
+ (unless (= frame-size nlocals)
+ (emit-reset-frame asm nlocals)))
(match exp
(($ $call proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
- (emit-tail-call asm (1+ (length args))))
+ (maybe-reset-frame (1+ (length args)))
+ (emit-handle-interrupts asm)
+ (emit-tail-call asm))
(($ $callk k proc args)
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
- (emit-tail-call-label asm (1+ (length args)) k))
+ (let ((nclosure (if proc 1 0)))
+ (maybe-reset-frame (+ nclosure (length args))))
+ (emit-handle-interrupts asm)
+ (emit-tail-call-label asm k))
(($ $values args)
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
- (emit-return-values asm (1+ (length args))))))
+ (maybe-reset-frame (length args))
+ (emit-handle-interrupts asm)
+ (emit-return-values asm))))
(define (compile-value label exp dst)
(match exp
(($ $values (arg))
(maybe-mov dst (slot arg)))
+ (($ $primcall (or 's64->u64 'u64->s64) #f (arg))
+ (maybe-mov dst (slot arg)))
(($ $const exp)
(emit-load-constant asm (from-sp dst) exp))
- (($ $closure k 0)
+ (($ $const-fun k)
(emit-load-static-procedure asm (from-sp dst) k))
- (($ $closure k nfree)
- (emit-make-closure asm (from-sp dst) k nfree))
+ (($ $code k)
+ (emit-load-label asm (from-sp dst) k))
(($ $primcall 'current-module)
(emit-current-module asm (from-sp dst)))
(($ $primcall 'current-thread)
(emit-current-thread asm (from-sp dst)))
- (($ $primcall 'cached-toplevel-box (scope name bound?))
- (emit-cached-toplevel-box asm (from-sp dst)
- (constant scope) (constant name)
- (constant bound?)))
- (($ $primcall 'cached-module-box (mod name public? bound?))
- (emit-cached-module-box asm (from-sp dst)
- (constant mod) (constant name)
- (constant public?) (constant bound?)))
- (($ $primcall 'define! (sym))
- (emit-define! asm (from-sp dst) (from-sp (slot sym))))
- (($ $primcall 'resolve (name bound?))
- (emit-resolve asm (from-sp dst) (constant bound?)
- (from-sp (slot name))))
- (($ $primcall 'free-ref (closure idx))
- (emit-free-ref asm (from-sp dst) (from-sp (slot closure))
- (constant idx)))
- (($ $primcall 'vector-ref (vector index))
- (emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
- (from-sp (slot index))))
- (($ $primcall 'make-vector (length init))
- (emit-make-vector asm (from-sp dst) (from-sp (slot length))
- (from-sp (slot init))))
- (($ $primcall 'make-vector/immediate (length init))
- (emit-make-vector/immediate asm (from-sp dst) (constant length)
- (from-sp (slot init))))
- (($ $primcall 'vector-ref/immediate (vector index))
- (emit-vector-ref/immediate asm (from-sp dst) (from-sp (slot vector))
- (constant index)))
- (($ $primcall 'allocate-struct (vtable nfields))
- (emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
- (from-sp (slot nfields))))
- (($ $primcall 'allocate-struct/immediate (vtable nfields))
- (emit-allocate-struct/immediate asm (from-sp dst)
- (from-sp (slot vtable))
- (constant nfields)))
- (($ $primcall 'struct-ref (struct n))
- (emit-struct-ref asm (from-sp dst) (from-sp (slot struct))
- (from-sp (slot n))))
- (($ $primcall 'struct-ref/immediate (struct n))
- (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
- (constant n)))
- (($ $primcall 'char->integer (src))
- (emit-char->integer asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'integer->char (src))
- (emit-integer->char asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'add/immediate (x y))
- (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
- (($ $primcall 'sub/immediate (x y))
- (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
- (($ $primcall 'uadd/immediate (x y))
- (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'usub/immediate (x y))
- (emit-usub/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'umul/immediate (x y))
- (emit-umul/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'ursh/immediate (x y))
- (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'ulsh/immediate (x y))
- (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x))
- (constant y)))
- (($ $primcall 'builtin-ref (name))
- (emit-builtin-ref asm (from-sp dst) (constant name)))
- (($ $primcall 'scm->f64 (src))
+ (($ $primcall 'define! #f (mod sym))
+ (emit-define! asm (from-sp dst)
+ (from-sp (slot mod)) (from-sp (slot sym))))
+ (($ $primcall 'resolve (bound?) (name))
+ (emit-resolve asm (from-sp dst) bound? (from-sp (slot name))))
+ (($ $primcall 'allocate-words annotation (nfields))
+ (emit-allocate-words asm (from-sp dst) (from-sp (slot nfields))))
+ (($ $primcall 'allocate-words/immediate (annotation . nfields))
+ (emit-allocate-words/immediate asm (from-sp dst) nfields))
+ (($ $primcall 'scm-ref annotation (obj idx))
+ (emit-scm-ref asm (from-sp dst) (from-sp (slot obj))
+ (from-sp (slot idx))))
+ (($ $primcall 'scm-ref/tag annotation (obj))
+ (let ((tag (match annotation
+ ('pair %tc1-pair)
+ ('struct %tc3-struct))))
+ (emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag)))
+ (($ $primcall 'scm-ref/immediate (annotation . idx) (obj))
+ (emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
+ (($ $primcall 'word-ref annotation (obj idx))
+ (emit-word-ref asm (from-sp dst) (from-sp (slot obj))
+ (from-sp (slot idx))))
+ (($ $primcall 'word-ref/immediate (annotation . idx) (obj))
+ (emit-word-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
+ (($ $primcall 'pointer-ref/immediate (annotation . idx) (obj))
+ (emit-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
+ (($ $primcall 'tail-pointer-ref/immediate (annotation . idx) (obj))
+ (emit-tail-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj))
+ idx))
+ (($ $primcall 'cache-ref key ())
+ (emit-cache-ref asm (from-sp dst) key))
+ (($ $primcall 'resolve-module public? (name))
+ (emit-resolve-module asm (from-sp dst) (from-sp (slot name)) public?))
+ (($ $primcall 'lookup #f (mod name))
+ (emit-lookup asm (from-sp dst) (from-sp (slot mod)) (from-sp (slot name))))
+ (($ $primcall 'add/immediate y (x))
+ (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'sub/immediate y (x))
+ (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'uadd/immediate y (x))
+ (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'usub/immediate y (x))
+ (emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'umul/immediate y (x))
+ (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'rsh (x y))
+ (emit-rsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
+ (($ $primcall 'lsh (x y))
+ (emit-lsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
+ (($ $primcall 'rsh/immediate y (x))
+ (emit-rsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'lsh/immediate y (x))
+ (emit-lsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'ursh/immediate y (x))
+ (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'srsh/immediate y (x))
+ (emit-srsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'ulsh/immediate y (x))
+ (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'builtin-ref idx ())
+ (emit-builtin-ref asm (from-sp dst) idx))
+ (($ $primcall 'scm->f64 #f (src))
(emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'load-f64 (src))
- (emit-load-f64 asm (from-sp dst) (constant src)))
- (($ $primcall 'f64->scm (src))
- (emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'scm->u64 (src))
+ (($ $primcall 'load-f64 val ())
+ (emit-load-f64 asm (from-sp dst) val))
+ (($ $primcall 'scm->u64 #f (src))
(emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'scm->u64/truncate (src))
+ (($ $primcall 'scm->u64/truncate #f (src))
(emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'load-u64 (src))
- (emit-load-u64 asm (from-sp dst) (constant src)))
- (($ $primcall 'u64->scm (src))
+ (($ $primcall 'load-u64 val ())
+ (emit-load-u64 asm (from-sp dst) val))
+ (($ $primcall 'u64->scm #f (src))
(emit-u64->scm asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'scm->s64 (src))
+ (($ $primcall 'scm->s64 #f (src))
(emit-scm->s64 asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'load-s64 (src))
- (emit-load-s64 asm (from-sp dst) (constant src)))
- (($ $primcall 's64->scm (src))
+ (($ $primcall 'load-s64 val ())
+ (emit-load-s64 asm (from-sp dst) val))
+ (($ $primcall 's64->scm #f (src))
(emit-s64->scm asm (from-sp dst) (from-sp (slot src))))
- (($ $primcall 'bv-length (bv))
- (emit-bv-length asm (from-sp dst) (from-sp (slot bv))))
- (($ $primcall 'bv-u8-ref (bv idx))
- (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-s8-ref (bv idx))
- (emit-bv-s8-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-u16-ref (bv idx))
- (emit-bv-u16-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-s16-ref (bv idx))
- (emit-bv-s16-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-u32-ref (bv idx val))
- (emit-bv-u32-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-s32-ref (bv idx val))
- (emit-bv-s32-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-u64-ref (bv idx val))
- (emit-bv-u64-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-s64-ref (bv idx val))
- (emit-bv-s64-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-f32-ref (bv idx val))
- (emit-bv-f32-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'bv-f64-ref (bv idx val))
- (emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv))
- (from-sp (slot idx))))
- (($ $primcall 'make-atomic-box (init))
- (emit-make-atomic-box asm (from-sp dst) (from-sp (slot init))))
- (($ $primcall 'atomic-box-ref (box))
- (emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box))))
- (($ $primcall 'atomic-box-swap! (box val))
- (emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box))
- (from-sp (slot val))))
- (($ $primcall 'atomic-box-compare-and-swap! (box expected desired))
- (emit-atomic-box-compare-and-swap!
- asm (from-sp dst) (from-sp (slot box))
- (from-sp (slot expected)) (from-sp (slot desired))))
- (($ $primcall name args)
+
+ (($ $primcall 'u8-ref ann (obj ptr idx))
+ (emit-u8-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's8-ref ann (obj ptr idx))
+ (emit-s8-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'u16-ref ann (obj ptr idx))
+ (emit-u16-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's16-ref ann (obj ptr idx))
+ (emit-s16-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'u32-ref ann (obj ptr idx))
+ (emit-u32-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's32-ref ann (obj ptr idx))
+ (emit-s32-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'u64-ref ann (obj ptr idx))
+ (emit-u64-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 's64-ref ann (obj ptr idx))
+ (emit-s64-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'f32-ref ann (obj ptr idx))
+ (emit-f32-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+ (($ $primcall 'f64-ref ann (obj ptr idx))
+ (emit-f64-ref asm (from-sp dst) (from-sp (slot ptr))
+ (from-sp (slot idx))))
+
+ (($ $primcall 'atomic-scm-ref/immediate (annotation . idx) (obj))
+ (emit-atomic-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj))
+ idx))
+ (($ $primcall 'atomic-scm-swap!/immediate (annotation . idx) (obj val))
+ (emit-atomic-scm-swap!/immediate asm (from-sp dst) (from-sp (slot obj))
+ idx (from-sp (slot val))))
+ (($ $primcall 'atomic-scm-compare-and-swap!/immediate (annotation . idx)
+ (obj expected desired))
+ (emit-atomic-scm-compare-and-swap!/immediate
+ asm (from-sp dst) (from-sp (slot obj)) idx (from-sp (slot expected))
+ (from-sp (slot desired))))
+
+ (($ $primcall 'untag-fixnum #f (src))
+ (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
+ (($ $primcall 'tag-fixnum #f (src))
+ (emit-tag-fixnum asm (from-sp dst) (from-sp (slot src))))
+ (($ $primcall 'untag-char #f (src))
+ (emit-untag-char asm (from-sp dst) (from-sp (slot src))))
+ (($ $primcall 'tag-char #f (src))
+ (emit-tag-char asm (from-sp dst) (from-sp (slot src))))
+ (($ $primcall name #f args)
;; FIXME: Inline all the cases.
- (let ((inst (prim-instruction name)))
- (emit-text asm `((,inst ,(from-sp dst)
- ,@(map (compose from-sp slot) args))))))))
+ (emit-text asm `((,name ,(from-sp dst)
+ ,@(map (compose from-sp 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 (from-sp (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-fmov asm dst src)))
- (lookup-parallel-moves handler allocation))
- (emit-reset-frame asm frame-size)
- (emit-br asm (forward-label khandler-body))))))
- (($ $primcall 'cache-current-module! (sym scope))
- (emit-cache-current-module! asm (from-sp (slot sym)) (constant scope)))
- (($ $primcall 'free-set! (closure idx value))
- (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
- (constant idx)))
- (($ $primcall 'box-set! (box value))
- (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
- (($ $primcall 'struct-set! (struct index value))
- (emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
- (from-sp (slot value))))
- (($ $primcall 'struct-set!/immediate (struct index value))
- (emit-struct-set!/immediate asm (from-sp (slot struct))
- (constant index) (from-sp (slot value))))
- (($ $primcall 'vector-set! (vector index value))
- (emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index))
- (from-sp (slot value))))
- (($ $primcall 'vector-set!/immediate (vector index value))
- (emit-vector-set!/immediate asm (from-sp (slot vector))
- (constant index) (from-sp (slot value))))
- (($ $primcall 'string-set! (string index char))
+ (($ $primcall 'cache-set! key (val))
+ (emit-cache-set! asm key (from-sp (slot val))))
+ (($ $primcall 'scm-set! annotation (obj idx val))
+ (emit-scm-set! asm (from-sp (slot obj)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'scm-set!/tag annotation (obj val))
+ (let ((tag (match annotation
+ ('pair %tc1-pair)
+ ('struct %tc3-struct))))
+ (emit-scm-set!/tag asm (from-sp (slot obj)) tag
+ (from-sp (slot val)))))
+ (($ $primcall 'scm-set!/immediate (annotation . idx) (obj val))
+ (emit-scm-set!/immediate asm (from-sp (slot obj)) idx
+ (from-sp (slot val))))
+ (($ $primcall 'word-set! annotation (obj idx val))
+ (emit-word-set! asm (from-sp (slot obj)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'word-set!/immediate (annotation . idx) (obj val))
+ (emit-word-set!/immediate asm (from-sp (slot obj)) idx
+ (from-sp (slot val))))
+ (($ $primcall 'pointer-set!/immediate (annotation . idx) (obj val))
+ (emit-pointer-set!/immediate asm (from-sp (slot obj)) idx
+ (from-sp (slot val))))
+ (($ $primcall 'string-set! #f (string index char))
(emit-string-set! asm (from-sp (slot string)) (from-sp (slot index))
(from-sp (slot char))))
- (($ $primcall 'set-car! (pair value))
- (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value))))
- (($ $primcall 'set-cdr! (pair value))
- (emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value))))
- (($ $primcall 'push-fluid (fluid val))
+ (($ $primcall 'push-fluid #f (fluid val))
(emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
- (($ $primcall 'pop-fluid ())
+ (($ $primcall 'pop-fluid #f ())
(emit-pop-fluid asm))
- (($ $primcall 'push-dynamic-state (state))
+ (($ $primcall 'push-dynamic-state #f (state))
(emit-push-dynamic-state asm (from-sp (slot state))))
- (($ $primcall 'pop-dynamic-state ())
+ (($ $primcall 'pop-dynamic-state #f ())
(emit-pop-dynamic-state asm))
- (($ $primcall 'wind (winder unwinder))
+ (($ $primcall 'wind #f (winder unwinder))
(emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
- (($ $primcall 'bv-u8-set! (bv idx val))
- (emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-s8-set! (bv idx val))
- (emit-bv-s8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-u16-set! (bv idx val))
- (emit-bv-u16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-s16-set! (bv idx val))
- (emit-bv-s16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-u32-set! (bv idx val))
- (emit-bv-u32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-s32-set! (bv idx val))
- (emit-bv-s32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-u64-set! (bv idx val))
- (emit-bv-u64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-s64-set! (bv idx val))
- (emit-bv-s64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-f32-set! (bv idx val))
- (emit-bv-f32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'bv-f64-set! (bv idx val))
- (emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
- (from-sp (slot val))))
- (($ $primcall 'unwind ())
+
+ (($ $primcall 'u8-set! ann (obj ptr idx val))
+ (emit-u8-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's8-set! ann (obj ptr idx val))
+ (emit-s8-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'u16-set! ann (obj ptr idx val))
+ (emit-u16-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's16-set! ann (obj ptr idx val))
+ (emit-s16-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'u32-set! ann (obj ptr idx val))
+ (emit-u32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's32-set! ann (obj ptr idx val))
+ (emit-s32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'u64-set! ann (obj ptr idx val))
+ (emit-u64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 's64-set! ann (obj ptr idx val))
+ (emit-s64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'f32-set! ann (obj ptr idx val))
+ (emit-f32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+ (($ $primcall 'f64-set! ann (obj ptr idx val))
+ (emit-f64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
+ (from-sp (slot val))))
+
+ (($ $primcall 'unwind #f ())
(emit-unwind asm))
- (($ $primcall 'fluid-set! (fluid value))
+ (($ $primcall 'fluid-set! #f (fluid value))
(emit-fluid-set! asm (from-sp (slot fluid)) (from-sp (slot value))))
- (($ $primcall 'atomic-box-set! (box val))
- (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
- (($ $primcall 'handle-interrupts ())
+ (($ $primcall 'atomic-scm-set!/immediate (annotation . idx) (obj val))
+ (emit-atomic-scm-set!/immediate asm (from-sp (slot obj)) idx
+ (from-sp (slot val))))
+ (($ $primcall 'instrument-loop #f ())
+ (emit-instrument-loop asm)
(emit-handle-interrupts asm))))
+ (define (compile-throw op param args)
+ (match (vector op param args)
+ (#('throw #f (key args))
+ (emit-throw asm (from-sp (slot key)) (from-sp (slot args))))
+ (#('throw/value param (val))
+ (emit-throw/value asm (from-sp (slot val)) param))
+ (#('throw/value+data param (val))
+ (emit-throw/value+data asm (from-sp (slot val)) param))))
+
+ (define (compile-prompt label k kh escape? tag)
+ (match (intmap-ref cps kh)
+ (($ $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 (from-sp (slot tag)) escape? proc-slot
+ receive-args)
+ (emit-j 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 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-fmov asm dst src)))
+ (lookup-parallel-moves kh allocation))
+ (emit-reset-frame asm frame-size)
+ (emit-j asm (forward-label khandler-body))))))
+
(define (compile-values label exp syms)
(match exp
(($ $values args)
@@ -386,7 +410,7 @@
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)))))
- (define (compile-test label exp kt kf next-label)
+ (define (compile-test label next-label kf kt op param args)
(define (prefer-true?)
(if (< (max kt kf) label)
;; Two backwards branches. Prefer
@@ -395,82 +419,120 @@
;; Otherwise prefer a backwards
;; branch or a near jump.
(< kt kf)))
- (define (unary op sym)
+ (define (emit-branch emit-jt emit-jf)
(cond
((eq? kt next-label)
- (op asm (from-sp (slot sym)) #t kf))
+ (emit-jf asm kf))
((eq? kf next-label)
- (op asm (from-sp (slot sym)) #f kt))
+ (emit-jt asm kt))
+ ((prefer-true?)
+ (emit-jt asm kt)
+ (emit-j asm kf))
(else
- (let ((invert? (not (prefer-true?))))
- (op asm (from-sp (slot sym)) invert? (if invert? kf kt))
- (emit-br asm (if invert? kt kf))))))
- (define (binary op a b)
- (cond
- ((eq? kt next-label)
- (op asm (from-sp (slot a)) (from-sp (slot b)) #t kf))
- ((eq? kf next-label)
- (op asm (from-sp (slot a)) (from-sp (slot b)) #f kt))
- (else
- (let ((invert? (not (prefer-true?))))
- (op asm (from-sp (slot a)) (from-sp (slot b)) invert?
- (if invert? kf kt))
- (emit-br asm (if invert? kt kf))))))
- (match exp
- (($ $values (sym)) (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 '< (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 'u64-< (a b)) (binary emit-br-if-u64-< a b))
- (($ $primcall 'u64-<= (a b)) (binary emit-br-if-u64-<= a b))
- (($ $primcall 'u64-= (a b)) (binary emit-br-if-u64-= a b))
- (($ $primcall 'u64->= (a b)) (binary emit-br-if-u64-<= b a))
- (($ $primcall 'u64-> (a b)) (binary emit-br-if-u64-< b a))
- (($ $primcall 'u64-<-scm (a b)) (binary emit-br-if-u64-<-scm a b))
- (($ $primcall 'u64-<=-scm (a b)) (binary emit-br-if-u64-<=-scm a b))
- (($ $primcall 'u64-=-scm (a b)) (binary emit-br-if-u64-=-scm a b))
- (($ $primcall 'u64->=-scm (a b)) (binary emit-br-if-u64->=-scm a b))
- (($ $primcall 'u64->-scm (a b)) (binary emit-br-if-u64->-scm a b))
- (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))
- (($ $primcall 'f64-< (a b)) (binary emit-br-if-f64-< a b))
- (($ $primcall 'f64-<= (a b)) (binary emit-br-if-f64-<= a b))
- (($ $primcall 'f64-= (a b)) (binary emit-br-if-f64-= a b))
- (($ $primcall 'f64->= (a b)) (binary emit-br-if-f64->= a b))
- (($ $primcall 'f64-> (a b)) (binary emit-br-if-f64-> a b))))
+ (emit-jf asm kf)
+ (emit-j asm kt))))
+ (define (unary op a)
+ (op asm (from-sp (slot a)))
+ (emit-branch emit-je emit-jne))
+ (define (binary op emit-jt emit-jf a b)
+ (op asm (from-sp (slot a)) (from-sp (slot b)))
+ (emit-branch emit-jt emit-jf))
+ (define (binary-test op a b)
+ (binary op emit-je emit-jne a b))
+ (define (binary-< emit-<? a b)
+ (binary emit-<? emit-jl emit-jnl a b))
+ (define (binary-<= emit-<? a b)
+ (binary emit-<? emit-jge emit-jnge b a))
+ (define (binary-test/imm op a b)
+ (op asm (from-sp (slot a)) b)
+ (emit-branch emit-je emit-jne))
+ (define (binary-</imm op a b)
+ (op asm (from-sp (slot a)) b)
+ (emit-branch emit-jl emit-jnl))
+ (match (vector op param args)
+ ;; Immediate type tag predicates.
+ (#('fixnum? #f (a)) (unary emit-fixnum? a))
+ (#('heap-object? #f (a)) (unary emit-heap-object? a))
+ (#('char? #f (a)) (unary emit-char? a))
+ (#('eq-false? #f (a)) (unary emit-eq-false? a))
+ (#('eq-nil? #f (a)) (unary emit-eq-nil? a))
+ (#('eq-null? #f (a)) (unary emit-eq-null? a))
+ (#('eq-true? #f (a)) (unary emit-eq-true? a))
+ (#('unspecified? #f (a)) (unary emit-unspecified? a))
+ (#('undefined? #f (a)) (unary emit-undefined? a))
+ (#('eof-object? #f (a)) (unary emit-eof-object? a))
+ (#('null? #f (a)) (unary emit-null? a))
+ (#('false? #f (a)) (unary emit-false? a))
+ (#('nil? #f (a)) (unary emit-nil? a))
+ ;; Heap type tag predicates.
+ (#('pair? #f (a)) (unary emit-pair? a))
+ (#('struct? #f (a)) (unary emit-struct? a))
+ (#('symbol? #f (a)) (unary emit-symbol? a))
+ (#('variable? #f (a)) (unary emit-variable? a))
+ (#('vector? #f (a)) (unary emit-vector? a))
+ (#('mutable-vector? #f (a)) (unary emit-mutable-vector? a))
+ (#('immutable-vector? #f (a)) (unary emit-immutable-vector? a))
+ (#('string? #f (a)) (unary emit-string? a))
+ (#('heap-number? #f (a)) (unary emit-heap-number? a))
+ (#('hash-table? #f (a)) (unary emit-hash-table? a))
+ (#('pointer? #f (a)) (unary emit-pointer? a))
+ (#('fluid? #f (a)) (unary emit-fluid? a))
+ (#('stringbuf? #f (a)) (unary emit-stringbuf? a))
+ (#('dynamic-state? #f (a)) (unary emit-dynamic-state? a))
+ (#('frame? #f (a)) (unary emit-frame? a))
+ (#('keyword? #f (a)) (unary emit-keyword? a))
+ (#('atomic-box? #f (a)) (unary emit-atomic-box? a))
+ (#('syntax? #f (a)) (unary emit-syntax? a))
+ (#('program? #f (a)) (unary emit-program? a))
+ (#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
+ (#('bytevector? #f (a)) (unary emit-bytevector? a))
+ (#('weak-set? #f (a)) (unary emit-weak-set? a))
+ (#('weak-table? #f (a)) (unary emit-weak-table? a))
+ (#('array? #f (a)) (unary emit-array? a))
+ (#('bitvector? #f (a)) (unary emit-bitvector? a))
+ (#('smob? #f (a)) (unary emit-smob? a))
+ (#('port? #f (a)) (unary emit-port? a))
+ (#('bignum? #f (a)) (unary emit-bignum? a))
+ (#('flonum? #f (a)) (unary emit-flonum? a))
+ (#('compnum? #f (a)) (unary emit-compnum? a))
+ (#('fracnum? #f (a)) (unary emit-fracnum? a))
+ ;; Binary predicates.
+ (#('eq? #f (a b)) (binary-test emit-eq? a b))
+ (#('heap-numbers-equal? #f (a b))
+ (binary-test emit-heap-numbers-equal? a b))
+ (#('< #f (a b)) (binary-< emit-<? a b))
+ (#('<= #f (a b)) (binary-<= emit-<? a b))
+ (#('= #f (a b)) (binary-test emit-=? a b))
+ (#('u64-< #f (a b)) (binary-< emit-u64<? a b))
+ (#('u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
+ (#('imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
+ (#('u64-= #f (a b)) (binary-test emit-u64=? a b))
+ (#('u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
+ (#('s64-= #f (a b)) (binary-test emit-u64=? a b))
+ (#('s64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
+ (#('s64-< #f (a b)) (binary-< emit-s64<? a b))
+ (#('s64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
+ (#('imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
+ (#('f64-< #f (a b)) (binary-< emit-f64<? a b))
+ (#('f64-<= #f (a b)) (binary-<= emit-f64<? a b))
+ (#('f64-= #f (a b)) (binary-test emit-f64=? 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)))
+ (nclosure (if proc 1 0))
+ (nargs (+ nclosure (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
+ (emit-handle-interrupts asm)
(emit-call asm proc-slot nargs)
(emit-slot-map asm proc-slot (lookup-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)
+ ((((? (lambda (src) (= src proc-slot)) src)
. dst)) dst)
(_ #f)))
;; The usual case: one required live return value, ignoring
@@ -481,7 +543,7 @@
(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)))
+ (emit-bind-rest asm (+ proc-slot nreq)))
(for-each (match-lambda
((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves k allocation))
@@ -506,7 +568,7 @@
(fallthrough? (= forwarded-k (skip-elided-conts (1+ label)))))
(define (maybe-emit-jump)
(unless fallthrough?
- (emit-br asm forwarded-k)))
+ (emit-j asm forwarded-k)))
(match (intmap-ref cps k)
(($ $ktail)
(compile-tail label exp))
@@ -516,13 +578,8 @@
(compile-value label exp dst)))
(maybe-emit-jump))
(($ $kargs () ())
- (match exp
- (($ $branch kt exp)
- (compile-test label exp (forward-label kt) forwarded-k
- (skip-elided-conts (1+ label))))
- (_
- (compile-effect label exp k)
- (maybe-emit-jump))))
+ (compile-effect label exp k)
+ (maybe-emit-jump))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
@@ -535,7 +592,29 @@
(fallthrough? (and fallthrough?
(= kargs (skip-elided-conts (1+ k))))))
(unless fallthrough?
- (emit-br asm kargs)))))))
+ (emit-j asm kargs)))))))
+
+ (define (compile-term label term)
+ (match term
+ (($ $continue k src exp)
+ (when src
+ (emit-source asm src))
+ (unless (elide-cont? label)
+ (compile-expression label k exp)))
+ (($ $branch kf kt src op param args)
+ (when src
+ (emit-source asm src))
+ (compile-test label (skip-elided-conts (1+ label))
+ (forward-label kf) (forward-label kt)
+ op param args))
+ (($ $prompt k kh src escape? tag)
+ (when src
+ (emit-source asm src))
+ (compile-prompt label (skip-elided-conts k) kh escape? tag))
+ (($ $throw src op param args)
+ (when src
+ (emit-source asm src))
+ (compile-throw op param args))))
(define (compile-cont label cont)
(match cont
@@ -547,6 +626,8 @@
(let ((first? (match (intmap-ref cps (1- label))
(($ $kfun) #t)
(_ #f)))
+ (has-closure? (match (intmap-ref cps (intmap-next cps))
+ (($ $kfun src meta self tail) (->bool self))))
(kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
@@ -554,16 +635,17 @@
(unless first?
(emit-end-arity asm))
(emit-label asm label)
- (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
- frame-size alt)
- ;; All arities define a closure binding in slot 0.
- (emit-definition asm 'closure 0 'scm)
+ (emit-begin-kw-arity asm has-closure? req opt rest kw-indices
+ allow-other-keys? frame-size alt)
+ (when has-closure?
+ ;; Most arities define a closure binding in slot 0.
+ (emit-definition asm 'closure 0 'scm))
;; Usually we just fall through, but it could be the body is
;; contified into another clause.
(let ((body (forward-label body)))
(unless (= body (skip-elided-conts (1+ label)))
- (emit-br asm body)))))
- (($ $kargs names vars ($ $continue k src exp))
+ (emit-j asm body)))))
+ (($ $kargs names vars term)
(emit-label asm label)
(for-each (lambda (name var)
(let ((slot (maybe-slot var)))
@@ -571,10 +653,7 @@
(let ((repr (lookup-representation var allocation)))
(emit-definition asm name slot repr)))))
names vars)
- (when src
- (emit-source asm src))
- (unless (elide-cont? label)
- (compile-expression label k exp)))
+ (compile-term label term))
(($ $kreceive arity kargs)
(emit-label asm label))
(($ $ktail)
@@ -602,7 +681,7 @@
(set! exp (convert-closures exp))
(set! exp (optimize-first-order-cps exp opts))
(set! exp (reify-primitives exp))
- (set! exp (add-handle-interrupts exp))
+ (set! exp (add-loop-instrumentation exp))
(renumber exp))
(define (compile-bytecode exp env opts)