diff options
Diffstat (limited to 'module/language/cps/compile-bytecode.scm')
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 691 |
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) |