diff options
Diffstat (limited to 'module/system/vm/assembler.scm')
-rw-r--r-- | module/system/vm/assembler.scm | 738 |
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 |