summaryrefslogtreecommitdiff
path: root/module/system/vm/assembler.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/assembler.scm')
-rw-r--r--module/system/vm/assembler.scm738
1 files changed, 491 insertions, 247 deletions
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 8d71dc551..c9e9f5f7b 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1,6 +1,6 @@
;;; Guile bytecode assembler
-;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009-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
@@ -44,6 +44,7 @@
(define-module (system vm assembler)
#:use-module (system base target)
+ #:use-module (system base types internal)
#:use-module (system vm dwarf)
#:use-module (system vm elf)
#:use-module (system vm linker)
@@ -63,97 +64,196 @@
(emit-mov* . emit-mov)
(emit-fmov* . emit-fmov)
+ emit-u64=?
+ emit-u64<?
+ emit-u64-imm<?
+ emit-imm-u64<?
+ emit-s64-imm=?
+ emit-s64<?
+ emit-s64-imm<?
+ emit-imm-s64<?
+ emit-f64=?
+ emit-f64<?
+ emit-=?
+ emit-<?
+ emit-arguments<=?
+ emit-positional-arguments<=?
+ emit-immediate-tag=?
+ emit-heap-tag=?
+ emit-eq?
+ emit-heap-numbers-equal?
+ emit-j
+ emit-jl
+ emit-je
+ emit-jnl
+ emit-jne
+ emit-jge
+ emit-jnge
+
+ emit-fixnum?
+ emit-heap-object?
+ emit-char?
+ emit-eq-null?
+ emit-eq-nil?
+ emit-eq-false?
+ emit-eq-true?
+ emit-unspecified?
+ emit-undefined?
+ emit-eof-object?
+
+ emit-untag-fixnum
+ emit-tag-fixnum
+ emit-untag-char
+ emit-tag-char
+
+ emit-throw
+ (emit-throw/value* . emit-throw/value)
+ (emit-throw/value+data* . emit-throw/value+data)
+
+ emit-pair?
+ emit-struct?
+ emit-symbol?
+ emit-variable?
+ emit-vector?
+ emit-mutable-vector?
+ emit-immutable-vector?
+ emit-weak-vector?
+ emit-string?
+ emit-heap-number?
+ emit-hash-table?
+ emit-pointer?
+ emit-fluid?
+ emit-stringbuf?
+ emit-dynamic-state?
+ emit-frame?
+ emit-keyword?
+ emit-syntax?
+ emit-program?
+ emit-vm-continuation?
+ emit-bytevector?
+ emit-weak-set?
+ emit-weak-table?
+ emit-array?
+ emit-bitvector?
+ emit-port?
+ emit-smob?
+ emit-bignum?
+ emit-flonum?
+ emit-compnum?
+ emit-fracnum?
+
+ emit-allocate-words
+ emit-allocate-words/immediate
+
+ emit-scm-ref
+ emit-scm-set!
+ emit-scm-ref/tag
+ emit-scm-set!/tag
+ emit-scm-ref/immediate
+ emit-scm-set!/immediate
+
+ emit-word-ref
+ emit-word-set!
+ emit-word-ref/immediate
+ emit-word-set!/immediate
+
+ emit-pointer-ref/immediate
+ emit-pointer-set!/immediate
+ emit-tail-pointer-ref/immediate
+
+ emit-u8-ref
+ emit-s8-ref
+ emit-u16-ref
+ emit-s16-ref
+ emit-u32-ref
+ emit-s32-ref
+ emit-u64-ref
+ emit-s64-ref
+ emit-f32-ref
+ emit-f64-ref
+ emit-u8-set!
+ emit-s8-set!
+ emit-u16-set!
+ emit-s16-set!
+ emit-u32-set!
+ emit-s32-set!
+ emit-u64-set!
+ emit-s64-set!
+ emit-f32-set!
+ emit-f64-set!
+
+ emit-atomic-scm-ref/immediate
+ emit-atomic-scm-set!/immediate
+ emit-atomic-scm-swap!/immediate
+ emit-atomic-scm-compare-and-swap!/immediate
+
+ ;; Intrinsics.
+ emit-add
+ emit-add/immediate
+ emit-sub
+ emit-sub/immediate
+ emit-mul
+ emit-div
+ emit-quo
+ emit-rem
+ emit-mod
+ emit-logand
+ emit-logior
+ emit-logxor
+ emit-logsub
+ emit-string-set!
+ emit-string->number
+ emit-string->symbol
+ emit-symbol->keyword
+ emit-class-of
+ emit-scm->f64
+ emit-scm->u64
+ emit-scm->u64/truncate
+ emit-scm->s64
+ emit-u64->scm
+ emit-s64->scm
+ emit-wind
+ emit-unwind
+ emit-push-fluid
+ emit-pop-fluid
+ emit-fluid-ref
+ emit-fluid-set!
+ emit-push-dynamic-state
+ emit-pop-dynamic-state
+ emit-lsh
+ emit-rsh
+ emit-lsh/immediate
+ emit-rsh/immediate
+ emit-resolve-module
+ emit-lookup
+ emit-define!
+ emit-current-module
+
+ emit-cache-ref
+ emit-cache-set!
+
emit-call
emit-call-label
emit-tail-call
emit-tail-call-label
+ (emit-instrument-entry* . emit-instrument-entry)
+ (emit-instrument-loop* . emit-instrument-loop)
emit-receive-values
- emit-return
emit-return-values
emit-call/cc
emit-abort
emit-builtin-ref
- emit-br-if-nargs-ne
- emit-br-if-nargs-lt
- emit-br-if-nargs-gt
emit-assert-nargs-ee
emit-assert-nargs-ge
emit-assert-nargs-le
- emit-alloc-frame
emit-reset-frame
emit-assert-nargs-ee/locals
- emit-br-if-npos-gt
emit-bind-kwargs
emit-bind-rest
- emit-br
- emit-br-if-true
- emit-br-if-null
- emit-br-if-nil
- emit-br-if-pair
- emit-br-if-struct
- emit-br-if-char
- emit-br-if-tc7
- emit-br-if-eq
- emit-br-if-eqv
- emit-br-if-=
- emit-br-if-<
- emit-br-if-<=
- emit-br-if-logtest
- emit-br-if-u64-=
- emit-br-if-u64-<
- emit-br-if-u64-<=
- emit-br-if-u64-<-scm
- emit-br-if-u64-<=-scm
- emit-br-if-u64-=-scm
- emit-br-if-u64->=-scm
- emit-br-if-u64->-scm
- emit-br-if-f64-=
- emit-br-if-f64-<
- emit-br-if-f64-<=
- emit-br-if-f64->
- emit-br-if-f64->=
- emit-box
- emit-box-ref
- emit-box-set!
- emit-make-closure
- emit-free-ref
- emit-free-set!
- emit-current-module
+ emit-load-label
emit-resolve
- emit-define!
- emit-toplevel-box
- emit-module-box
emit-prompt
- emit-wind
- emit-unwind
- emit-push-fluid
- emit-pop-fluid
- emit-push-dynamic-state
- emit-pop-dynamic-state
emit-current-thread
- emit-fluid-ref
- emit-fluid-set!
- emit-string-length
- emit-string-ref
- emit-string-set!
- emit-string->number
- emit-string->symbol
- emit-symbol->keyword
- emit-cons
- emit-car
- emit-cdr
- emit-set-car!
- emit-set-cdr!
- emit-add
- emit-add/immediate
- emit-sub
- emit-sub/immediate
- emit-mul
- emit-div
- emit-quo
- emit-rem
- emit-mod
- emit-ash
emit-fadd
emit-fsub
emit-fmul
@@ -164,72 +264,20 @@
emit-uadd/immediate
emit-usub/immediate
emit-umul/immediate
- emit-logand
- emit-logior
- emit-logxor
- emit-logsub
emit-ulogand
emit-ulogior
emit-ulogxor
emit-ulogsub
emit-ursh
+ emit-srsh
emit-ulsh
emit-ursh/immediate
+ emit-srsh/immediate
emit-ulsh/immediate
- emit-char->integer
- emit-integer->char
- emit-make-vector
- emit-make-vector/immediate
- emit-vector-length
- emit-vector-ref
- emit-vector-ref/immediate
- emit-vector-set!
- emit-vector-set!/immediate
- emit-struct-vtable
- emit-allocate-struct/immediate
- emit-struct-ref/immediate
- emit-struct-set!/immediate
- emit-allocate-struct
- emit-struct-ref
- emit-struct-set!
- emit-class-of
emit-make-array
- emit-scm->f64
emit-load-f64
- emit-f64->scm
- emit-scm->u64
- emit-scm->u64/truncate
emit-load-u64
- emit-u64->scm
- emit-scm->s64
emit-load-s64
- emit-s64->scm
- emit-bv-length
- emit-bv-u8-ref
- emit-bv-s8-ref
- emit-bv-u16-ref
- emit-bv-s16-ref
- emit-bv-u32-ref
- emit-bv-s32-ref
- emit-bv-u64-ref
- emit-bv-s64-ref
- emit-bv-f32-ref
- emit-bv-f64-ref
- emit-bv-u8-set!
- emit-bv-s8-set!
- emit-bv-u16-set!
- emit-bv-s16-set!
- emit-bv-u32-set!
- emit-bv-s32-set!
- emit-bv-u64-set!
- emit-bv-s64-set!
- emit-bv-f32-set!
- emit-bv-f64-set!
- emit-make-atomic-box
- emit-atomic-box-ref
- emit-atomic-box-set!
- emit-atomic-box-swap!
- emit-atomic-box-compare-and-swap!
emit-handle-interrupts
emit-text
@@ -255,10 +303,9 @@
;;; These helpers create one 32-bit unit from multiple components.
(define-inline (check-urange x mask)
- (let ((x* (logand x mask)))
- (unless (= x x*)
- (error "out of range" x))
- x*))
+ (unless (and (exact-integer? x) (= x (logand x mask)))
+ (error "out of range" x))
+ x)
(define-inline (check-srange x mask)
(let ((x* (logand x mask)))
@@ -278,6 +325,11 @@
(y (check-srange y #xffffff)))
(logior x (ash y 8))))
+(define-inline (pack-u16-u16 x y)
+ (let ((x (check-urange x #xffff))
+ (y (check-urange y #xffff)))
+ (logior x (ash y 16))))
+
(define-inline (pack-u1-u7-u24 x y z)
(let ((x (check-urange x #x1))
(y (check-urange y #x7f))
@@ -290,6 +342,12 @@
(z (check-urange z #xfff)))
(logior x (ash y 8) (ash z 20))))
+(define-inline (pack-u8-u12-s12 x y z)
+ (let ((x (check-urange x #xff))
+ (y (check-urange y #xfff))
+ (z (check-srange z #xfff)))
+ (logior x (ash y 8) (ash z 20))))
+
(define-inline (pack-u8-u8-u16 x y z)
(let ((x (check-urange x #xff))
(y (check-urange y #xff))
@@ -340,19 +398,26 @@ N-byte unit."
(unless (match x (pattern #t) (_ #f))
(error (string-append "expected " kind) x)))))
+(define-record-type <jit-data>
+ (make-jit-data low-pc high-pc)
+ jit-data?
+ (low-pc jit-data-low-pc)
+ (high-pc jit-data-high-pc))
+
(define-record-type <meta>
- (%make-meta label properties low-pc high-pc arities)
+ (%make-meta label properties low-pc high-pc arities jit-data-label)
meta?
(label meta-label)
(properties meta-properties set-meta-properties!)
(low-pc meta-low-pc)
(high-pc meta-high-pc set-meta-high-pc!)
- (arities meta-arities set-meta-arities!))
+ (arities meta-arities set-meta-arities!)
+ (jit-data-label meta-jit-data-label))
(define (make-meta label properties low-pc)
(assert-match label (or (? exact-integer?) (? symbol?)) "symbol")
(assert-match properties (((? symbol?) . _) ...) "alist with symbolic keys")
- (%make-meta label properties low-pc #f '()))
+ (%make-meta label properties low-pc #f '() (gensym "jit-data")))
(define (meta-name meta)
(assq-ref (meta-properties meta) 'name))
@@ -411,7 +476,7 @@ N-byte unit."
(labels asm-labels set-asm-labels!)
;; A list of relocations needed by the program text. We use an
- ;; internal representation for relocations, and handle textualn
+ ;; internal representation for relocations, and handle textual
;; relative relocations in the assembler. Other kinds of relocations
;; are later reified as linker relocations and resolved by the linker.
;;
@@ -566,6 +631,8 @@ later by the linker."
(emit asm (pack-u8-u12-u12 opcode a b)))
((X8_S12_C12 a b)
(emit asm (pack-u8-u12-u12 opcode a b)))
+ ((X8_S12_Z12 a b)
+ (emit asm (pack-u8-u12-s12 opcode a b)))
((X8_C12_C12 a b)
(emit asm (pack-u8-u12-u12 opcode a b)))
((X8_F12_F12 a b)
@@ -621,6 +688,10 @@ later by the linker."
(emit asm 0))
((C8_C24 a b)
(emit asm (pack-u8-u24 a b)))
+ ((C8_S24 a b)
+ (emit asm (pack-u8-u24 a b)))
+ ((C16_C16 a b)
+ (emit asm (pack-u16-u16 a b)))
((B1_X7_L24 a label)
(record-label-reference asm label)
(emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
@@ -733,23 +804,14 @@ later by the linker."
(emit-push asm a)
(encode-X8_S12_S12 asm 0 0 opcode)
(emit-pop asm dst))))
-(define (encode-X8_S12_S12-X8_C24!/shuffle asm a b c opcode)
- (cond
- ((< (logior a b) (ash 1 12))
- (encode-X8_S12_S12-X8_C24 asm a b c opcode))
- (else
- (emit-push asm a)
- (emit-push asm (1+ b))
- (encode-X8_S12_S12-X8_C24 asm 1 0 c opcode)
- (emit-drop asm 2))))
-(define (encode-X8_S12_S12-X8_C24<-/shuffle asm dst a const opcode)
+(define (encode-X8_S12_C12!/shuffle asm a const opcode)
(cond
- ((< (logior dst a) (ash 1 12))
- (encode-X8_S12_S12-X8_C24 asm dst a const opcode))
+ ((< a (ash 1 12))
+ (encode-X8_S12_C12 asm a const opcode))
(else
(emit-push asm a)
- (encode-X8_S12_S12-X8_C24 asm 0 0 const opcode)
- (emit-pop asm dst))))
+ (encode-X8_S12_C12 asm 0 const opcode)
+ (emit-drop asm 1))))
(define (encode-X8_S12_C12<-/shuffle asm dst const opcode)
(cond
((< dst (ash 1 12))
@@ -759,6 +821,14 @@ later by the linker."
(emit-push asm dst)
(encode-X8_S12_C12 asm 0 const opcode)
(emit-pop asm dst))))
+(define (encode-X8_S12_Z12!/shuffle asm a const opcode)
+ (cond
+ ((< a (ash 1 12))
+ (encode-X8_S12_Z12 asm a const opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S12_Z12 asm 0 const opcode)
+ (emit-drop asm 1))))
(define (encode-X8_S8_I16<-/shuffle asm dst imm opcode)
(cond
((< dst (ash 1 8))
@@ -813,6 +883,51 @@ later by the linker."
(emit-push asm a)
(encode-X8_S8_C8_S8 asm 0 const 0 opcode)
(emit-pop asm dst))))
+(define (encode-X8_S8_S8_S8-C32<-/shuffle asm dst a b c32 opcode)
+ (cond
+ ((< (logior dst a b) (ash 1 8))
+ (encode-X8_S8_S8_S8-C32 asm dst a b c32 opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (1+ b))
+ (encode-X8_S8_S8_S8-C32 asm 1 1 0 c32 opcode)
+ (emit-drop asm 1)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_S8_C8-C32<-/shuffle asm dst a const c32 opcode)
+ (cond
+ ((< (logior dst a) (ash 1 8))
+ (encode-X8_S8_S8_C8-C32 asm dst a const c32 opcode))
+ (else
+ (emit-push asm a)
+ (encode-X8_S8_S8_C8-C32 asm 0 0 const c32 opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S8_S8_S8-C32!/shuffle asm a b c c32 opcode)
+ (cond
+ ((< (logior a b c) (ash 1 8))
+ (encode-X8_S8_S8_S8-C32 asm a b c c32 opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm (+ b 1))
+ (emit-push asm (+ c 2))
+ (encode-X8_S8_S8_S8-C32 asm 2 1 0 c32 opcode)
+ (emit-drop asm 3))))
+(define (encode-X8_S12_S12-C32<-/shuffle asm dst src c32 opcode)
+ (cond
+ ((< (logior dst src) (ash 1 12))
+ (encode-X8_S12_S12-C32 asm dst src c32 opcode))
+ (else
+ (emit-push asm src)
+ (encode-X8_S12_S12-C32 asm 0 0 c32 opcode)
+ (emit-pop asm dst))))
+(define (encode-X8_S12_S12-C32!/shuffle asm a b c32 opcode)
+ (cond
+ ((< (logior a b) (ash 1 12))
+ (encode-X8_S12_S12-C32 asm a b c32 opcode))
+ (else
+ (emit-push asm a)
+ (emit-push asm b)
+ (encode-X8_S12_S12-C32 asm 1 0 c32 opcode)
+ (emit-drop asm 2))))
(eval-when (expand)
(define (id-append ctx a b)
@@ -824,11 +939,18 @@ later by the linker."
(('<- 'X8_S12_S12) #'encode-X8_S12_S12<-/shuffle)
(('! 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24!/shuffle)
(('<- 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24<-/shuffle)
+ (('! 'X8_S12_C12) #'encode-X8_S12_C12!/shuffle)
(('<- 'X8_S12_C12) #'encode-X8_S12_C12<-/shuffle)
+ (('! 'X8_S12_Z12) #'encode-X8_S12_Z12!/shuffle)
(('<- 'X8_S8_I16) #'encode-X8_S8_I16<-/shuffle)
(('! 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8!/shuffle)
(('<- 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8<-/shuffle)
(('<- 'X8_S8_S8_C8) #'encode-X8_S8_S8_C8<-/shuffle)
+ (('<- 'X8_S8_S8_S8 'C32) #'encode-X8_S8_S8_S8-C32<-/shuffle)
+ (('<- 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32<-/shuffle)
+ (('! 'X8_S8_S8_C8 'C32) #'encode-X8_S8_S8_C8-C32!/shuffle)
+ (('<- 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32<-/shuffle)
+ (('! 'X8_S12_S12 'C32) #'encode-X8_S12_S12-C32!/shuffle)
(('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle)
(('<- 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8<-/shuffle)
(else (encoder-name operands))))
@@ -852,6 +974,8 @@ later by the linker."
('L32 #'(label))
('LO32 #'(label offset))
('C8_C24 #'(a b))
+ ('C8_S24 #'(a b))
+ ('C16_C16 #'(a b))
('B1_X7_L24 #'(a label))
('B1_C7_L24 #'(a b label))
('B1_X31 #'(a))
@@ -865,6 +989,7 @@ later by the linker."
('X8_S8_I16 #'(a imm))
('X8_S12_S12 #'(a b))
('X8_S12_C12 #'(a b))
+ ('X8_S12_Z12 #'(a b))
('X8_C12_C12 #'(a b))
('X8_F12_F12 #'(a b))
('X8_S8_S8_S8 #'(a b c))
@@ -928,6 +1053,20 @@ later by the linker."
(emit-fmov* asm dst (1+ proc))
(emit-reset-frame asm nlocals))))
+(define (emit-throw/value* asm val param)
+ (emit-throw/value asm val (intern-non-immediate asm param)))
+
+(define (emit-throw/value+data* asm val param)
+ (emit-throw/value+data asm val (intern-non-immediate asm param)))
+
+(define (emit-instrument-entry* asm)
+ (let ((meta (car (asm-meta asm))))
+ (emit-instrument-entry asm (meta-jit-data-label meta))))
+
+(define (emit-instrument-loop* asm)
+ (let ((meta (car (asm-meta asm))))
+ (emit-instrument-loop asm (meta-jit-data-label meta))))
+
(define (emit-text asm instructions)
"Assemble @var{instructions} using the assembler @var{asm}.
@var{instructions} is a sequence of instructions, expressed as a list of
@@ -998,9 +1137,8 @@ immediate, and @code{#f} otherwise."
(element-size uniform-vector-backing-store-element-size))
(define-record-type <cache-cell>
- (make-cache-cell scope key)
+ (make-cache-cell key)
cache-cell?
- (scope cache-cell-scope)
(key cache-cell-key))
(define (simple-vector? obj)
@@ -1109,16 +1247,11 @@ label."
(error "expected a non-immediate" obj))
(intern-constant asm obj))
-(define (intern-cache-cell asm scope key)
+(define (intern-cache-cell asm key)
"Intern a cache cell into the constant table, and return its label.
If there is already a cache cell with the given scope and key, it is
returned instead."
- (intern-constant asm (make-cache-cell scope key)))
-
-;; Return the label of the cell that holds the module for a scope.
-(define (intern-module-cache-cell asm scope)
- "Intern a cache cell for a module, and return its label."
- (intern-cache-cell asm scope #t))
+ (intern-constant asm (make-cache-cell key)))
@@ -1161,60 +1294,133 @@ returned instead."
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
-(define-syntax-rule (define-tc7-macro-assembler name tc7)
- (define-macro-assembler (name asm slot invert? label)
- (emit-br-if-tc7 asm slot invert? tc7 label)))
-
-;; Keep in sync with tags.h. Part of Guile's ABI. Currently unused
-;; macro assemblers are commented out. See also
-;; *branching-primcall-arities* in (language cps primitives), the set of
-;; macro-instructions in assembly.scm, and
-;; disassembler.scm:code-annotation.
-;;
-;; FIXME: Define all tc7 values in Scheme in one place, derived from
-;; tags.h.
-(define-tc7-macro-assembler br-if-symbol #x05)
-(define-tc7-macro-assembler br-if-variable #x07)
-(define-tc7-macro-assembler br-if-vector #x0d)
-;(define-tc7-macro-assembler br-if-weak-vector 13)
-(define-tc7-macro-assembler br-if-string #x15)
-;(define-tc7-macro-assembler br-if-heap-number 23)
-;(define-tc7-macro-assembler br-if-stringbuf 39)
-(define-tc7-macro-assembler br-if-bytevector #x4d)
-;(define-tc7-macro-assembler br-if-pointer 31)
-;(define-tc7-macro-assembler br-if-hashtable 29)
-;(define-tc7-macro-assembler br-if-fluid 37)
-;(define-tc7-macro-assembler br-if-dynamic-state 45)
-;(define-tc7-macro-assembler br-if-frame 47)
-(define-tc7-macro-assembler br-if-keyword #x35)
-;(define-tc7-macro-assembler br-if-syntax #x3d)
-;(define-tc7-macro-assembler br-if-vm 55)
-;(define-tc7-macro-assembler br-if-vm-cont 71)
-;(define-tc7-macro-assembler br-if-rtl-program 69)
-;(define-tc7-macro-assembler br-if-weak-set 85)
-;(define-tc7-macro-assembler br-if-weak-table 87)
-;(define-tc7-macro-assembler br-if-array 93)
-(define-tc7-macro-assembler br-if-bitvector #x5f)
-;(define-tc7-macro-assembler br-if-port 125)
-;(define-tc7-macro-assembler br-if-smob 127)
+(define-syntax-rule (define-immediate-tag=?-macro-assembler name pred mask tag)
+ (define-macro-assembler (pred asm slot)
+ (emit-immediate-tag=? asm slot mask tag)))
+
+(visit-immediate-tags define-immediate-tag=?-macro-assembler)
+
+(define-syntax-rule (define-heap-tag=?-macro-assembler name pred mask tag)
+ (define-macro-assembler (pred asm slot)
+ (emit-heap-tag=? asm slot mask tag)))
+
+(visit-heap-tags define-heap-tag=?-macro-assembler)
+
+(define-syntax-rule (define-scm<-scm-scm-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-scm asm dst a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-uimm-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-uimm asm dst a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm-sz-u32-intrinsic name)
+ (define-macro-assembler (name asm a b c)
+ (emit-call-scm-sz-u32 asm a b c (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-f64<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-f64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-u64<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-u64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-s64<-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-s64<-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-u64-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-u64 asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-s64-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-s64 asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-intrinsic name)
+ (define-macro-assembler (name asm)
+ (emit-call-thread asm (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-scm-intrinsic name)
+ (define-macro-assembler (name asm a)
+ (emit-call-thread-scm asm a (intrinsic-name->index 'name))))
+(define-syntax-rule (define-thread-scm-scm-intrinsic name)
+ (define-macro-assembler (name asm a b)
+ (emit-call-thread-scm-scm asm a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-thread-scm-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-scm<-thread-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-u64-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-u64 asm dst a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-bool-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-uimm asm dst a (if b 1 0) (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-thread-intrinsic name)
+ (define-macro-assembler (name asm dst)
+ (emit-call-scm<-thread asm dst (intrinsic-name->index 'name))))
+
+(define-scm<-scm-scm-intrinsic add)
+(define-scm<-scm-uimm-intrinsic add/immediate)
+(define-scm<-scm-scm-intrinsic sub)
+(define-scm<-scm-uimm-intrinsic sub/immediate)
+(define-scm<-scm-scm-intrinsic mul)
+(define-scm<-scm-scm-intrinsic div)
+(define-scm<-scm-scm-intrinsic quo)
+(define-scm<-scm-scm-intrinsic rem)
+(define-scm<-scm-scm-intrinsic mod)
+(define-scm<-scm-scm-intrinsic logand)
+(define-scm<-scm-scm-intrinsic logior)
+(define-scm<-scm-scm-intrinsic logxor)
+(define-scm<-scm-scm-intrinsic logsub)
+(define-scm-sz-u32-intrinsic string-set!)
+(define-scm<-scm-intrinsic string->number)
+(define-scm<-scm-intrinsic string->symbol)
+(define-scm<-scm-intrinsic symbol->keyword)
+(define-scm<-scm-intrinsic class-of)
+(define-f64<-scm-intrinsic scm->f64)
+(define-u64<-scm-intrinsic scm->u64)
+(define-u64<-scm-intrinsic scm->u64/truncate)
+(define-s64<-scm-intrinsic scm->s64)
+(define-scm<-u64-intrinsic u64->scm)
+(define-scm<-s64-intrinsic s64->scm)
+(define-thread-scm-scm-intrinsic wind)
+(define-thread-intrinsic unwind)
+(define-thread-scm-scm-intrinsic push-fluid)
+(define-thread-intrinsic pop-fluid)
+(define-scm<-thread-scm-intrinsic fluid-ref)
+(define-thread-scm-scm-intrinsic fluid-set!)
+(define-thread-scm-intrinsic push-dynamic-state)
+(define-thread-intrinsic pop-dynamic-state)
+(define-scm<-scm-u64-intrinsic lsh)
+(define-scm<-scm-u64-intrinsic rsh)
+(define-scm<-scm-uimm-intrinsic lsh/immediate)
+(define-scm<-scm-uimm-intrinsic rsh/immediate)
+(define-scm<-scm-bool-intrinsic resolve-module)
+(define-scm<-scm-scm-intrinsic lookup)
+(define-scm<-scm-scm-intrinsic define!)
+(define-scm<-thread-intrinsic current-module)
(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
(let ((meta (make-meta label properties (asm-start asm))))
- (set-asm-meta! asm (cons meta (asm-meta asm)))))
+ (set-asm-meta! asm (cons meta (asm-meta asm))))
+ (emit-instrument-entry* asm))
(define-macro-assembler (end-program asm)
(let ((meta (car (asm-meta asm))))
(set-meta-high-pc! meta (asm-start asm))
- (set-meta-arities! meta (reverse (meta-arities meta)))))
-
-(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
- (emit-begin-opt-arity asm req '() #f nlocals alternate))
-
-(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
- (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
-
-(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+ (set-meta-arities! meta (reverse (meta-arities meta)))
+ (set-asm-constants!
+ asm
+ (vhash-cons (make-jit-data (meta-low-pc meta) (meta-high-pc meta))
+ (meta-jit-data-label meta)
+ (asm-constants asm)))))
+
+(define-macro-assembler (begin-standard-arity asm has-closure? req nlocals
+ alternate)
+ (emit-begin-opt-arity asm has-closure? req '() #f nlocals alternate))
+
+(define-macro-assembler (begin-opt-arity asm has-closure? req opt rest nlocals
+ alternate)
+ (emit-begin-kw-arity asm has-closure? req opt rest '() #f nlocals alternate))
+
+(define-macro-assembler (begin-kw-arity asm has-closure? req opt rest kw-indices
allow-other-keys? nlocals alternate)
(assert-match req ((? symbol?) ...) "list of symbols")
(assert-match opt ((? symbol?) ...) "list of symbols")
@@ -1226,11 +1432,17 @@ returned instead."
(assert-match alternate (or #f (? exact-integer?) (? symbol?)) "#f or symbol")
(let* ((meta (car (asm-meta asm)))
(arity (make-arity req opt rest kw-indices allow-other-keys?
- (asm-start asm) #f '()))
+ ;; Include the initial instrument-entry in
+ ;; the first arity.
+ (if (null? (meta-arities meta))
+ (meta-low-pc meta)
+ (asm-start asm))
+ #f '()))
;; The procedure itself is in slot 0, in the standard calling
;; convention. For procedure prologues, nreq includes the
;; procedure, so here we add 1.
- (nreq (1+ (length req)))
+ (nclosure (if has-closure? 1 0))
+ (nreq (+ nclosure (length req)))
(nopt (length opt))
(rest? (->bool rest)))
(set-meta-arities! meta (cons arity (meta-arities meta)))
@@ -1251,7 +1463,8 @@ returned instead."
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(cond
(alternate
- (emit-br-if-nargs-ne asm nreq alternate)
+ (emit-arguments<=? asm nreq)
+ (emit-jne asm alternate)
(emit-alloc-frame asm nlocals))
((and (< nreq (ash 1 12)) (< (- nlocals nreq) (ash 1 12)))
(emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
@@ -1261,24 +1474,39 @@ returned instead."
(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
(if alternate
- (emit-br-if-nargs-lt asm nreq alternate)
+ (begin
+ (emit-arguments<=? asm nreq)
+ (emit-jl asm alternate))
(emit-assert-nargs-ge asm nreq))
(cond
(rest?
+ (unless (zero? nopt)
+ (emit-bind-optionals asm (+ nreq nopt)))
(emit-bind-rest asm (+ nreq nopt)))
(alternate
- (emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
+ (emit-arguments<=? asm (+ nreq nopt))
+ ;; The arguments<=? instruction sets NONE to indicate greater-than,
+ ;; whereas for <, NONE usually indicates greater-than-or-equal,
+ ;; hence the name jge. Perhaps we just need to rename jge to
+ ;; br-if-none.
+ (emit-jge asm alternate)
+ (unless (zero? nopt)
+ (emit-bind-optionals asm (+ nreq nopt))))
(else
- (emit-assert-nargs-le asm (+ nreq nopt))))
+ (emit-assert-nargs-le asm (+ nreq nopt))
+ (unless (zero? nopt)
+ (emit-bind-optionals asm (+ nreq nopt)))))
(emit-alloc-frame asm nlocals))
(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
allow-other-keys? nlocals alternate)
(if alternate
(begin
- (emit-br-if-nargs-lt asm nreq alternate)
+ (emit-arguments<=? asm nreq)
+ (emit-jl asm alternate)
(unless rest?
- (emit-br-if-npos-gt asm nreq (+ nreq nopt) alternate)))
+ (emit-positional-arguments<=? asm nreq (+ nreq nopt))
+ (emit-jge asm alternate)))
(emit-assert-nargs-ge asm nreq))
(let ((ntotal (fold (lambda (kw ntotal)
(match kw
@@ -1305,22 +1533,11 @@ returned instead."
(- (asm-start asm) (arity-low-pc arity)))))
(set-arity-definitions! arity (cons def (arity-definitions arity)))))
-(define-macro-assembler (cache-current-module! asm module scope)
- (let ((mod-label (intern-module-cache-cell asm scope)))
- (emit-static-set! asm module mod-label 0)))
+(define-macro-assembler (cache-ref asm dst key)
+ (emit-static-ref asm dst (intern-cache-cell asm key)))
-(define-macro-assembler (cached-toplevel-box asm dst scope sym bound?)
- (let ((sym-label (intern-non-immediate asm sym))
- (mod-label (intern-module-cache-cell asm scope))
- (cell-label (intern-cache-cell asm scope sym)))
- (emit-toplevel-box asm dst cell-label mod-label sym-label bound?)))
-
-(define-macro-assembler (cached-module-box asm dst module-name sym public? bound?)
- (let* ((sym-label (intern-non-immediate asm sym))
- (key (cons public? module-name))
- (mod-name-label (intern-constant asm key))
- (cell-label (intern-cache-cell asm key sym)))
- (emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
+(define-macro-assembler (cache-set! asm key val)
+ (emit-static-set! asm val (intern-cache-cell asm key) 0))
(define-macro-assembler (slot-map asm proc-slot slot-map)
(unless (zero? slot-map)
@@ -1341,7 +1558,8 @@ corresponding linker symbol for the start of the section."
(let ((name-idx (intern-section-name! asm (symbol->string name)))
(index (asm-next-section-number asm)))
(set-asm-next-section-number! asm (1+ index))
- (make-linker-object (apply make-elf-section
+ (make-linker-object (symbol->string name)
+ (apply make-elf-section
#:index index
#:name name-idx
#:size (bytevector-length bv)
@@ -1379,8 +1597,9 @@ a procedure to do that and return its label. Otherwise return
`((begin-program ,label ())
(assert-nargs-ee/locals 1 1)
,@(reverse inits)
+ (reset-frame 1)
(load-constant 0 ,*unspecified*)
- (return-values 2)
+ (return-values)
(end-program)))
label))))
@@ -1435,6 +1654,11 @@ should be .data or .rodata), and return the resulting linker object.
(* (1+ (vector-length x)) word-size))
((syntax? x)
(* 4 word-size))
+ ((jit-data? x)
+ (case word-size
+ ((4) (+ word-size (* 4 3)))
+ ((8) (+ word-size (* 4 4))) ;; One additional uint32_t for padding.
+ (else (error word-size))))
((simple-uniform-vector? x)
(* 4 word-size))
((uniform-vector-backing-store? x)
@@ -1501,6 +1725,10 @@ should be .data or .rodata), and return the resulting linker object.
((cache-cell? obj)
(write-placeholder asm buf pos))
+ ((jit-data? obj)
+ ;; Default initialization of 0.
+ (values))
+
((string? obj)
(let ((tag (logior tc7-string string-read-only-flag)))
(case word-size
@@ -1621,6 +1849,19 @@ should be .data or .rodata), and return the resulting linker object.
(else
(error "unrecognized object" obj))))
+ (define (add-relocs obj pos relocs)
+ (match obj
+ (($ <jit-data> low-pc high-pc)
+ ;; Patch "start" and "end" fields of "struct jit_data".
+ (cons* (make-linker-reloc 'rel32/1 (+ pos word-size 4)
+ (+ low-pc word-size 4)
+ '.rtl-text)
+ (make-linker-reloc 'rel32/1 (+ pos word-size 8)
+ (+ high-pc word-size 8)
+ '.rtl-text)
+ relocs))
+ (_ relocs)))
+
(cond
((vlist-null? data) #f)
(else
@@ -1628,16 +1869,16 @@ should be .data or .rodata), and return the resulting linker object.
(+ (byte-length k) (align len 8)))
0 data))
(buf (make-bytevector byte-len 0)))
- (let lp ((i 0) (pos 0) (symbols '()))
+ (let lp ((i 0) (pos 0) (relocs '()) (symbols '()))
(if (< i (vlist-length data))
- (let* ((pair (vlist-ref data i))
- (obj (car pair))
- (obj-label (cdr pair)))
- (write buf pos obj)
- (lp (1+ i)
- (align (+ (byte-length obj) pos) 8)
- (cons (make-linker-symbol obj-label pos) symbols)))
- (make-object asm name buf '() symbols
+ (match (vlist-ref data i)
+ ((obj . obj-label)
+ (write buf pos obj)
+ (lp (1+ i)
+ (align (+ (byte-length obj) pos) 8)
+ (add-relocs obj pos relocs)
+ (cons (make-linker-symbol obj-label pos) symbols))))
+ (make-object asm name buf relocs symbols
#:flags (match name
('.data (logior SHF_ALLOC SHF_WRITE))
('.rodata SHF_ALLOC))))))))))
@@ -1661,7 +1902,8 @@ these may be @code{#f}."
(lp (1+ i))))))
((uniform-vector-backing-store? x) #t)
(else #f)))
- (let* ((constants (asm-constants asm))
+ (let* ((init-constants (emit-init-constants asm))
+ (constants (asm-constants asm))
(len (vlist-length constants)))
(let lp ((i 0)
(ro vlist-null)
@@ -1669,11 +1911,12 @@ these may be @code{#f}."
(if (= i len)
(values (link-data asm ro '.rodata)
(link-data asm rw '.data)
- (emit-init-constants asm))
- (let ((pair (vlist-ref constants i)))
- (if (shareable? (car pair))
- (lp (1+ i) (vhash-consq (car pair) (cdr pair) ro) rw)
- (lp (1+ i) ro (vhash-consq (car pair) (cdr pair) rw))))))))
+ init-constants)
+ (match (vlist-ref constants i)
+ ((obj . label)
+ (if (shareable? obj)
+ (lp (1+ i) (vhash-consq obj label ro) rw)
+ (lp (1+ i) ro (vhash-consq obj label rw)))))))))
@@ -1806,8 +2049,8 @@ needed."
;;;
;; FIXME: Define these somewhere central, shared with C.
-(define *bytecode-major-version* #x0202)
-(define *bytecode-minor-version* (char->integer #\A))
+(define *bytecode-major-version* #x0300)
+(define *bytecode-minor-version* 1)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},
@@ -2052,8 +2295,9 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
((f64) 1)
((u64) 2)
((s64) 3)
+ ((ptr) 4)
(else (error "what!" representation)))))
- (put-uleb128 names-port (logior (ash slot 2) tag)))
+ (put-uleb128 names-port (logior (ash slot 3) tag)))
(lp definitions))))))
(let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
(match metas