From 467ca64a7f61a401ad0b02fc03b91e93d77ceab9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 13 Mar 2021 20:53:45 -0700 Subject: [PATCH] Chez Scheme: split cpprim out of cpnanopass Moving the np-expand-primtives pass to a separately compiled source file reduces peak memory use when compiling Chez Scheme from about 1.3 GB to about 0.7 GB on a 64-bit platform. It's also nice from a code-navigation perspective to split a 19k-line file to a 10k-line file plus 8k-line file (and some additional small files). The overall time for Chez Scheme to compile itself is only slightly affected, even though some support functions, macros, and record declarations end up getting compiled twice. --- racket/src/ChezScheme/IMPLEMENTATION.md | 21 +- racket/src/ChezScheme/rktboot/make-boot.rkt | 1 + racket/src/ChezScheme/s/Mf-base | 11 +- racket/src/ChezScheme/s/cpnanopass.ss | 8558 +------------------ racket/src/ChezScheme/s/cpprim.ss | 7959 +++++++++++++++++ racket/src/ChezScheme/s/np-help.ss | 206 + racket/src/ChezScheme/s/np-info.ss | 258 + racket/src/ChezScheme/s/np-languages.ss | 57 +- racket/src/ChezScheme/s/np-register.ss | 180 + racket/src/ChezScheme/s/primdata.ss | 2 + 10 files changed, 8684 insertions(+), 8569 deletions(-) create mode 100644 racket/src/ChezScheme/s/cpprim.ss create mode 100644 racket/src/ChezScheme/s/np-help.ss create mode 100644 racket/src/ChezScheme/s/np-info.ss create mode 100644 racket/src/ChezScheme/s/np-register.ss diff --git a/racket/src/ChezScheme/IMPLEMENTATION.md b/racket/src/ChezScheme/IMPLEMENTATION.md index 753a677ea3..becbdcfbe6 100644 --- a/racket/src/ChezScheme/IMPLEMENTATION.md +++ b/racket/src/ChezScheme/IMPLEMENTATION.md @@ -14,17 +14,18 @@ Some key files in "s": * "syntax.ss": the macro expander - * "cpnanopass.ss": the main compiler + * "cpnanopass.ss" and "cpprim.ss": the main compiler, where + "cpprim.ss" is the part that inlines primitives * "cp0.ss", "cptypes.ss", "cpletrec.ss", etc.: source-to-source passes that apply before the main compiler * "x86_64.ss", "arm64.ss", etc.: backends that are used by - "cpnanopass.ss" + "cpnanopass.ss" and "cpprim.ss" * "ta6os.def", "tarm64le", etc.: one per OS-architecture combination, provides platform-specific constants that feed into "cmacro.ss" and - selects the backend used by "cpnanopass.ss" + selects the backend used by "cpnanopass.ss" and "cpprim.ss" Chez Scheme is a bootstrapped compiler, meaning you need a Chez Scheme compiler to build a Chez Scheme compiler. The compiler and makefiles @@ -375,12 +376,12 @@ recogizes an immediate application of the `set-car!` primitive and inlines its implementation. The `#2%` prefix instructs the compiler to inline the safe implementation of `set-car!`, which checks whether its first argument is a pair. Look for `define-inline 2 set-car!` in -"cpnanopass.ss" for that part of the compiler. The content of -"prims.ss" is compiled in unsafe mode, so that's why safe mode needs -to be selected explicitly when needed. +"cpprim.ss" for that part of the compiler. The content of "prims.ss" +is compiled in unsafe mode, so that's why safe mode needs to be +selected explicitly when needed. What if the argument to `set-car!` is not a pair? The implementation -of inline `set-car!` in "cpnanopass.ss" includes +of inline `set-car!` in "cpprim.ss" includes ```scheme (build-libcall #t src sexpr set-car! e-pair e-new) @@ -457,9 +458,9 @@ Compilation * performs front-end optimizations on that representation (see "cp0.ss", "cptypes.ss", etc.), - * and then compiles to machine code (see "cpnanopass.ss"), which - involves many individual passes that convert through many different - intermediate forms (see "np-language.ss"). + * and then compiles to machine code (see "cpnanopass.ss" and + "cpprim.ss"), which involves many individual passes that convert + through many different intermediate forms (see "np-language.ss"). It's worth noting that Chez Scheme produces machine code directly, instead of relying on a system-provided assembler. Chez Scheme also diff --git a/racket/src/ChezScheme/rktboot/make-boot.rkt b/racket/src/ChezScheme/rktboot/make-boot.rkt index 248574d715..a5a859213c 100644 --- a/racket/src/ChezScheme/rktboot/make-boot.rkt +++ b/racket/src/ChezScheme/rktboot/make-boot.rkt @@ -426,6 +426,7 @@ "cpletrec.ss" "cpcommonize.ss" "cpnanopass.ss" + "cpprim.ss" "compile.ss" "back.ss"))]) (status (format "Load ~a" s)) diff --git a/racket/src/ChezScheme/s/Mf-base b/racket/src/ChezScheme/s/Mf-base index 6239802f1c..92fe643e9f 100644 --- a/racket/src/ChezScheme/s/Mf-base +++ b/racket/src/ChezScheme/s/Mf-base @@ -124,7 +124,7 @@ patchfile = patch = patch # putting cpnanopass.patch early for maximum make --jobs=2 benefit -patchobj = patch.patch cpnanopass.patch cprep.patch cpcheck.patch\ +patchobj = patch.patch cpnanopass.patch cpprim.patch cprep.patch cpcheck.patch\ cp0.patch cpvalid.patch cptypes.patch cpcommonize.patch cpletrec.patch\ reloc.patch\ compile.patch fasl.patch vfasl.patch syntax.patch env.patch\ @@ -155,7 +155,7 @@ basesrc =\ baseobj = ${basesrc:%.ss=%.$m} compilersrc =\ - cpnanopass.ss compile.ss cback.ss + cpnanopass.ss cpprim.ss compile.ss cback.ss compilerobj = ${compilersrc:%.ss=%.$m} @@ -169,7 +169,7 @@ macroobj =\ allsrc =\ ${basesrc} ${compilersrc} cmacros.ss ${archincludes} setup.ss debug.ss priminfo.ss primdata.ss layout.ss\ base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss\ - np-languages.ss fxmap.ss cptypes-lattice.ss strip-types.ss + np-languages.ss fxmap.ss cptypes-lattice.ss strip-types.ss np-register.ss np-info.ss np-help.ss # doit uses a different Scheme process to compile each target doit: ${PetiteBoot} ${SchemeBoot} ${Cheader} ${Cequates} ${Cgcocd} ${Cgcoce} ${Cgcpar} ${Cheapcheck} ${Revision} @@ -252,6 +252,7 @@ clean: profileclean '(collect 1 2)'\ '(delete-file "$*.covin")'\ '(time (${compile} "$*.ss" "$*.$m" (quote $m)))'\ + '(printf " ~a bytes peak memory use~n" (maximum-memory-bytes))' \ '(when #${pdhtml} (profile-dump-html))'\ '(when #${dumpspd} (profile-dump-data "${ProfileDumpSource}"))'\ '(when #${dumpbpd} (profile-dump-data "${ProfileDumpBlock}"))'\ @@ -320,6 +321,7 @@ clean: profileclean '(collect-request-handler (lambda () (collect 0 1)))'\ '(collect 1 2)'\ '(time (${compile} "$*.ss" "$*.patch" (quote $m)))'\ + '(printf " ~a bytes peak memory use~n" (maximum-memory-bytes))' \ | ${Scheme} -q ${macroobj} saveboot: @@ -506,6 +508,7 @@ script.all makescript: ' (quote $m)))'\ ' (quote (${src}))'\ ' (quote (${obj}))))'\ + '(printf " ~a bytes peak memory use~n" (maximum-memory-bytes))' \ '(when #${pps} (#%$$print-pass-stats))'\ '(delete-file (string-append (path-root "${PetiteBoot}") ".covin"))'\ '(apply #%$$make-boot-file "${PetiteBoot}" (quote $m) (quote ())'\ @@ -596,7 +599,7 @@ strip.so: strip-types.ss vfasl.so: strip-types.ss ${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss strip-types.ss env.ss fxmap.ss cptypes-lattice.ss -cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss ${archincludes} +cpnanopass.$m cpnanopass.patch cpnanopass.so cpprim.$m cpprim.patch: nanopass.so np-languages.ss np-register.ss np-info.ss np-help.ss ${archincludes} cptypes.$m: fxmap.ss cptypes-lattice.ss 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss strip.$m: strip-types.ss diff --git a/racket/src/ChezScheme/s/cpnanopass.ss b/racket/src/ChezScheme/s/cpnanopass.ss index f54ebfd099..6b6a8778bd 100644 --- a/racket/src/ChezScheme/s/cpnanopass.ss +++ b/racket/src/ChezScheme/s/cpnanopass.ss @@ -14,6 +14,13 @@ ;;; limitations under the License. (let () + (define-syntax define-once + (syntax-rules () + [(_ id rhs) (define-once id (id) rhs)] + [(_ id (name . _) rhs) (define id (let ([v rhs]) + ($sputprop 'name 'once v) + v))])) + (include "np-languages.ss") (define track-dynamic-closure-counts ($make-thread-parameter #f (lambda (x) (and x #t)))) @@ -64,24 +71,6 @@ (syntax-rules (x) [(_ name) (set! name (let ([t name]) (trace-lambda name args (apply t args))))])) - (define-syntax architecture - (let ([fn (format "~a.ss" (constant architecture))]) - (with-source-path 'architecture fn - (lambda (fn) - (let* ([p ($open-file-input-port 'include fn)] - [sfd ($source-file-descriptor fn p)] - [p (transcoded-port p (current-transcoder))]) - (let ([do-read ($make-read p sfd 0)]) - (let* ([regs (do-read)] [inst (do-read)] [asm (do-read)]) - (when (eof-object? asm) ($oops #f "too few expressions in ~a" fn)) - (unless (eof-object? (do-read)) ($oops #f "too many expressions in ~a" fn)) - (close-input-port p) - (lambda (x) - (syntax-case x (registers instructions assembler) - [(k registers) (datum->syntax #'k regs)] - [(k instructions) (datum->syntax #'k inst)] - [(k assembler) (datum->syntax #'k asm)]))))))))) - ; version in cmacros uses keyword as template and should ; probably be changed to use the id (define-syntax define-who @@ -481,158 +470,9 @@ [(and (eq? l full-tree) (eq? r full-tree)) full-tree] [else (make-tree-node l r)]))))])))) - (define-syntax tc-disp - (lambda (x) - (syntax-case x () - [(_ name) - (case (datum name) - [(%ac0) (constant tc-ac0-disp)] - [(%ac1) (constant tc-ac1-disp)] - [(%sfp) (constant tc-sfp-disp)] - [(%cp) (constant tc-cp-disp)] - [(%esp) (constant tc-esp-disp)] - [(%ap) (constant tc-ap-disp)] - [(%eap) (constant tc-eap-disp)] - [(%trap) (constant tc-trap-disp)] - [(%xp) (constant tc-xp-disp)] - [(%yp) (constant tc-yp-disp)] - [(%save1) (constant tc-save1-disp)] - [else #f])]))) - - (define-syntax define-reserved-registers - (lambda (x) - (syntax-case x () - [(_ [regid alias ... callee-save? mdinfo type] ...) - (syntax-case #'(regid ...) (%tc %sfp) [(%tc %sfp . others) #t] [_ #f]) - #'(begin - (begin - (define regid (make-reg 'regid 'mdinfo (tc-disp regid) callee-save? 'type)) - (module (alias ...) (define x regid) (define alias x) ...)) - ...)]))) - - (define-syntax define-allocable-registers - (lambda (x) - (assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max))) - (syntax-case x () - [(_ regvec arg-registers extra-registers extra-fpregisters with-initialized-registers - [regid reg-alias ... callee-save? mdinfo type] ...) - (with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...) (extra-fpregid ...)) - (syntax-case #'([regid type] ...) (%ac0 %xp %ts %td uptr) - [([%ac0 _] [%xp _] [%ts _] [%td _] [other other-type] ...) - (let f ([other* #'(other ...)] - [other-type* #'(other-type ...)] - [rtc-disp* '()] - [arg-offset (constant tc-arg-regs-disp)] - [fp-offset (constant tc-fpregs-disp)] - [rextra* '()] - [rfpextra* '()]) - (if (null? other*) - (cond - [(not (fx= (length rextra*) (constant asm-arg-reg-max))) - (syntax-error x (format "asm-arg-reg-max extra registers are not specified ~s" (syntax->datum rextra*)))] - [(not (fx= (length rfpextra*) (constant asm-fpreg-max))) - (syntax-error x (format "asm-fpreg-max extra registers are not specified ~s" (syntax->datum rfpextra*)))] - [else - (let ([extra* (reverse rextra*)] - [fpextra* (reverse rfpextra*)]) - (list - (list* - (constant tc-ac0-disp) - (constant tc-xp-disp) - (constant tc-ts-disp) - (constant tc-td-disp) - (reverse rtc-disp*)) - (list-head extra* (constant asm-arg-reg-cnt)) - (list-tail extra* (constant asm-arg-reg-cnt)) - fpextra*))]) - (let ([other (car other*)]) - (if (memq (syntax->datum other) '(%ac1 %yp %cp %ret)) - (f (cdr other*) (cdr other-type*) (cons #`(tc-disp #,other) rtc-disp*) - arg-offset fp-offset rextra* rfpextra*) - (if (eq? (syntax->datum (car other-type*)) 'fp) - (f (cdr other*) (cdr other-type*) (cons fp-offset rtc-disp*) - arg-offset (fx+ fp-offset (constant double-bytes)) rextra* (cons other rfpextra*)) - (f (cdr other*) (cdr other-type*) (cons arg-offset rtc-disp*) - (fx+ arg-offset (constant ptr-bytes)) fp-offset (cons other rextra*) rfpextra*))))))] - [_ (syntax-error x "missing or out-of-order required registers")])] - [(regid-loc ...) (generate-temporaries #'(regid ...))]) - #'(begin - (define-syntax define-squawking-parameter - (syntax-rules () - [(_ (id (... ...)) loc) - (begin - (define loc ($make-thread-parameter #f)) - (define-syntax id - (lambda (q) - (unless (identifier? q) (syntax-error q)) - #`(let ([x (loc)]) - (unless x (syntax-error #'#,q "uninitialized")) - x))) - (... ...))] - [(_ id loc) (define-squawking-parameter (id) loc)])) - (define-squawking-parameter (regid reg-alias ...) regid-loc) - ... - (define-squawking-parameter regvec regvec-loc) - (define-squawking-parameter arg-registers arg-registers-loc) - (define-squawking-parameter extra-registers extra-registers-loc) - (define-squawking-parameter extra-fpregisters extra-fpregisters-loc) - (define-syntax with-initialized-registers - (syntax-rules () - [(_ b1 b2 (... ...)) - (parameterize ([regid-loc (make-reg 'regid 'mdinfo tc-disp callee-save? 'type)] ...) - (parameterize ([regvec-loc (vector regid ...)] - [arg-registers-loc (list arg-regid ...)] - [extra-registers-loc (list extra-regid ...)] - [extra-fpregisters-loc (list extra-fpregid ...)]) - (let () b1 b2 (... ...))))]))))]))) - - (define-syntax define-machine-dependent-registers - (lambda (x) - (syntax-case x () - [(_ [regid alias ... callee-save? mdinfo type] ...) - #'(begin - (begin - (define regid (make-reg 'regid 'mdinfo #f callee-save? 'type)) - (module (alias ...) (define x regid) (define alias x) ...)) - ...)]))) - - (define-syntax define-registers - (lambda (x) - (syntax-case x (reserved allocable machine-dependent) - [(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) - (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) - (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)) - (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? with-initialized-registers) - #`(begin - (define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) - (define-allocable-registers regvec arg-registers extra-registers extra-fpregisters with-initialized-registers - [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) - (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...) - (define-syntax real-register? - (with-syntax ([real-reg* #''(rreg ... rreg-alias ... ... areg ... areg-alias ... ... mdreg ... mdreg-alias ... ...)]) - (syntax-rules () - [(_ e) (memq e real-reg*)])))))]))) - - (architecture registers) - - ; pseudo register used for mref's with no actual index - (define %zero (make-reg 'zero #f #f #f #f)) - - ;; define %ref-ret to be sfp[0] on machines w/no ret register - ;; - ;; The ret register, if any, is used to pass a return address to a - ;; function. All functions currently stash the ret register in - ;; sfp[0] and return to sfp[0] instead of the ret register, so the - ;; register doesn't have to be saved and restored for non-tail - ;; calls --- so use sfp[0] instead of the ret registerr to refer - ;; to the current call's return address. (A leaf procedure could - ;; do better, but doesn't currently.) - (define-syntax %ref-ret - (lambda (x) - (meta-cond - [(real-register? '%ret) #'%ret] - [else (with-syntax ([%mref (datum->syntax x '%mref)]) - #'(%mref ,%sfp 0))]))) + ;; Defines the `architecture` macro and registers defined for the + ;; target architecture: + (include "np-register.ss") (define make-Ldoargerr (lambda () @@ -707,34 +547,6 @@ (and (not (eq? (fv-type fv) 'reserved)) (compatible-var-types? (fv-type fv) type)))) - (define-syntax reg-cons* - (lambda (x) - (syntax-case x () - [(_ ?reg ... ?reg*) - (fold-right - (lambda (reg reg*) - (cond - [(real-register? (syntax->datum reg)) - #`(cons #,reg #,reg*)] - [else reg*])) - #'?reg* #'(?reg ...))]))) - - (define-syntax reg-list - (syntax-rules () - [(_ ?reg ...) (reg-cons* ?reg ... '())])) - - (define-syntax with-saved-ret-reg - (lambda (x) - (syntax-case x () - [(k ?e) - (if (real-register? '%ret) - (with-implicit (k %seq %mref) - #'(%seq - (set! ,(%mref ,%sfp 0) ,%ret) - ,?e - (set! ,%ret ,(%mref ,%sfp 0)))) - #'?e)]))) - (module (restore-scheme-state save-scheme-state with-saved-scheme-state) (define-syntax build-reg-list ; TODO: create reg records at compile time, and build these lists at compile time @@ -839,252 +651,15 @@ (loop (fx+ i 1)) (cons reg (loop (fx+ i 1)))))])))) - (define-record-type ctci ; compile-time version of code-info - (nongenerative) - (sealed #t) - (fields (mutable live) (mutable rpi*) (mutable closure-fv-names)) - (protocol - (lambda (new) - (lambda () - (new #f '() #f))))) - - (define-record-type ctrpi ; compile-time version of rp-info - (nongenerative) - (sealed #t) - (fields label src sexpr mask)) - (define-threaded next-lambda-seqno) - - (define-record-type info-lambda (nongenerative) - (parent info) - (sealed #t) - (fields src sexpr libspec (mutable interface*) (mutable dcl*) (mutable flags) (mutable fv*) (mutable name) - (mutable well-known?) (mutable closure-rep) ctci (mutable pinfo*) seqno) - (protocol - (lambda (pargs->new) - (define next-seqno + (module () + (set! $np-next-lambda-seqno (lambda () (let ([seqno next-lambda-seqno]) (set! next-lambda-seqno (fx+ seqno 1)) - seqno))) - (rec cons-info-lambda - (case-lambda - [(src sexpr libspec interface*) (cons-info-lambda src sexpr libspec interface* #f 0)] - [(src sexpr libspec interface* name) (cons-info-lambda src sexpr libspec interface* name 0)] - [(src sexpr libspec interface* name flags) - ((pargs->new) src sexpr libspec interface* - (map (lambda (iface) (make-direct-call-label 'dcl)) interface*) - (if (eq? (subset-mode) 'system) (fxlogor flags (constant code-flag-system)) flags) - '() name #f 'closure (and (generate-inspector-information) (make-ctci)) '() (next-seqno))]))))) - - (define-record-type info-call (nongenerative) - (parent info) - (sealed #t) - (fields src sexpr (mutable check?) pariah? error? shift-attachment? shift-consumer-attachment?*) - (protocol - (lambda (pargs->new) - (case-lambda - [(src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*) - ((pargs->new) src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*)] - [(src sexpr check? pariah? error?) - ((pargs->new) src sexpr check? pariah? error? #f '())])))) - - (define-record-type info-newframe (nongenerative) - (parent info) - (sealed #t) - (fields - src - sexpr - cnfv* - nfv* - nfv** - (mutable weight) - (mutable call-live*) - (mutable frame-words) - (mutable local-save*)) - (protocol - (lambda (pargs->new) - (lambda (src sexpr cnfv* nfv* nfv**) - ((pargs->new) src sexpr cnfv* nfv* nfv** 0 #f #f #f))))) - - (define-record-type info-kill* (nongenerative) - (parent info) - (fields kill*)) - - (define-record-type info-kill*-live* (nongenerative) - (parent info-kill*) - (fields live*) - (protocol - (lambda (new) - (case-lambda - [(kill* live*) - ((new kill*) live*)] - [(kill*) - ((new kill*) (reg-list))])))) - - (define-record-type info-asmlib (nongenerative) - (parent info-kill*-live*) - (sealed #t) - (fields libspec save-ra?) - (protocol - (lambda (new) - (case-lambda - [(kill* libspec save-ra? live*) - ((new kill* live*) libspec save-ra?)] - [(kill* libspec save-ra?) - ((new kill*) libspec save-ra?)])))) - - (module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics) - ; standing on our heads here to avoid referencing registers at - ; load time...would be cleaner if registers were immutable, - ; i.e., mutable fields (direct and inherited from var) were kept - ; in separate tables...but that might add more cost to register - ; allocation, which is already expensive. - (define-record-type intrinsic (nongenerative) - (sealed #t) - (fields libspec get-kill* get-live* get-rv*)) - (define intrinsic-info-asmlib - (lambda (intrinsic save-ra?) - (make-info-asmlib ((intrinsic-get-kill* intrinsic)) - (intrinsic-libspec intrinsic) - save-ra? - ((intrinsic-get-live* intrinsic))))) - (define intrinsic-return-live* - ; used a handful of times, just while compiling library.ss...don't bother optimizing - (lambda (intrinsic) - (fold-left (lambda (live* kill) (remq kill live*)) - (vector->list regvec) ((intrinsic-get-kill* intrinsic))))) - (define intrinsic-entry-live* - ; used a handful of times, just while compiling library.ss...don't bother optimizing - (lambda (intrinsic) ; return-live* - rv + live* - (fold-left (lambda (live* live) (if (memq live live*) live* (cons live live*))) - (fold-left (lambda (live* rv) (remq rv live*)) - (intrinsic-return-live* intrinsic) - ((intrinsic-get-rv* intrinsic))) - ((intrinsic-get-live* intrinsic))))) - (define intrinsic-modify-reg* - (lambda (intrinsic) - (append ((intrinsic-get-rv* intrinsic)) - ((intrinsic-get-kill* intrinsic))))) - (define-syntax declare-intrinsic - (syntax-rules (unquote) - [(_ name entry-name (kill ...) (live ...) (rv ...)) - (begin - (define name - (make-intrinsic - (lookup-libspec entry-name) - (lambda () (reg-list kill ...)) - (lambda () (reg-list live ...)) - (lambda () (reg-list rv ...)))) - (export name))])) - ; must include in kill ... any register explicitly assigned by the intrinsic - ; plus additional registers as needed to avoid spilled unspillables. the - ; list could be machine-dependent but at this point it doesn't matter. - (declare-intrinsic dofargint32 dofargint32 (%ts %td %xp) (%ac0) (%ac0)) - (constant-case ptr-bits - [(32) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0 %ac1))] - [(64) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0))]) - (declare-intrinsic dofretint32 dofretint32 (%ts %td %xp) (%ac0) (%ac0)) - (constant-case ptr-bits - [(32) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] - [(64) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0) (%ac0))]) - (declare-intrinsic dofretuns32 dofretuns32 (%ts %td %xp) (%ac0) (%ac0)) - (constant-case ptr-bits - [(32) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] - [(64) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0) (%ac0))]) - (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) - (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) - (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) - (declare-intrinsic get-room get-room () (%xp) (%xp)) - (declare-intrinsic scan-remembered-set scan-remembered-set () () ()) - (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; %reify1 & %reify2 are defined as needed per machine... - (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; ... to have enough registers to allocate - (declare-intrinsic dooverflow dooverflow () () ()) - (declare-intrinsic dooverflood dooverflood () (%xp) ()) - ; a dorest routine takes all of the register and frame arguments from the rest - ; argument forward and also modifies the rest argument. for the rest argument, - ; this is a wash (it's live both before and after). the others should also be - ; listed as live. it's inconvenient and currently unnecessary to do so. - ; (actually currently impossible to list the infinite set of frame arguments) - (define-syntax dorest-intrinsic-max (identifier-syntax 5)) - (export dorest-intrinsic-max) - (define (list-xtail ls n) - (if (or (null? ls) (fx= n 0)) - ls - (list-xtail (cdr ls) (fx1- n)))) - (define dorest-intrinsics - (let () - (define-syntax dorests - (lambda (x) - #`(vector #,@ - (let f ([i 0]) - (if (fx> i dorest-intrinsic-max) - '() - (cons #`(make-intrinsic - (lookup-libspec #,(construct-name #'k "dorest" i)) - (lambda () (reg-list %ac0 %xp %ts %td)) - (lambda () (reg-cons* %ac0 (list-xtail arg-registers #,i))) - (lambda () (let ([ls (list-xtail arg-registers #,i)]) (if (null? ls) '() (list (car ls)))))) - (f (fx+ i 1)))))))) - dorests))) - - (define-record-type info-alloc (nongenerative) - (parent info) - (sealed #t) - (fields tag save-flrv? save-ra?)) - - (define-record-type info-foreign (nongenerative) - (parent info) - (sealed #t) - (fields conv* arg-type* result-type unboxed? (mutable name)) - (protocol - (lambda (pargs->new) - (lambda (conv* arg-type* result-type unboxed?) - ((pargs->new) conv* arg-type* result-type unboxed? #f))))) - - (define-record-type info-literal (nongenerative) - (parent info) - (sealed #t) - (fields indirect? type addr offset)) - - (define-record-type info-lea (nongenerative) - (parent info) - (sealed #t) - (fields offset)) - - (define-record-type info-load (nongenerative) - (parent info) - (sealed #t) - (fields type swapped?)) - - (define-record-type info-condition-code (nongenerative) - (parent info) - (sealed #t) - (fields type reversed? invertible?)) - - (define-record-type info-c-simple-call (nongenerative) - (parent info-kill*-live*) - (sealed #t) - (fields save-ra? entry) - (protocol - (lambda (new) - (case-lambda - [(save-ra? entry) ((new '() '()) save-ra? entry)] - [(live* save-ra? entry) ((new '() live*) save-ra? entry)])))) - - (define-record-type info-c-return (nongenerative) - (parent info) - (sealed #t) - (fields offset)) - - (define-record-type info-inline (nongenerative) - (parent info) - (sealed #t) - (fields)) - - (define-record-type info-unboxed-args (nongenerative) - (parent info) - (fields unboxed?*)) + seqno)))) + + (include "np-info.ss") (module () (record-writer (record-type-descriptor info-load) @@ -1104,12 +679,6 @@ (fprintf p "#" (info-literal-addr x)))) ) - (define (fp-type? type) - (nanopass-case (Ltype Type) type - [(fp-double-float) #t] - [(fp-single-float) #t] - [else #f])) - (define-pass cpnanopass : Lsrc (ir) -> L1 () (definitions (define-syntax with-uvars @@ -1176,132 +745,7 @@ (kfixed (car x**) (car body*)) (f (cdr x**) (cdr interface*) (cdr body*))))))))) - (define-syntax define-$type-check - (lambda (x) - (syntax-case x () - [(k L) (with-implicit (k $type-check) - #'(define $type-check - (lambda (mask type expr) - (with-output-language L - (cond - [(fx= type 0) (%inline log!test ,expr (immediate ,mask))] - [(= mask (constant byte-constant-mask)) (%inline eq? ,expr (immediate ,type))] - [else (%inline type-check? ,expr (immediate ,mask) (immediate ,type))])))))]))) - - (define-syntax %type-check - (lambda (x) - (syntax-case x () - [(k mask type expr) - (with-implicit (k $type-check quasiquote) - #'($type-check (constant mask) (constant type) `expr))]))) - - (define-syntax %typed-object-check ; NB: caller must bind e - (lambda (x) - (syntax-case x () - [(k mask type expr) - (with-implicit (k quasiquote %type-check %constant %mref) - #'`(if ,(%type-check mask-typed-object type-typed-object expr) - ,(%type-check mask type - ,(%mref expr ,(constant typed-object-type-disp))) - ,(%constant sfalse)))]))) - - (define-syntax %seq - (lambda (x) - (syntax-case x () - [(k e1 ... e2) - (with-implicit (k quasiquote) - #``#,(fold-right (lambda (x body) #`(seq #,x #,body)) - #'e2 #'(e1 ...)))]))) - - (define-syntax %mref - (lambda (x) - (syntax-case x () - [(k e0 e1 imm type) - (with-implicit (k quasiquote) - #'`(mref e0 e1 imm type))] - [(k e0 e1 imm) - (with-implicit (k quasiquote) - #'`(mref e0 e1 imm uptr))] - [(k e0 imm) - (with-implicit (k quasiquote) - #'`(mref e0 ,%zero imm uptr))]))) - - (define-syntax %inline - (lambda (x) - (syntax-case x () - [(k name e ...) - (with-implicit (k quasiquote) - #'`(inline ,null-info ,(%primitive name) e ...))]))) - - (define-syntax %lea - (lambda (x) - (syntax-case x () - [(k base offset) - (with-implicit (k quasiquote) - #'`(inline ,(make-info-lea offset) ,%lea1 base))] - [(k base index offset) - (with-implicit (k quasiquote) - #'`(inline ,(make-info-lea offset) ,%lea2 base index))]))) - - (define-syntax %constant - (lambda (x) - (syntax-case x () - [(k x) - (with-implicit (k quasiquote) - #'`(immediate ,(constant x)))]))) - - (define-syntax %tc-ref - (lambda (x) - (define-who field-type - (lambda (struct field) - (cond - [(assq field (getprop struct '*fields* '())) => - (lambda (a) - (apply - (lambda (field type disp len) type) - a))] - [else ($oops who "undefined field ~s-~s" struct field)]))) - (syntax-case x () - [(k field) #'(k ,%tc field)] - [(k e-tc field) - (if (memq (field-type 'tc (datum field)) '(ptr xptr uptr iptr)) - (with-implicit (k %mref) - #`(%mref e-tc - #,(lookup-constant - (string->symbol - (format "tc-~a-disp" (datum field)))))) - (syntax-error x "non-ptr-size tc field"))]))) - - (define-syntax %constant-alloc - (lambda (x) - (syntax-case x () - [(k tag size) #'(k tag size #f #f)] - [(k tag size save-flrv?) #'(k tag size save-flrv? #f)] - [(k tag size save-flrv? save-asm-ra?) - (with-implicit (k quasiquote) - #'`(alloc - ,(make-info-alloc (constant tag) save-flrv? save-asm-ra?) - (immediate ,(c-alloc-align size))))]))) - - (define-syntax %mv-jump - (lambda (x) - (syntax-case x () - [(k ret-reg (live ...)) - (with-implicit (k quasiquote %mref %inline %constant) - #'`(if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ;; compact: use regular return or error? - (if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-values-error-mask)) - ;; values error: - (jump (literal ,(make-info-literal #f 'library-code - (lookup-libspec values-error) - (constant code-data-disp))) - (live ...)) - ;; regular return point: - (jump ret-reg (live ...))) - ;; non-compact rp-header - (jump ,(%mref ret-reg ,(constant return-address-mv-return-address-disp)) (live ...))))]))) + (include "np-help.ss") (define-pass np-recognize-let : L1 (ir) -> L2 () (definitions @@ -1426,17 +870,6 @@ (lambda (x* body) `(clause (,x* ...) ,interface ,body)))])) - ; for use only after mdcl field has been added to the call syntax - (define-syntax %primcall - (lambda (x) - (syntax-case x () - [(k src sexpr prim arg ...) - (identifier? #'prim) - (with-implicit (k quasiquote) - #``(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 'prim) - arg ...))]))) - (define-pass np-sanitize-bindings : L4 (ir) -> L4 () ; must come before suppress-procedure-checks and recognize-mrvs ; since it sets up uvar-info-lambda, but after convert-assignments @@ -3478,7963 +2911,6 @@ (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () [(clause (,x* ...) ,mcp ,interface ,body) (Expr body #f) ir])) - (define target-fixnum? - (if (and (= (constant most-negative-fixnum) (most-negative-fixnum)) - (= (constant most-positive-fixnum) (most-positive-fixnum))) - fixnum? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))) - - (define unfix - (lambda (imm) - (ash imm (fx- (constant fixnum-offset))))) - - (define fix - (lambda (imm) - (ash imm (constant fixnum-offset)))) - - (define ptr->imm - (lambda (x) - (cond - [(eq? x #f) (constant sfalse)] - [(eq? x #t) (constant strue)] - [(eq? x (void)) (constant svoid)] - [(null? x) (constant snil)] - [(eof-object? x) (constant seof)] - [($unbound-object? x) (constant sunbound)] - [(bwp-object? x) (constant sbwp)] - [(eq? x '#1=#1#) (constant black-hole)] - [(target-fixnum? x) (fix x)] - [(char? x) (+ (* (constant char-factor) (char->integer x)) (constant type-char))] - [else #f]))) - - (define-syntax ref-reg - (lambda (x) - (syntax-case x () - [(k reg) - (identifier? #'reg) - (if (real-register? (datum reg)) - #'reg - (with-implicit (k %mref) #`(%mref ,%tc ,(tc-disp reg))))]))) - - ;; After the `np-expand-primitives` pass, some expression produce - ;; double (i.e., floating-point) values instead of pointer values. - ;; Those expression results always flow to an `inline` primitive - ;; that expects double values. The main consequence is that a later - ;; pass must only put such returns in a temporary with type 'fp. - - ; TODO: recognize a direct call when it is at the end of a sequence, closures, or let form - ; TODO: push call into if? (would need to pull arguments into temporaries to ensure order of evaluation - ; TODO: how does this interact with mvcall? - (module (np-expand-primitives) - (define-threaded new-l*) - (define-threaded new-le*) - (define ht2 (make-hashtable symbol-hash eq?)) - (define ht3 (make-hashtable symbol-hash eq?)) - (define handle-prim - (lambda (src sexpr level name e*) - (let ([handler (or (and (fx= level 3) (symbol-hashtable-ref ht3 name #f)) - (symbol-hashtable-ref ht2 name #f))]) - (and handler (handler src sexpr e*))))) - (define-syntax Symref - (lambda (x) - (syntax-case x () - [(k ?sym) - (with-implicit (k quasiquote) - #'`(literal ,(make-info-literal #t 'object ?sym (constant symbol-value-disp))))]))) - (define single-valued? - (case-lambda - [(e) (single-valued? e 5)] - [(e fuel) - (and (not (zero? fuel)) - (nanopass-case (L7 Expr) e - [,x #t] - [(immediate ,imm) #t] - [(literal ,info) #t] - [(label-ref ,l ,offset) #t] - [(mref ,e1 ,e2 ,imm ,type) #t] - [(quote ,d) #t] - [,pr #t] - [(call ,info ,mdcl ,pr ,e* ...) - (all-set? (prim-mask single-valued) (primref-flags pr))] - [(foreign-call ,info ,e, e* ...) #t] - [(alloc ,info ,e) #t] - [(set! ,lvalue ,e) #t] - [(profile ,src) #t] - [(pariah) #t] - [(let ([,x* ,e*] ...) ,body) - (single-valued? body (fx- fuel 1))] - [(if ,e0 ,e1 ,e2) - (and (single-valued? e1 (fx- fuel 1)) - (single-valued? e2 (fx- fuel 1)))] - [(seq ,e0 ,e1) - (single-valued? e1 (fx- fuel 1))] - [(unboxed-fp ,e) #t] - [else #f]))])) - (define ensure-single-valued - (case-lambda - [(e unsafe-omit?) - (if (or unsafe-omit? - (single-valued? e)) - e - (with-output-language (L7 Expr) - (let ([t (make-tmp 'v)]) - `(values ,(make-info-call #f #f #f #f #f) ,e))))] - [(e) (ensure-single-valued e (fx= (optimize-level) 3))])) - (define-pass np-expand-primitives : L7 (ir) -> L9 () - (definitions - (define Expr1 - (lambda (e) - (let-values ([(e unboxed-fp?) (Expr e #f)]) - e))) - (define Expr* - (lambda (e*) - (map Expr1 e*))) - (define unboxed-fp->boxed - (lambda (e) - (let ([t (make-tmp 't)]) - (with-output-language (L9 Expr) - `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) - (seq - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e) - ,t)))))) - (define (fp-lvalue? lvalue) - (nanopass-case (L9 Lvalue) lvalue - [,x (and (uvar? x) (eq? (uvar-type x) 'fp))] - [(mref ,e1 ,e2 ,imm ,type) (eq? type 'fp)]))) - (Program : Program (ir) -> Program () - [(labels ([,l* ,le*] ...) ,l) - (fluid-let ([new-l* '()] [new-le* '()]) - (let ([le* (map CaseLambdaExpr le*)]) - `(labels ([,l* ,le*] ... [,new-l* ,new-le*] ...) ,l)))]) - (CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr ()) - (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () - [(clause (,x* ...) ,mcp ,interface ,[body #f -> body unboxed-fp?]) - `(clause (,x* ...) ,mcp ,interface ,body)]) - ;; The result of `Expr` can be unboxed (second result is #t) only - ;; if the `can-unbox-fp?` argument is #t, but the result can always - ;; be a boxed expression (even if `can-unbox-fp?` is #t) - (Expr : Expr (ir [can-unbox-fp? #f]) -> Expr (#f) - [(quote ,d) - (values (cond - [(ptr->imm d) => (lambda (i) `(immediate ,i))] - [else `(literal ,(make-info-literal #f 'object d 0))]) - #f)] - [,pr (values (Symref (primref-name pr)) #f)] - [(unboxed-fp ,[e #t -> e unboxed-fp?]) - (if can-unbox-fp? - (values e #t) - (values (unboxed-fp->boxed e) #f))] - [(call ,info0 ,mdcl0 - (call ,info1 ,mdcl1 ,pr (quote ,d)) - ,[e* #f -> e* unboxed-fp?*] ...) - (guard (and (eq? (primref-name pr) '$top-level-value) (symbol? d))) - (values `(call ,info0 ,mdcl0 ,(Symref d) ,e* ...) #f)] - [(call ,info ,mdcl ,pr ,e* ...) - (cond - [(and - (or (not (info-call-shift-attachment? info)) - ;; Note: single-valued also implies that the primitive doesn't - ;; tail-call an arbitary function (which might inspect attachments): - (all-set? (prim-mask single-valued) (primref-flags pr))) - (handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*)) - => (lambda (e) - (let-values ([(e unboxed-fp?) (Expr e can-unbox-fp?)]) - (values - (cond - [(info-call-shift-attachment? info) - (let ([t (make-tmp 't (if unboxed-fp? 'fp 'ptr))]) - `(let ([,t ,e]) - (seq - (attachment-set pop #f) - ,t)))] - [else e]) - unboxed-fp?)))] - [else - (let ([e* (Expr* e*)]) - ; NB: expand calls through symbol top-level values similarly - (let ([info (if (any-set? (prim-mask abort-op) (primref-flags pr)) - (make-info-call (info-call-src info) (info-call-sexpr info) - (info-call-check? info) #t #t - (info-call-shift-attachment? info) - (info-call-shift-consumer-attachment?* info)) - info)]) - (values `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...) - ;; an error can be treated as unboxed if the context wants that: - (and can-unbox-fp? (info-call-error? info)))))])] - [(call ,info ,mdcl ,x ,e* ...) - (guard (uvar-loop? x)) - (let ([e* (map (lambda (x1 e) - (let ([unbox? (eq? (uvar-type x1) 'fp)]) - (let-values ([(e unboxed-fp?) (Expr e unbox?)]) - (cond - [(and unbox? (not unboxed-fp?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp)] - [else e])))) - (uvar-location x) e*)]) - (values `(call ,info ,mdcl ,x ,e* ...) #f))] - [(call ,info ,mdcl ,e ,e* ...) - (let ([e (and e (Expr1 e))] - [e* (Expr* e*)]) - (values `(call ,info ,mdcl ,e ,e* ...) #f))] - [(inline ,info ,prim ,e* ...) - (cond - [(info-unboxed-args? info) - (let ([e* (map (lambda (e unbox-arg?) - (let-values ([(e unboxed-arg?) (Expr e unbox-arg?)]) - (if (and unbox-arg? (not unboxed-arg?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e))) - e* - (info-unboxed-args-unboxed?* info))]) - (values `(inline ,info ,prim ,e* ...) - ;; Especially likely to be replaced by enclosing `unboxed-fp` wrapper: - #f))] - [else - (let ([e* (Expr* e*)]) - (values `(inline ,info ,prim ,e* ...) #f))])] - [(set! ,[lvalue #t -> lvalue fp-unboxed?l] ,e) - (let ([fp? (fp-lvalue? lvalue)]) - (let-values ([(e unboxed?) (Expr e fp?)]) - (let ([e (if (and fp? (not unboxed?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e)]) - (values `(set! ,lvalue ,e) #f))))] - [(values ,info ,[e* #f -> e* unboxed-fp?*] ...) (values `(values ,info ,e* ...) #f)] - [(alloc ,info ,e) (values `(alloc ,info ,(Expr1 e)) #f)] - [(if ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?1] ,[e2 can-unbox-fp? -> e2 unboxed-fp?2]) - (let* ([unboxed-fp? (or unboxed-fp?1 unboxed-fp?2)] - [e1 (if (and unboxed-fp? (not unboxed-fp?1)) - (%mref ,e1 ,%zero ,(constant flonum-data-disp) fp) - e1)] - [e2 (if (and unboxed-fp? (not unboxed-fp?2)) - (%mref ,e2 ,%zero ,(constant flonum-data-disp) fp) - e2)]) - (values `(if ,e0 ,e1 ,e2) unboxed-fp?))] - [(seq ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?]) - (values `(seq ,e0 ,e1) unboxed-fp?)] - [(let ([,x* ,e*] ...) ,body) - (let ([e* (map (lambda (x e) - (if (eq? (uvar-type x) 'fp) - (let-values ([(e unboxed?) (Expr e #t)]) - (if (not unboxed?) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e)) - (Expr1 e))) - x* e*)]) - (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) - (values `(let ([,x* ,e*] ...) ,body) unboxed-fp?)))] - [(loop ,x (,x* ...) ,body) - (uvar-location-set! x x*) - (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) - (uvar-location-set! x #f) - (values `(loop ,x (,x* ...) ,body) unboxed-fp?))] - [(attachment-set ,aop ,e) (values `(attachment-set ,aop ,(and e (Expr1 e))) #f)] - [(attachment-get ,reified ,e) (values `(attachment-get ,reified ,(and e (Expr1 e))) #f)] - [(attachment-consume ,reified ,e) (values `(attachment-consume ,reified ,(and e (Expr1 e))) #f)] - [(continuation-set ,cop ,e1 ,e2) (values `(continuation-set ,cop ,(Expr1 e1) ,(Expr1 e2)) #f)] - [(label ,l ,[body can-unbox-fp? -> body unboxed-fp?]) (values `(label ,l ,body) unboxed-fp?)] - [(foreign-call ,info ,e ,e* ...) - (let ([e (Expr1 e)] - [e* (if (info-foreign-unboxed? info) - (map (lambda (e type) - (let ([unbox-arg? (fp-type? type)]) - (let-values ([(e unboxed-fp?) (Expr e unbox-arg?)]) - (if (and unbox-arg? (not unboxed-fp?)) - (%mref ,e ,%zero ,(constant flonum-data-disp) fp) - e)))) - e* - (info-foreign-arg-type* info)) - (map Expr1 e*))]) - (let ([new-e `(foreign-call ,info ,e ,e* ...)] - [unboxed? (and (info-foreign-unboxed? info) - (fp-type? (info-foreign-result-type info)))]) - (if (and unboxed? (not can-unbox-fp?)) - (values (unboxed-fp->boxed new-e) #f) - (values new-e unboxed?))))] - [(mvcall ,info ,e1 ,e2) (values `(mvcall ,info ,(Expr1 e1) ,(Expr1 e2)) #f)] - [(mvlet ,e ((,x** ...) ,interface* ,body*) ...) - (values `(mvlet ,(Expr1 e) ((,x** ...) ,interface* ,(map Expr1 body*)) ...) #f)] - [,lvalue (Lvalue lvalue can-unbox-fp?)]) - (Lvalue : Lvalue (ir [unboxed-fp? #f]) -> Lvalue (#f) - [(mref ,e1 ,e2 ,imm ,type) - (let ([e `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type)]) - (if (and (eq? type 'fp) (not unboxed-fp?)) - (values (unboxed-fp->boxed e) #f) - (values e (eq? type 'fp))))] - [,x - (let ([fp? (and (uvar? x) (eq? (uvar-type x) 'fp))]) - (if (and fp? (not unboxed-fp?)) - (values (unboxed-fp->boxed x) #f) - (values x fp?)))])) - (define-who unhandled-arity - (lambda (name args) - (sorry! who "unhandled argument count ~s for ~s" (length args) 'name))) - (with-output-language (L7 Expr) - (define-$type-check (L7 Expr)) - (define-syntax define-inline - (let () - (define ctht2 (make-hashtable symbol-hash eq?)) - (define ctht3 (make-hashtable symbol-hash eq?)) - (define check-and-record - (lambda (level name) - (let ([a (symbol-hashtable-cell (if (fx= level 2) ctht2 ctht3) (syntax->datum name) #f)]) - (when (cdr a) (syntax-error name "duplicate inline")) - (set-cdr! a #t)))) - (lambda (x) - (define compute-interface - (lambda (clause) - (syntax-case clause () - [(x e1 e2 ...) (identifier? #'x) -1] - [((x ...) e1 e2 ...) (length #'(x ...))] - [((x ... . r) e1 e2 ...) (fxlognot (length #'(x ...)))]))) - (define bitmaskify - (lambda (i*) - (fold-left (lambda (mask i) - (logor mask (if (fx< i 0) (ash -1 (fxlognot i)) (ash 1 i)))) - 0 i*))) - (syntax-case x () - [(k level id clause ...) - (identifier? #'id) - (let ([level (datum level)] [name (datum id)]) - (unless (memv level '(2 3)) - (syntax-error x (format "invalid level ~s in inline definition" level))) - (let ([pr ($sgetprop name (if (eqv? level 2) '*prim2* '*prim3*) #f)]) - (include "primref.ss") - (unless pr - (syntax-error x (format "unrecognized primitive name ~s in inline definition" name))) - (let ([arity (primref-arity pr)]) - (when arity - (unless (= (bitmaskify arity) (bitmaskify (map compute-interface #'(clause ...)))) - (syntax-error x (format "arity mismatch for ~s" name)))))) - (check-and-record level #'id) - (with-implicit (k src sexpr moi) - #`(symbol-hashtable-set! #,(if (eqv? level 2) #'ht2 #'ht3) 'id - (rec moi - (lambda (src sexpr args) - (apply (case-lambda clause ... [rest #f]) args))))))])))) - (define no-need-to-bind? - (lambda (multiple-ref? e) - (nanopass-case (L7 Expr) e - [,x (if (uvar? x) (not (uvar-assigned? x)) (eq? x %zero))] - [(immediate ,imm) #t] ; might should produce binding if imm is large - [(quote ,d) (or (not multiple-ref?) (ptr->imm d))] - [,pr (not multiple-ref?)] - [(literal ,info) (and (not multiple-ref?) (not (info-literal-indirect? info)))] - [(profile ,src) #t] - [(pariah) #t] - [else #f]))) - (define binder - (lambda (multiple-ref? type e) - (if (no-need-to-bind? multiple-ref? e) - (values e values) - (let ([t (make-tmp 't type)]) - (values t (lift-fp-unboxed - (lambda (body) - `(let ([,t ,e]) ,body)))))))) - (define list-binder - (lambda (multiple-ref? type e*) - (if (null? e*) - (values '() values) - (let-values ([(e dobind) (binder multiple-ref? type (car e*))] - [(e* dobind*) (list-binder multiple-ref? type (cdr e*))]) - (values (cons e e*) - (lambda (body) - (dobind (dobind* body)))))))) - (define dirty-store-binder - (lambda (multiple-ref? type e) - (nanopass-case (L7 Expr) e - [(call ,info ,mdcl ,pr ,e) - (guard (eq? (primref-name pr) '$fixmediate)) - (let-values ([(t dobind) (binder multiple-ref? type e)]) - (values `(call ,info ,mdcl ,pr ,t) dobind))] - [else - (binder multiple-ref? type e)]))) - (define-syntax $bind - (lambda (x) - (syntax-case x () - [(_ binder multiple-ref? type (b ...) e) - (let ([t0* (generate-temporaries #'(b ...))]) - (let f ([b* #'(b ...)] [t* t0*] [x* '()]) - (if (null? b*) - (with-syntax ([(x ...) (reverse x*)] [(t ...) t0*]) - #`(let ([x t] ...) e)) - (syntax-case (car b*) () - [x (identifier? #'x) - #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type x)]) - (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))] - [(x e) (identifier? #'x) - #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type e)]) - (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))]))))]))) - (define-syntax bind - (syntax-rules () - [(_ multiple-ref? type (b ...) e) - (identifier? #'type) - ($bind binder multiple-ref? type (b ...) e)] - [(_ multiple-ref? (b ...) e) - ($bind binder multiple-ref? ptr (b ...) e)])) - (define-syntax list-bind - (syntax-rules () - [(_ multiple-ref? type (b ...) e) - (identifier? #'type) - ($bind list-binder multiple-ref? type (b ...) e)] - [(_ multiple-ref? (b ...) e) - ($bind list-binder multiple-ref? ptr (b ...) e)])) - (define-syntax dirty-store-bind - (syntax-rules () - [(_ multiple-ref? (b ...) e) - ($bind dirty-store-binder multiple-ref? ptr (b ...) e)])) - (define lift-fp-unboxed - (lambda (k) - (lambda (e) - ;; Propagate unboxing information: - (nanopass-case (L7 Expr) e - [(unboxed-fp ,e) `(unboxed-fp ,(k e))] - [else - (let ([new-e (k e)]) - (nanopass-case (L7 Expr) e - [(mref ,e0 ,e1 ,imm ,type) - (if (eq? type 'fp) - `(unboxed-fp ,new-e) - new-e)] - [,x (if (and (uvar? x) (eq? (uvar-type x) 'fp)) - `(unboxed-fp ,new-e) - new-e)] - [else new-e]))])))) - (define-syntax build-libcall - (lambda (x) - (syntax-case x () - [(k pariah? src sexpr name e ...) - (let ([libspec ($sgetprop (datum name) '*libspec* #f)]) - (define interface-okay? - (lambda (interface* cnt) - (ormap - (lambda (interface) - (if (fx< interface 0) - (fx>= cnt (lognot interface)) - (fx= cnt interface))) - interface*))) - (unless libspec (syntax-error x "unrecognized library routine")) - (unless (eqv? (length #'(e ...)) (libspec-interface libspec)) - (syntax-error x "invalid number of arguments")) - (let ([is-pariah? (datum pariah?)]) - (unless (boolean? is-pariah?) - (syntax-error x "pariah indicator must be a boolean literal")) - (when (and (libspec-error? libspec) (not is-pariah?)) - (syntax-error x "pariah indicator is inconsistent with libspec-error indicator")) - (with-implicit (k quasiquote) - (with-syntax ([body #`(call ,(make-info-call src sexpr #f pariah? #,(libspec-error? libspec)) #f - (literal ,(make-info-literal #f 'library '#,(datum->syntax #'* libspec) 0)) - ,e ...)]) - (if is-pariah? - #'`(seq (pariah) body) - #'`body)))))]))) - (define-syntax when-known-endianness - (lambda (stx) - (syntax-case stx () - [(_ e ...) - #'(constant-case native-endianness - [(unknown) (void)] - [else e ...])]))) - (define constant? - (case-lambda - [(x) - (nanopass-case (L7 Expr) x - [(quote ,d) #t] - ; TODO: handle immediate? - [else #f])] - [(pred? x) - (nanopass-case (L7 Expr) x - [(quote ,d) (pred? d)] - ; TODO: handle immediate? - [else #f])])) - (define constant-value - (lambda (x) - (nanopass-case (L7 Expr) x - [(quote ,d) d] - ; TODO: handle immediate if constant? does - [else #f]))) - (define maybe-add-label - (lambda (Llib body) - (if Llib - `(label ,Llib ,body) - body))) - (define build-and - (lambda (e1 e2) - `(if ,e1 ,e2 ,(%constant sfalse)))) - (define maybe-build-and - (lambda (e1 e2) - (if e1 - (build-and e1 e2) - e2))) - (define build-simple-or - (lambda (e1 e2) - `(if ,e1 ,(%constant strue) ,e2))) - (define build-fix - (lambda (e) - (%inline sll ,e ,(%constant fixnum-offset)))) - (define build-double-scale - (lambda (e) - (constant-case ptr-bits - [(32) (%inline sll ,e (immediate 1))] - [(64) e] - [else ($oops 'build-double-scale "unknown ptr-bit size ~s" (constant ptr-bits))]))) - (define build-unfix - (lambda (e) - (nanopass-case (L7 Expr) e - [(quote ,d) (guard (target-fixnum? d)) `(immediate ,d)] - [else (%inline sra ,e ,(%constant fixnum-offset))]))) - (define build-not - (lambda (e) - `(if ,e ,(%constant sfalse) ,(%constant strue)))) - (define build-null? - (lambda (e) - (%type-check mask-nil snil ,e))) - (define build-eq? - (lambda (e1 e2) - (%inline eq? ,e1 ,e2))) - (define build-eqv? - (lambda (src sexpr e1 e2) - (bind #t (e1 e2) - (build-simple-or - (build-eq? e1 e2) - (build-and - ;; checking just one argument is good enough for typical - ;; uses, where `eqv?` almost always receives two fixnums - ;; or two characters; checking both arguments appears to - ;; by counter-productive by introducing too many branches - (build-simple-or - (%type-check mask-flonum type-flonum ,e1) - (build-and - (%type-check mask-typed-object type-typed-object ,e1) - (%type-check mask-other-number type-other-number - ,(%mref ,e1 ,(constant bignum-type-disp))))) - (build-libcall #f src sexpr eqv? e1 e2)))))) - (define make-build-eqv? - (lambda (src sexpr) - (lambda (e1 e2) - (build-eqv? src sexpr e1 e2)))) - (define fixnum-constant? - (lambda (e) - (constant? target-fixnum? e))) - (define expr->index - (lambda (e alignment limit) - (nanopass-case (L7 Expr) e - [(quote ,d) - (and (target-fixnum? d) - (>= d 0) - (< d limit) - (fxzero? (logand d (fx- alignment 1))) - d)] - [else #f]))) - (define build-fixnums? - (lambda (e*) - (let ([e* (remp fixnum-constant? e*)]) - (if (null? e*) - `(quote #t) - (%type-check mask-fixnum type-fixnum - ,(fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) - (car e*) (cdr e*))))))) - (define build-flonums? - (lambda (e*) - (let ([e* (remp (lambda (e) (constant? flonum? e)) e*)]) - (if (null? e*) - `(quote #t) - (let f ([e* e*]) - (let ([e (car e*)] [e* (cdr e*)]) - (let ([check (%type-check mask-flonum type-flonum ,e)]) - (if (null? e*) - check - (build-and check (f e*)))))))))) - (define build-fl= - (lambda (e1 e2) ; must be bound - `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))) - (define build-chars? - (lambda (e1 e2) - (define char-constant? - (lambda (e) - (constant? char? e))) - (if (char-constant? e1) - (if (char-constant? e2) - (%constant strue) - (%type-check mask-char type-char ,e2)) - (if (char-constant? e2) - (%type-check mask-char type-char ,e1) - (build-and - (%type-check mask-char type-char ,e1) - (%type-check mask-char type-char ,e2)))))) - (define build-list - (lambda (e*) - (if (null? e*) - (%constant snil) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) - (let loop ([e* e*] [i 0]) - (let ([e (car e*)] [e* (cdr e*)]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) - ,(if (null? e*) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,(%constant snil)) - ,t) - (let ([next-i (fx+ i (constant size-pair))]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) - ,(%inline + ,t (immediate ,next-i))) - ,(loop e* next-i)))))))))))) - (define build-pair? - (lambda (e) - (%type-check mask-pair type-pair ,e))) - (define build-car - (lambda (e) - (%mref ,e ,(constant pair-car-disp)))) - (define build-cdr - (lambda (e) - (%mref ,e ,(constant pair-cdr-disp)))) - (define build-char->integer - (lambda (e) - (%inline srl ,e - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))))) - (define build-integer->char - (lambda (e) - (%inline + - ,(%inline sll ,e - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) - ,(%constant type-char)))) - (define need-store-fence? - (if-feature pthreads - (constant-case architecture - [(arm32 arm64) #t] - [else #f]) - #f)) - (define add-store-fence - ;; A store--store fence should be good enough for safety on a platform that - ;; orders load dependencies (which is anything except Alpha) - (lambda (e) - (if need-store-fence? - `(seq ,(%inline store-store-fence) ,e) - e))) - (define build-dirty-store - (case-lambda - [(base offset e) (build-dirty-store base %zero offset e)] - [(base index offset e) (build-dirty-store base index offset e - (lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e)) - (lambda (s r) `(seq ,s ,r)))] - [(base index offset e build-assign build-remember-seq) - (nanopass-case (L7 Expr) e - [(call ,info ,mdcl ,pr ,e) - (guard (eq? (primref-name pr) '$fixmediate)) - (build-assign base index offset e)] - [else - (if (nanopass-case (L7 Expr) e - [(quote ,d) (ptr->imm d)] - [(call ,info ,mdcl ,pr ,e* ...) - (eq? 'fixnum ($sgetprop (primref-name pr) '*result-type* #f))] - [else #f]) - (build-assign base index offset e) - (let ([a (if (eq? index %zero) - (%lea ,base offset) - (%lea ,base ,index offset))]) - ; NB: should work harder to determine cases where x can't be a fixnum - (if (nanopass-case (L7 Expr) e - [(quote ,d) #t] - [(literal ,info) #t] - [else #f]) - (bind #f ([e e]) - ; eval a second so the address is not live across any calls - (bind #t ([a a]) - (add-store-fence - (build-remember-seq - (build-assign a %zero 0 e) - (%inline remember ,a))))) - (bind #t ([e e]) - ; eval a second so the address is not live across any calls - (bind #t ([a a]) - (if need-store-fence? - ;; Fence needs to be before store, so duplicate - ;; store instruction to lift out fixnum check; this - ;; appears to be worthwhile on the Apple M1 to avoid - ;; tighly interleaved writes and fences - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(build-assign a %zero 0 e) - ,(add-store-fence - (build-remember-seq - (build-assign a %zero 0 e) - (%inline remember ,a)))) - ;; Generate one copy of store instruction - (build-remember-seq - (build-assign a %zero 0 e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant svoid) - ,(%inline remember ,a)))))))))])])) - (define make-build-cas - (lambda (old-v) - (lambda (base index offset v) - `(seq - ,(%inline cas ,base ,index (immediate ,offset) ,old-v ,v) - (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))))) - (define build-cas-seq - (lambda (cas remember) - `(if ,cas - (seq ,remember ,(%constant strue)) - ,(%constant sfalse)))) - (define build-$record - (lambda (tag args) - (bind #f (tag) - (list-bind #f (args) - (let ([n (fx+ (length args) 1)]) - (bind #t ([t (%constant-alloc type-typed-object (fx* n (constant ptr-bytes)))]) - `(seq - (set! ,(%mref ,t ,(constant record-type-disp)) ,tag) - ,(let f ([args args] [offset (constant record-data-disp)]) - (if (null? args) - t - `(seq - (set! ,(%mref ,t ,offset) ,(car args)) - ,(f (cdr args) (fx+ offset (constant ptr-bytes))))))))))))) - (define build-$real->flonum - (lambda (src sexpr x who) - (if (known-flonum-result? x) - x - (bind #t (x) - (bind #f (who) - `(if ,(%type-check mask-flonum type-flonum ,x) - ,x - ,(build-libcall #t src sexpr real->flonum x who))))))) - (define build-$inexactnum-real-part - (lambda (e) - (%lea ,e (fx+ (constant inexactnum-real-disp) - (fx- (constant type-flonum) (constant typemod)))))) - (define build-$inexactnum-imag-part - (lambda (e) - (%lea ,e (fx+ (constant inexactnum-imag-disp) - (fx- (constant type-flonum) (constant typemod)))))) - (define make-build-fill - (lambda (elt-bytes data-disp) - (define ptr-bytes (constant ptr-bytes)) - (define super-size - (lambda (e-fill) - (define-who super-size-imm - (lambda (imm) - `(immediate - ,(constant-case ptr-bytes - [(4) - (case elt-bytes - [(1) (let ([imm (logand imm #xff)])< - (let ([imm (logor (ash imm 8) imm)]) - (logor (ash imm 16) imm)))] - [(2) (let ([imm (logand imm #xffff)]) - (logor (ash imm 16) imm))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] - [(8) - (case elt-bytes - [(1) (let ([imm (logand imm #xff)]) - (let ([imm (logor (ash imm 8) imm)]) - (let ([imm (logor (ash imm 16) imm)]) - (logor (ash imm 32) imm))))] - [(2) (let ([imm (logand imm #xffff)]) - (let ([imm (logor (ash imm 16) imm)]) - (logor (ash imm 32) imm)))] - [(4) (let ([imm (logand imm #xffffffff)]) - (logor (ash imm 32) imm))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])])))) - (define-who super-size-expr - (lambda (e-fill) - (define (double e-fill k) - (%inline logor - ,(%inline sll ,e-fill (immediate ,k)) - ,e-fill)) - (define (mask e-fill k) - (%inline logand ,e-fill (immediate ,k))) - (constant-case ptr-bytes - [(4) - (case elt-bytes - [(1) (bind #t ([e-fill (mask e-fill #xff)]) - (bind #t ([e-fill (double e-fill 8)]) - (double e-fill 16)))] - [(2) (bind #t ([e-fill (mask e-fill #xffff)]) - (double e-fill 16))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] - [(8) - (case elt-bytes - [(1) (bind #t ([e-fill (mask e-fill #xff)]) - (bind #t ([e-fill (double e-fill 8)]) - (bind #t ([e-fill (double e-fill 16)]) - (double e-fill 32))))] - [(2) (bind #t ([e-fill (mask e-fill #xffff)]) - (bind #t ([e-fill (double e-fill 16)]) - (double e-fill 32)))] - [(4) (bind #t ([e-fill (mask e-fill #xffffffff)]) - (double e-fill 32))] - [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])]))) - (if (fx= elt-bytes ptr-bytes) - e-fill - (nanopass-case (L7 Expr) e-fill - [(quote ,d) - (cond - [(ptr->imm d) => super-size-imm] - [else (super-size-expr e-fill)])] - [(immediate ,imm) (super-size-imm imm)] - [else (super-size-expr e-fill)])))) - (lambda (e-vec e-bytes e-fill) - ; NB: caller must bind e-vec and e-fill - (safe-assert (no-need-to-bind? #t e-vec)) - (safe-assert (no-need-to-bind? #f e-fill)) - (nanopass-case (L7 Expr) e-bytes - [(immediate ,imm) - (guard (fixnum? imm) (fx<= 0 imm (fx* 4 ptr-bytes))) - (if (fx= imm 0) - e-vec - (bind #t ([e-fill (super-size e-fill)]) - (let f ([n (if (fx>= elt-bytes ptr-bytes) - imm - (fxlogand (fx+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))]) - (let ([n (fx- n ptr-bytes)]) - `(seq - (set! ,(%mref ,e-vec ,(fx+ data-disp n)) ,e-fill) - ,(if (fx= n 0) e-vec (f n)))))))] - [else - (let ([Ltop (make-local-label 'Ltop)] [t (make-assigned-tmp 't 'uptr)]) - (bind #t ([e-fill (super-size e-fill)]) - `(let ([,t ,(if (fx>= elt-bytes ptr-bytes) - e-bytes - (nanopass-case (L7 Expr) e-bytes - [(immediate ,imm) - `(immediate ,(logand (+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))] - [else - (%inline logand - ,(%inline + - ,e-bytes - (immediate ,(fx- ptr-bytes 1))) - (immediate ,(fx- ptr-bytes)))]))]) - (label ,Ltop - (if ,(%inline eq? ,t (immediate 0)) - ,e-vec - ,(%seq - (set! ,t ,(%inline - ,t (immediate ,ptr-bytes))) - (set! ,(%mref ,e-vec ,t ,data-disp) ,e-fill) - (goto ,Ltop)))))))])))) - - ;; NOTE: integer->ptr and unsigned->ptr DO NOT handle 64-bit integers on a 32-bit machine. - ;; this is okay for $object-ref and $object-set!, which do not support moving 64-bit values - ;; as single entities on a 32-bit machine, but care should be taken if these are used with - ;; other primitives. - (define-who integer->ptr - (lambda (x width) - (if (fx>= (constant fixnum-bits) width) - (build-fix x) - (%seq - (set! ,%ac0 ,x) - (set! ,%xp ,(build-fix %ac0)) - (set! ,%xp ,(build-unfix %xp)) - (if ,(%inline eq? ,%ac0 ,%xp) - ,(build-fix %ac0) - (seq - (set! ,%ac0 - (inline - ,(case width - [(32) (intrinsic-info-asmlib dofretint32 #f)] - [(64) (intrinsic-info-asmlib dofretint64 #f)] - [else ($oops who "can't handle width ~s" width)]) - ,%asmlibcall)) - ,%ac0)))))) - (define-who unsigned->ptr - (lambda (x width) - (if (fx>= (constant fixnum-bits) width) - (build-fix x) - `(seq - (set! ,%ac0 ,x) - (if ,(%inline u< ,(%constant most-positive-fixnum) ,%ac0) - (seq - (set! ,%ac0 - (inline - ,(case width - [(32) (intrinsic-info-asmlib dofretuns32 #f)] - [(64) (intrinsic-info-asmlib dofretuns64 #f)] - [else ($oops who "can't handle width ~s" width)]) - ,%asmlibcall)) - ,%ac0) - ,(build-fix %ac0)))))) - (define-who i32xu32->ptr - (lambda (hi lo) - (safe-assert (eqv? (constant ptr-bits) 32)) - (let ([Lbig (make-local-label 'Lbig)]) - (bind #t (lo hi) - `(if ,(%inline eq? ,hi ,(%inline sra ,lo (immediate 31))) - ,(bind #t ([fxlo (build-fix lo)]) - `(if ,(%inline eq? ,(build-unfix fxlo) ,lo) - ,fxlo - (goto ,Lbig))) - (label ,Lbig - ,(%seq - (set! ,%ac0 ,lo) - (set! ,(ref-reg %ac1) ,hi) - (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretint64 #f) ,%asmlibcall)) - ,%ac0))))))) - (define-who u32xu32->ptr - (lambda (hi lo) - (safe-assert (eqv? (constant ptr-bits) 32)) - (let ([Lbig (make-local-label 'Lbig)]) - (bind #t (lo hi) - `(if ,(%inline eq? ,hi (immediate 0)) - (if ,(%inline u< ,(%constant most-positive-fixnum) ,lo) - (goto ,Lbig) - ,(build-fix lo)) - (label ,Lbig - ,(%seq - (set! ,%ac0 ,lo) - (set! ,(ref-reg %ac1) ,hi) - (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretuns64 #f) ,%asmlibcall)) - ,%ac0))))))) - - (define-who ptr->integer - (lambda (value width) - (if (fx> (constant fixnum-bits) width) - (build-unfix value) - `(seq - (set! ,%ac0 ,value) - (if ,(%type-check mask-fixnum type-fixnum ,%ac0) - ,(build-unfix %ac0) - (seq - (set! ,%ac0 - (inline - ,(cond - [(fx<= width 32) (intrinsic-info-asmlib dofargint32 #f)] - [(fx<= width 64) (intrinsic-info-asmlib dofargint64 #f)] - [else ($oops who "can't handle width ~s" width)]) - ,%asmlibcall)) - ,%ac0)))))) - (define ptr-type (constant-case ptr-bits - [(32) 'unsigned-32] - [(64) 'unsigned-64] - [else ($oops 'ptr-type "unknown ptr-bit size ~s" (constant ptr-bits))])) - (define-who type->width - (lambda (x) - (case x - [(integer-8 unsigned-8 char) 8] - [(integer-16 unsigned-16) 16] - [(integer-24 unsigned-24) 24] - [(integer-32 unsigned-32 single-float) 32] - [(integer-40 unsigned-40) 40] - [(integer-48 unsigned-48) 48] - [(integer-56 unsigned-56) 56] - [(integer-64 unsigned-64 double-float) 64] - [(scheme-object fixnum) (constant ptr-bits)] - [(wchar) (constant wchar-bits)] - [else ($oops who "unknown type ~s" x)]))) - (define offset-expr->index+offset - (lambda (offset) - (if (fixnum-constant? offset) - (values %zero (constant-value offset)) - (values (build-unfix offset) 0)))) - (define-who build-int-load - ;; assumes aligned (if required) offset - (lambda (swapped? type base index offset build-int) - (case type - [(integer-8 unsigned-8) - (build-int `(inline ,(make-info-load type #f) ,%load ,base ,index (immediate ,offset)))] - [(integer-16 integer-32 unsigned-16 unsigned-32) - (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))] - [(integer-64 unsigned-64) - ;; NB: doesn't handle unknown endiannesss for 32-bit machines - (constant-case ptr-bits - [(32) - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 4) offset) - (values offset (+ offset 4)))]) - (bind #t (base index) - (build-int - `(inline ,(make-info-load 'integer-32 swapped?) ,%load ,base ,index (immediate ,hi)) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))))] - [(64) - (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))])] - [(integer-24 unsigned-24) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 2)))]) - (define hi-type (if (eq? type 'integer-24) 'integer-8 'unsigned-8)) - (bind #t (base index) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 16)) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,lo))))))])] - [(integer-40 unsigned-40) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 4)))]) - (define hi-type (if (eq? type 'integer-40) 'integer-8 'unsigned-8)) - (bind #t (base index) - (constant-case ptr-bits - [(32) - (build-int - `(inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] - [(64) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 32)) - (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] - [(integer-48 unsigned-48) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 2) offset) - (values offset (+ offset 4)))]) - (define hi-type (if (eq? type 'integer-48) 'integer-16 'unsigned-16)) - (bind #t (base index) - (constant-case ptr-bits - [(32) - (build-int - `(inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] - [(64) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) - (immediate 32)) - (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] - [(integer-56 unsigned-56) - (constant-case native-endianness - [(unknown) #f] - [else - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 3) (+ offset 1) offset) - (values offset (+ offset 4) (+ offset 6)))]) - (define hi-type (if (eq? type 'integer-56) 'integer-8 'unsigned-8)) - (bind #t (base index) - (constant-case ptr-bits - [(32) - (build-int - (%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 16)) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) - `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] - [(64) - (build-int - (%inline logor - ,(%inline sll - ,(%inline logor - ,(%inline sll - (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) - (immediate 16)) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) - (immediate 32)) - (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] - [else (sorry! who "unsupported type ~s" type)]))) - (define-who build-object-ref - ;; assumes aligned (if required) offset - (case-lambda - [(swapped? type base offset-expr) - (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) - (build-object-ref swapped? type base index offset))] - [(swapped? type base index offset) - (case type - [(scheme-object) `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset))] - [(double-float) - (if swapped? - (constant-case ptr-bits - [(32) - (bind #t (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - (%seq - (set! ,(%mref ,t ,(constant flonum-data-disp)) - (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index - (immediate ,(+ offset 4)))) - (set! ,(%mref ,t ,(+ (constant flonum-data-disp) 4)) - (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index - (immediate ,offset))) - ,t)))] - [(64) - (bind #f (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - `(seq - (set! ,(%mref ,t ,(constant flonum-data-disp)) - (inline ,(make-info-load 'unsigned-64 #t) ,%load ,base ,index - (immediate ,offset))) - ,t)))]) - (bind #f (base index) - (%mref ,base ,index ,offset fp)))] - [(single-float) - (if swapped? - (bind #f (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - (%seq - (inline ,(make-info-load 'unsigned-32 #f) ,%store ,t ,%zero ,(%constant flonum-data-disp) - (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index - (immediate ,offset))) - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) - (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) - ,%load-single->double - ;; slight abuse to call this "unboxed", but `load-single->double` - ;; wants an FP-flavored address - ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)))) - ,t))) - (bind #f (base index) - (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) - (%seq - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) - (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) - ,%load-single->double - ;; slight abuse to call this "unboxed", but `load-single->double` - ;; wants an FP-flavored address - ,(%mref ,base ,index ,offset fp)))) - ,t))))] - [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64) - (build-int-load swapped? type base index offset - (if (and (eqv? (constant ptr-bits) 32) (memq type '(integer-40 integer-48 integer-56 integer-64))) - i32xu32->ptr - (lambda (x) (integer->ptr x (type->width type)))))] - [(unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) - (build-int-load swapped? type base index offset - (if (and (eqv? (constant ptr-bits) 32) (memq type '(unsigned-40 unsigned-48 unsigned-56 unsigned-64))) - u32xu32->ptr - (lambda (x) (unsigned->ptr x (type->width type)))))] - [(fixnum) (build-fix `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset)))] - [else (sorry! who "unsupported type ~s" type)])])) - (define-who build-int-store - ;; assumes aligned (if required) offset - (lambda (swapped? type base index offset value) - (case type - [(integer-8 unsigned-8) - `(inline ,(make-info-load type #f) ,%store ,base ,index (immediate ,offset) ,value)] - [(integer-16 integer-32 integer-64 unsigned-16 unsigned-32 unsigned-64) - `(inline ,(make-info-load type swapped?) ,%store ,base ,index (immediate ,offset) ,value)] - [(integer-24 unsigned-24) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 2)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 16))))))])] - [(integer-40 unsigned-40) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 1) offset) - (values offset (+ offset 4)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 32))))))])] - [(integer-48 unsigned-48) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 2) offset) - (values offset (+ offset 4)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 32))))))])] - [(integer-56 unsigned-56) - (constant-case native-endianness - [(unknown) #f] - [else - (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) - (values (+ offset 3) (+ offset 1) offset) - (values offset (+ offset 4) (+ offset 6)))]) - (bind #t (base index value) - (%seq - (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) - (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,mi) - ,(%inline srl ,value (immediate 32))) - (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 48))))))])] - [else (sorry! who "unsupported type ~s" type)]))) - (define-who build-object-set! - ;; assumes aligned (if required) offset - (case-lambda - [(type base offset-expr value) - (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) - (build-object-set! type base index offset value))] - [(type base index offset value) - (case type - [(scheme-object) (build-dirty-store base index offset value)] - [(double-float) - (bind #f (base index) - `(set! ,(%mref ,base ,index ,offset fp) ,value))] - [(single-float) - (bind #f (base index) - `(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single - ;; slight abuse to call this "unboxed", but `store-double->single` - ;; wants an FP-flavored address - ,(%mref ,base ,index ,offset fp) - ,(%mref ,value ,%zero ,(constant flonum-data-disp) fp)))] - ; 40-bit+ only on 64-bit machines - [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 - unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) - (build-int-store #f type base index offset (ptr->integer value (type->width type)))] - [(fixnum) - `(inline ,(make-info-load ptr-type #f) ,%store - ,base ,index (immediate ,offset) ,(build-unfix value))] - [else (sorry! who "unrecognized type ~s" type)])])) - (define-who build-swap-object-set! - (case-lambda - [(type base offset-expr value) - (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) - (build-swap-object-set! type base index offset value))] - [(type base index offset value) - (case type - ; only on 64-bit machines - [(double-float) - `(inline ,(make-info-load 'unsigned-64 #t) ,%store - ,base ,index (immediate ,offset) - ,(%mref ,value ,(constant flonum-data-disp)))] - ; 40-bit+ only on 64-bit machines - [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 - unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) - (build-int-store #t type base index offset (ptr->integer value (type->width type)))] - [(fixnum) - `(inline ,(make-info-load ptr-type #t) ,%store ,base ,index (immediate ,offset) - ,(build-unfix value))] - [else (sorry! who "unrecognized type ~s" type)])])) - (define extract-unsigned-bitfield - (lambda (raw? start end arg) - (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] - [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))] - [body (%inline srl - ,(if (fx= left 0) - arg - (%inline sll ,arg (immediate ,left))) - (immediate ,right))]) - (if (fx= start 0) - body - (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))) - (define extract-signed-bitfield - (lambda (raw? start end arg) - (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] - [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))]) - (let ([body (if (fx= left 0) arg (%inline sll ,arg (immediate ,left)))]) - (let ([body (if (fx= right 0) body (%inline sra ,body (immediate ,right)))]) - (if (fx= start 0) - body - (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))))) - (define insert-bitfield - (lambda (raw? start end bf-width arg val) - (if raw? - (cond - [(fx= start 0) - (%inline logor - ,(%inline sll - ,(%inline srl ,arg (immediate ,end)) - (immediate ,end)) - ,(%inline srl - ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) - (immediate ,(fx- (constant ptr-bits) end))))] - [(fx= end bf-width) - (%inline logor - ,(%inline srl - ,(%inline sll ,arg - (immediate ,(fx- (constant ptr-bits) start))) - (immediate ,(fx- (constant ptr-bits) start))) - ,(cond - [(fx< start (constant fixnum-offset)) - (%inline srl ,val - (immediate ,(fx- (constant fixnum-offset) start)))] - [(fx> start (constant fixnum-offset)) - (%inline sll ,val - (immediate ,(fx- start (constant fixnum-offset))))] - [else val]))] - [else - (%inline logor - ,(%inline logand ,arg - (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) start)))) - ,(%inline srl - ,(if (fx= (fx- end start) (constant fixnum-bits)) - val - (%inline sll ,val - (immediate ,(fx- (constant fixnum-bits) (fx- end start))))) - (immediate ,(fx- (constant ptr-bits) end))))]) - (cond - [(fx= start 0) - (%inline logor - ,(%inline sll - ,(%inline srl ,arg (immediate ,(fx+ end (constant fixnum-offset)))) - (immediate ,(fx+ end (constant fixnum-offset)))) - ,(%inline srl - ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) - (immediate ,(fx- (constant fixnum-bits) end))))] - #;[(fx= end (constant fixnum-bits)) ---] ; end < fixnum-bits - [else - (%inline logor - ,(%inline logand ,arg - (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) - (fx+ start (constant fixnum-offset)))))) - ,(%inline srl - ,(%inline sll ,val - (immediate ,(fx- (constant fixnum-bits) (fx- end start)))) - (immediate ,(fx- (constant fixnum-bits) end))))])))) - (define translate - (lambda (e current-shift target-shift) - (let ([delta (fx- current-shift target-shift)]) - (if (fx= delta 0) - e - (if (fx< delta 0) - (%inline sll ,e (immediate ,(fx- delta))) - (%inline srl ,e (immediate ,delta))))))) - (define extract-length - (lambda (t/l length-offset) - (%inline logand - ,(translate t/l length-offset (constant fixnum-offset)) - (immediate ,(- (constant fixnum-factor)))))) - (define build-type/length - (lambda (e type current-shift target-shift) - (let ([e (translate e current-shift target-shift)]) - (if (eqv? type 0) - e - (%inline logor ,e (immediate ,type)))))) - (define-syntax build-ref-check - (syntax-rules () - [(_ type-disp maximum-length length-offset type mask immutable-flag) - (lambda (e-v e-i maybe-e-new) - ; NB: caller must bind e-v, e-i, and maybe-e-new - (safe-assert (no-need-to-bind? #t e-v)) - (safe-assert (no-need-to-bind? #t e-i)) - (safe-assert (or (not maybe-e-new) (no-need-to-bind? #t maybe-e-new))) - (build-and - (%type-check mask-typed-object type-typed-object ,e-v) - (bind #t ([t (%mref ,e-v ,(constant type-disp))]) - (cond - [(expr->index e-i 1 (constant maximum-length)) => - (lambda (index) - (let ([e (%inline u< - (immediate ,(logor (ash index (constant length-offset)) (constant type) (constant immutable-flag))) - ,t)]) - (if (and (eqv? (constant type) (constant type-fixnum)) - (eqv? (constant mask) (constant mask-fixnum))) - (build-and e (build-fixnums? (if maybe-e-new (list t maybe-e-new) (list t)))) - (build-and - (%type-check mask type ,t) - (if maybe-e-new (build-and e (build-fixnums? (list maybe-e-new))) e)))))] - [else - (let ([e (%inline u< ,e-i ,(extract-length t (constant length-offset)))]) - (if (and (eqv? (constant type) (constant type-fixnum)) - (eqv? (constant mask) (constant mask-fixnum))) - (build-and e (build-fixnums? (if maybe-e-new (list e-i t maybe-e-new) (list e-i t)))) - (build-and - (%type-check mask type ,t) - (build-and - (build-fixnums? (if maybe-e-new (list e-i maybe-e-new) (list e-i))) - e))))]))))])) - (define-syntax build-set-immutable! - (syntax-rules () - [(_ type-disp immutable-flag) - (lambda (e-v) - (bind #t (e-v) - `(set! ,(%mref ,e-v ,(constant type-disp)) - ,(%inline logor - ,(%mref ,e-v ,(constant type-disp)) - (immediate ,(constant immutable-flag))))))])) - (define inline-args-limit (constant inline-args-limit)) - (define reduce-equality - (lambda (src sexpr moi e1 e2 e*) - (and (fx<= (length e*) (fx- inline-args-limit 2)) - (bind #t (e1) - (bind #f (e2) - (list-bind #f (e*) - (let compare ([src src] [e2 e2] [e* e*]) - (if (null? e*) - (moi src sexpr (list e1 e2)) - `(if ,(moi src sexpr (list e1 e2)) - ,(compare #f (car e*) (cdr e*)) - (quote #f)))))))))) - (define reduce-inequality - (lambda (src sexpr moi e1 e2 e*) - (and (fx<= (length e*) (fx- inline-args-limit 2)) - (let f ([e2 e2] [e* e*] [re* '()]) - (if (null? e*) - (bind #f ([e2 e2]) - (let compare ([src src] [e* (cons e1 (reverse (cons e2 re*)))]) - (let ([more-args (cddr e*)]) - (if (null? more-args) - (moi src sexpr e*) - `(if ,(moi src sexpr (list (car e*) (cadr e*))) - ,(compare #f (cdr e*)) - (quote #f)))))) - (bind #t ([e2 e2]) (f (car e*) (cdr e*) (cons e2 re*)))))))) - (define reduce ; left associative as required for, e.g., fx- - (lambda (src sexpr moi e e*) - (and (fx<= (length e*) (fx- inline-args-limit 1)) - (bind #f (e) - (list-bind #f ([e* e*]) - (let reduce ([src src] [e e] [e* e*]) - (if (null? e*) - e - (reduce #f (moi src sexpr (list e (car e*))) (cdr e*))))))))) - (define reduce-fp-compare ; suitable for arguments known or assumed to produce flonums - (lambda (reduce) - (lambda (src sexpr moi e1 e2 e*) - (and (fx<= (length e*) (fx- inline-args-limit 2)) - (bind #t fp (e1) - (bind #f fp (e2) - (list-bind #f fp (e*) - (reduce src sexpr moi e1 e2 e*)))))))) - (define reduce-fp ; specialized reducer supports unboxing for nesting - (lambda (src sexpr level name e e*) - (and (fx<= (length e*) (fx- inline-args-limit 1)) - (let ([pr (lookup-primref level name)]) - (let reduce ([e e] [src src] [sexpr sexpr] [e* e*]) - (if (null? e*) - e - (reduce `(call ,(make-info-call src sexpr #f #f #f) #f ,pr ,e ,(car e*)) - #f #f (cdr e*)))))))) - (module (relop-length RELOP< RELOP<= RELOP= RELOP>= RELOP>) - (define RELOP< -2) - (define RELOP<= -1) - (define RELOP= 0) - (define RELOP>= 1) - (define RELOP> 2) - (define (mirror op) (fx- op)) - (define go - (lambda (op e n) - (let f ([n n] [e e]) - (if (fx= n 0) - (cond - [(or (eqv? op RELOP=) (eqv? op RELOP<=)) (build-null? e)] - [(eqv? op RELOP<) `(seq ,e (quote #f))] - [(eqv? op RELOP>) (build-not (build-null? e))] - [(eqv? op RELOP>=) `(seq ,e (quote #t))] - [else (sorry! 'relop-length "unexpected op ~s" op)]) - (cond - [(or (eqv? op RELOP=) (eqv? op RELOP>)) - (bind #t (e) - (build-and - (build-not (build-null? e)) - (f (fx- n 1) (build-cdr e))))] - [(eqv? op RELOP<) - (if (fx= n 1) - (build-null? e) - (bind #t (e) - (build-simple-or - (build-null? e) - (f (fx- n 1) (build-cdr e)))))] - [(eqv? op RELOP<=) - (bind #t (e) - (build-simple-or - (build-null? e) - (f (fx- n 1) (build-cdr e))))] - [(eqv? op RELOP>=) - (if (fx= n 1) - (build-not (build-null? e)) - (bind #t (e) - (build-and - (build-not (build-null? e)) - (f (fx- n 1) (build-cdr e)))))] - [else (sorry! 'relop-length "unexpected op ~s" op)]))))) - (define relop-length1 - (lambda (op e n) - (nanopass-case (L7 Expr) e - [(call ,info ,mdcl ,pr ,e) - (guard (and (eq? (primref-name pr) 'length) (all-set? (prim-mask unsafe) (primref-flags pr)))) - (go op e n)] - [else #f]))) - (define relop-length2 - (lambda (op e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) (and (fixnum? d) (fx<= 0 d 4) (relop-length1 op e1 d))] - [else #f]))) - (define relop-length - (case-lambda - [(op e) (relop-length1 op e 0)] - [(op e1 e2) (or (relop-length2 op e1 e2) (relop-length2 (mirror op) e2 e1))]))) - (define make-ftype-pointer-equal? - (lambda (e1 e2) - (bind #f (e1 e2) - (%inline eq? - ,(%mref ,e1 ,(constant record-data-disp)) - ,(%mref ,e2 ,(constant record-data-disp)))))) - (define make-ftype-pointer-null? - (lambda (e) - (%inline eq? - ,(%mref ,e ,(constant record-data-disp)) - (immediate 0)))) - (define eqvop-null-fptr - (lambda (e1 e2) - (nanopass-case (L7 Expr) e1 - [(call ,info ,mdcl ,pr ,e1) - (and - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr)) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (and (eqv? d 0) (make-ftype-pointer-null? e1))] - [(call ,info ,mdcl ,pr ,e2) - (and (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr)) - (make-ftype-pointer-equal? e1 e2))] - [else #f]))] - [(quote ,d) - (and (eqv? d 0) - (nanopass-case (L7 Expr) e2 - [(call ,info ,mdcl ,pr ,e2) - (and (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr)) - (make-ftype-pointer-null? e2))] - [else #f]))] - [else #f]))) - (define-inline 2 values - [(e) (ensure-single-valued e)] - [e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)]) - (define-inline 2 $value - [(e) (ensure-single-valued e #f)]) - (define-inline 2 eq? - [(e1 e2) - (or (eqvop-null-fptr e1 e2) - (relop-length RELOP= e1 e2) - (%inline eq? ,e1 ,e2))]) - (define-inline 2 keep-live - [(e) (%seq ,(%inline keep-live ,e) ,(%constant svoid))]) - (let () - (define (zgo src sexpr e e1 e2 r6rs?) - (build-simple-or - (%inline eq? ,e (immediate 0)) - `(if ,(build-fixnums? (list e)) - ,(%constant sfalse) - ,(if r6rs? - (build-libcall #t src sexpr fx=? e1 e2) - (build-libcall #t src sexpr fx= e1 e2))))) - (define (go src sexpr e1 e2 r6rs?) - (or (relop-length RELOP= e1 e2) - (cond - [(constant? (lambda (x) (eqv? x 0)) e1) - (bind #t (e2) (zgo src sexpr e2 e1 e2 r6rs?))] - [(constant? (lambda (x) (eqv? x 0)) e2) - (bind #t (e1) (zgo src sexpr e1 e1 e2 r6rs?))] - [else (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline eq? ,e1 ,e2) - ,(if r6rs? - (build-libcall #t src sexpr fx=? e1 e2) - (build-libcall #t src sexpr fx= e1 e2))))]))) - (define-inline 2 fx= - [(e1 e2) (go src sexpr e1 e2 #f)] - [(e1 . e*) #f]) - (define-inline 2 fx=? - [(e1 e2) (go src sexpr e1 e2 #t)] - [(e1 e2 . e*) #f])) - (let () ; level 2 fx<, fx= fx>=? RELOP>= >=) - (fx-pred fx> fx>? RELOP> >)) - (let () ; level 3 fx=, fx=?, etc. - (define-syntax fx-pred - (syntax-rules () - [(_ op r6rs:op length-op inline-op) - (let () - (define (go e1 e2) - (or (relop-length length-op e1 e2) - (%inline inline-op ,e1 ,e2))) - (define reducer - (if (eq? 'inline-op 'eq?) - reduce-equality - reduce-inequality)) - (define-inline 3 op - [(e) `(seq ,(ensure-single-valued e) ,(%constant strue))] - [(e1 e2) (go e1 e2)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) - (define-inline 3 r6rs:op - [(e1 e2) (go e1 e2)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]))])) - (fx-pred fx< fx= fx>=? RELOP>= >=) - (fx-pred fx> fx>? RELOP> >)) - (let () ; level 3 fxlogand, ... - (define-syntax fxlogop - (syntax-rules () - [(_ op inline-op base) - (define-inline 3 op - [() `(immediate ,(fix base))] - [(e) (ensure-single-valued e)] - [(e1 e2) (%inline inline-op ,e1 ,e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)])])) - (fxlogop fxlogand logand -1) - (fxlogop fxand logand -1) - (fxlogop fxlogor logor 0) - (fxlogop fxlogior logor 0) - (fxlogop fxior logor 0) - (fxlogop fxlogxor logxor 0) - (fxlogop fxxor logxor 0)) - (let () - (define log-partition - (lambda (p base e*) - (let loop ([e* e*] [n base] [nc* '()]) - (if (null? e*) - (if (and (fixnum? n) (fx= n base) (not (null? nc*))) - (values (car nc*) (cdr nc*) nc*) - (values `(immediate ,(fix n)) nc* nc*)) - (let ([e (car e*)]) - (if (fixnum-constant? e) - (let ([m (constant-value e)]) - (loop (cdr e*) (if n (p n m) m) nc*)) - (loop (cdr e*) n (cons e nc*)))))))) - (let () ; level 2 fxlogor, fxlogior, fxor - (define-syntax fxlogorop - (syntax-rules () - [(_ op) - (let () - (define (go src sexpr e*) - (and (fx<= (length e*) inline-args-limit) - (list-bind #t (e*) - (let-values ([(e e* nc*) (log-partition logor 0 e*)]) - (bind #t ([t (fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) e e*)]) - `(if ,(%type-check mask-fixnum type-fixnum ,t) - ,t - ,(case (length nc*) - [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] - [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] - ; TODO: need fxargerr library routine w/who arg & rest interface - [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))]))))))) ; NB: should be error call---but is it? - (define-inline 2 op - [() `(immediate ,(fix 0))] - [e* (go src sexpr e*)]))])) - (fxlogorop fxlogor) - (fxlogorop fxlogior) - (fxlogorop fxior)) - (let () ; level 2 fxlogand, ... - (define-syntax fxlogop - (syntax-rules () - [(_ op inline-op base) - (define-inline 2 op - [() `(immediate ,(fix base))] - [e* (and (fx<= (length e*) (fx- inline-args-limit 1)) - (list-bind #t (e*) - ;; NB: using inline-op here because it works when target's - ;; NB: fixnum range is larger than the host's fixnum range - ;; NB: during cross compile - (let-values ([(e e* nc*) (log-partition inline-op base e*)]) - `(if ,(build-fixnums? nc*) - ,(fold-left (lambda (e1 e2) (%inline inline-op ,e1 ,e2)) e e*) - ; TODO: need fxargerr library routine w/who arg & rest interface - ,(case (length nc*) - [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] - [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] - ; TODO: need fxargerr library routine w/who arg & rest interface - [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))])))))])])) ; NB: should be error call---but is it? - (fxlogop fxlogand logand -1) - (fxlogop fxand logand -1) - (fxlogop fxlogxor logxor 0) - (fxlogop fxxor logxor 0))) - (define-inline 3 fxlogtest - [(e1 e2) (%inline logtest ,e1 ,e2)]) - (define-inline 2 fxlogtest - [(e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline logtest ,e1 ,e2) - ,(build-libcall #t src sexpr fxlogtest e1 e2)))]) - (let () - (define xorbits (lognot (constant mask-fixnum))) - (define-syntax fxlognotop - (syntax-rules () - [(_ name) - (begin - (define-inline 3 name - [(e) (%inline logxor ,e (immediate ,xorbits))]) - (define-inline 2 name - [(e) (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%inline logxor ,e (immediate ,xorbits)) - ,(build-libcall #t src sexpr name e)))]))])) - (fxlognotop fxlognot) - (fxlognotop fxnot)) - (define-inline 3 $fxu< - [(e1 e2) (or (relop-length RELOP< e1 e2) - (%inline u< ,e1 ,e2))]) - (define-inline 3 fx+ - [() `(immediate 0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (%inline + ,e1 ,e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - (define-inline 3 r6rs:fx+ ; limited to two arguments - [(e1 e2) (%inline + ,e1 ,e2)]) - (define-inline 3 fx+/wraparound - [(e1 e2) (%inline + ,e1 ,e2)]) - (define-inline 3 fx1+ - [(e) (%inline + ,e (immediate ,(fix 1)))]) - (define-inline 2 $fx+? - [(e1 e2) - (let ([Lfalse (make-local-label 'Lfalse)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Lfalse ,(%constant sfalse)) - ,t)) - (goto ,Lfalse))))]) - (let () - (define (go src sexpr e1 e2) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2)) - ,t)) - (goto ,Llib))))) - (define-inline 2 fx+ - [() `(immediate 0)] - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,e - ,(build-libcall #t #f sexpr fx+ e `(immediate ,(fix 0)))))] - [(e1 e2) (go src sexpr e1 e2)] - ; TODO: 3-operand case requires 3-operand library routine - #;[(e1 e2 e3) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2 e3) - `(if ,(build-fixnums? (list e1 e2 e3)) - ,(bind #t ([t (%inline +/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2 e3)) - ,(bind #t ([t (%inline +/ovfl ,t ,e3)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (goto ,Llib) - ,t)))) - (goto ,Llib))))] - [(e1 . e*) #f]) - (define-inline 2 r6rs:fx+ ; limited to two arguments - [(e1 e2) (go src sexpr e1 e2)]) - (define-inline 2 fx+/wraparound - [(e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline + ,e1 ,e2) - ,(build-libcall #t src sexpr fx+/wraparound e1 e2)))])) - - (define-inline 3 fx- - [(e) (%inline - (immediate 0) ,e)] - [(e1 e2) (%inline - ,e1 ,e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - (define-inline 3 r6rs:fx- ; limited to one or two arguments - [(e) (%inline - (immediate 0) ,e)] - [(e1 e2) (%inline - ,e1 ,e2)]) - (define-inline 3 fx-/wraparound - [(e1 e2) (%inline - ,e1 ,e2)]) - (define-inline 3 fx1- - [(e) (%inline - ,e (immediate ,(fix 1)))]) - (define-inline 2 $fx-? - [(e1 e2) - (let ([Lfalse (make-local-label 'Lfalse)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t (%inline -/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Lfalse ,(%constant sfalse)) - ,t)) - (goto ,Lfalse))))]) - (let () - (define (go src sexpr e1 e2) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2)) - ,t)) - (goto ,Llib))))) - (define-inline 2 fx- - [(e) (go src sexpr `(immediate ,(fix 0)) e)] - [(e1 e2) (go src sexpr e1 e2)] - ; TODO: 3-operand case requires 3-operand library routine - #;[(e1 e2 e3) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2 e3) - `(if ,(build-fixnums? (list e1 e2 e3)) - ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2 e3)) - ,(bind #t ([t (%inline -/ovfl ,t ,e3)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (goto ,Llib) - ,t)))) - (goto ,Llib))))] - [(e1 . e*) #f]) - (define-inline 2 r6rs:fx- ; limited to one or two arguments - [(e) (go src sexpr `(immediate ,(fix 0)) e)] - [(e1 e2) (go src sexpr e1 e2)]) - (define-inline 2 fx-/wraparound - [(e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline - ,e1 ,e2) - ,(build-libcall #t src sexpr fx-/wraparound e1 e2)))])) - (define-inline 2 fx1- - [(e) (let ([Llib (make-local-label 'Llib)]) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(bind #t ([t (%inline -/ovfl ,e (immediate ,(fix 1)))]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx1- e)) - ,t)) - (goto ,Llib))))]) - (define-inline 2 fx1+ - [(e) (let ([Llib (make-local-label 'Llib)]) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(bind #f ([t (%inline +/ovfl ,e (immediate ,(fix 1)))]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx1+ e)) - ,t)) - (goto ,Llib))))]) - - (let () - (define fixnum-powers-of-two - (let f ([m 2] [e 1]) - (if (<= m (constant most-positive-fixnum)) - (cons (cons m e) (f (* m 2) (fx+ e 1))) - '()))) - (define-inline 3 fxdiv - [(e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (let ([a (assv d fixnum-powers-of-two)]) - (and a - (%inline logand - ,(%inline sra ,e1 (immediate ,(cdr a))) - (immediate ,(- (constant fixnum-factor))))))] - [else #f])]) - (define-inline 3 fxmod - [(e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (let ([a (assv d fixnum-powers-of-two)]) - (and a (%inline logand ,e1 (immediate ,(fix (- d 1))))))] - [else #f])]) - (let () - (define (build-fx* e1 e2 ovfl?) - (define (fx*-constant e n) - (if ovfl? - (%inline */ovfl ,e (immediate ,n)) - (cond - [(eqv? n 1) e] - [(eqv? n -1) (%inline - (immediate 0) ,e)] - [(eqv? n 2) (%inline sll ,e (immediate 1))] - [(eqv? n 3) - (bind #t (e) - (%inline + - ,(%inline + ,e ,e) - ,e))] - [(eqv? n 10) - (bind #t (e) - (%inline + - ,(%inline + - ,(%inline sll ,e (immediate 3)) - ,e) - ,e))] - [(assv n fixnum-powers-of-two) => - (lambda (a) (%inline sll ,e (immediate ,(cdr a))))] - [else (%inline * ,e (immediate ,n))]))) - (nanopass-case (L7 Expr) e2 - [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e1 d)] - [else - (nanopass-case (L7 Expr) e1 - [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e2 d)] - [else - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(if ovfl? - (%inline */ovfl ,e1 ,t) - (%inline * ,e1 ,t))))])])) - (define-inline 3 fx* - [() `(immediate ,(fix 1))] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-fx* e1 e2 #f)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - (define-inline 3 r6rs:fx* ; limited to two arguments - [(e1 e2) (build-fx* e1 e2 #f)]) - (define-inline 3 fx*/wraparound - [(e1 e2) (build-fx* e1 e2 #f)]) - (let () - (define (go src sexpr e1 e2) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #t ([t (build-fx* e1 e2 #t)]) - `(if (inline ,(make-info-condition-code 'multiply-overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2)) - ,t)) - (goto ,Llib))))) - (define-inline 2 fx* - [() `(immediate ,(fix 1))] - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,e - ,(build-libcall #t src sexpr fx* e `(immediate ,(fix 0)))))] - [(e1 e2) (go src sexpr e1 e2)] - ; TODO: 3-operand case requires 3-operand library routine - #;[(e1 e2 e3) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e1 e2 e3) - `(if ,(build-fixnums? (list e1 e2 e3)) - ,(bind #t ([t (build-fx* e1 e2 #t)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2 e3)) - ,(bind #t ([t (build-fx* t e3 #t)]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (goto ,Llib) - ,t)))) - (goto ,Llib))))] - [(e1 . e*) #f]) - (define-inline 2 r6rs:fx* ; limited to two arguments - [(e1 e2) (go src sexpr e1 e2)]) - (define-inline 2 fx*/wraparound - [(e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(build-fx* e1 e2 #f) - ,(build-libcall #t src sexpr fx*/wraparound e1 e2)))])) - (let () - (define build-fx/p2 - (lambda (e1 p2) - (bind #t (e1) - (build-fix - (%inline sra - ,(%inline + ,e1 - ,(%inline srl - ,(if (fx= p2 1) - e1 - (%inline sra ,e1 (immediate ,(fx- p2 1)))) - (immediate ,(fx- (constant fixnum-bits) p2)))) - (immediate ,(fx+ p2 (constant fixnum-offset)))))))) - - (define build-fx/ - (lambda (src sexpr e1 e2) - (or (nanopass-case (L7 Expr) e2 - [(quote ,d) - (let ([a (assv d fixnum-powers-of-two)]) - (and a (build-fx/p2 e1 (cdr a))))] - [else #f]) - (if (constant integer-divide-instruction) - (build-fix (%inline / ,e1 ,e2)) - `(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 '$fx/) - ,e1 ,e2))))) - - (define-inline 3 fx/ - [(e) (build-fx/ src sexpr `(quote 1) e)] - [(e1 e2) (build-fx/ src sexpr e1 e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxquotient - [(e) (build-fx/ src sexpr `(quote 1) e)] - [(e1 e2) (build-fx/ src sexpr e1 e2)] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxremainder - [(e1 e2) - (bind #t (e1 e2) - (%inline - ,e1 - ,(build-fx* - (build-fx/ src sexpr e1 e2) - e2 #f)))])) - (let () - (define-syntax build-fx - (lambda (x) - (syntax-case x () - [(_ op a1 a2) - #`(%inline op - #,(if (number? (syntax->datum #'a1)) - #`(immediate a1) - #`,a1) - #,(if (number? (syntax->datum #'a2)) - #`(immediate a2) - #`,a2))]))) - (define (build-popcount16 e) - (constant-case popcount-instruction - [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 16-bit - [else - (let ([x (make-tmp 'x 'uptr)] - [x2 (make-tmp 'x2 'uptr)] - [x3 (make-tmp 'x3 'uptr)] - [x4 (make-tmp 'x4 'uptr)]) - `(let ([,x ,(build-unfix e)]) - (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555))]) - (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333) (build-fx logand (build-fx srl x2 2) #x3333))]) - (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f)]) - ,(build-fix (build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x1f)))))))])) - (define (build-popcount32 e) - (constant-case popcount-instruction - [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 32-bit - [else - (let ([x (make-tmp 'x 'uptr)] - [x2 (make-tmp 'x2 'uptr)] - [x3 (make-tmp 'x3 'uptr)] - [x4 (make-tmp 'x4 'uptr)]) - `(let ([,x ,(build-unfix e)]) - (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x55555555))]) - (let ([,x3 ,(build-fx + (build-fx logand x2 #x33333333) (build-fx logand (build-fx srl x2 2) #x33333333))]) - (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f)]) - ,(build-fix (build-fx logand (build-fx srl (build-fx * x4 #x01010101) 24) #x3f)))))))])) - (define (build-popcount e) - (constant-case popcount-instruction - [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed - [else - (constant-case ptr-bits - [(32) (build-popcount32 e)] - [(64) - (let ([x (make-tmp 'x 'uptr)] - [x2 (make-tmp 'x2 'uptr)] - [x3 (make-tmp 'x3 'uptr)] - [x4 (make-tmp 'x4 'uptr)] - [x5 (make-tmp 'x5 'uptr)]) - `(let ([,x ,e]) ; no unfix needed - (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555555555555555))]) - (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333333333333333) (build-fx logand (build-fx srl x2 2) #x3333333333333333))]) - (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f0f0f0f0f)]) - (let ([,x5 ,(build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x00ff00ff00ff00ff)]) - ,(build-fix (build-fx logand (build-fx srl (build-fx * x5 #x0101010101010101) 56) #x7f))))))))])])) - (define-inline 3 fxpopcount - [(e) - (bind #f (e) - (build-popcount e))]) - (define-inline 2 fxpopcount - [(e) - (bind #t (e) - `(if ,(build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline >= ,e (immediate ,0))) - ,(build-popcount e) - ,(build-libcall #t #f sexpr fxpopcount e)))]) - (define-inline 3 fxpopcount32 - [(e) - (bind #f (e) - (build-popcount32 e))]) - (define-inline 2 fxpopcount32 - [(e) - (bind #t (e) - `(if ,(constant-case ptr-bits - [(32) - (build-and (%type-check mask-fixnum type-fixnum ,e) - (%inline >= ,e (immediate ,0)))] - [(64) - (build-and (%type-check mask-fixnum type-fixnum ,e) - (%inline u< ,e (immediate ,(fix #x100000000))))]) - ,(build-popcount32 e) - ,(build-libcall #t #f sexpr fxpopcount32 e)))]) - (define-inline 3 fxpopcount16 - [(e) - (bind #f (e) - (build-popcount16 e))]) - (define-inline 2 fxpopcount16 - [(e) - (bind #f (e) - `(if ,(build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< ,e (immediate ,(fix #x10000)))) - ,(build-popcount16 e) - ,(build-libcall #t #f sexpr fxpopcount16 e)))])))) - (let () - (define do-fxsll - (lambda (e1 e2) - (nanopass-case (L7 Expr) e2 - [(quote ,d) - (%inline sll ,e1 (immediate ,d))] - [else - ; TODO: bind-uptr might be handy here and also a make-unfix - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(%inline sll ,e1 ,t)))]))) - (define-inline 3 fxsll - [(e1 e2) (do-fxsll e1 e2)]) - (define-inline 3 fxarithmetic-shift-left - [(e1 e2) (do-fxsll e1 e2)]) - (define-inline 3 fxsll/wraparound - [(e1 e2) (do-fxsll e1 e2)])) - (define-inline 3 fxsrl - [(e1 e2) - (%inline logand - ,(nanopass-case (L7 Expr) e2 - [(quote ,d) - (%inline srl ,e1 (immediate ,d))] - [else - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(%inline srl ,e1 ,t)))]) - (immediate ,(fx- (constant fixnum-factor))))]) - (let () - (define do-fxsra - (lambda (e1 e2) - (%inline logand - ,(nanopass-case (L7 Expr) e2 - [(quote ,d) - (%inline sra ,e1 (immediate ,d))] - [else - (let ([t (make-tmp 't 'uptr)]) - `(let ([,t ,(build-unfix e2)]) - ,(%inline sra ,e1 ,t)))]) - (immediate ,(fx- (constant fixnum-factor)))))) - (define-inline 3 fxsra - [(e1 e2) (do-fxsra e1 e2)]) - (define-inline 3 fxarithmetic-shift-right - [(e1 e2) (do-fxsra e1 e2)])) - (let () - (define-syntax %safe-shift - (syntax-rules () - [(_ src sexpr op libcall e1 e2 ?size) - (let ([size ?size]) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- size 1)))) e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1)) - ,(%inline logand - ,(%inline op ,e1 (immediate ,(constant-value e2))) - (immediate ,(- (constant fixnum-factor)))) - ,(build-libcall #t src sexpr libcall e1 e2))) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e2 (immediate ,(fix size)))) - ,(%inline logand - ,(%inline op ,e1 ,(build-unfix e2)) - (immediate ,(- (constant fixnum-factor)))) - ,(build-libcall #t src sexpr libcall e1 e2)))))])) - (define-inline 2 fxsrl - [(e1 e2) (%safe-shift src sexpr srl fxsrl e1 e2 (+ (constant fixnum-bits) 1))]) - (define-inline 2 fxsra - [(e1 e2) (%safe-shift src sexpr sra fxsra e1 e2 (+ (constant fixnum-bits) 1))]) - (define-inline 2 fxarithmetic-shift-right - [(e1 e2) (%safe-shift src sexpr sra fxarithmetic-shift-right e1 e2 (constant fixnum-bits))])) - (define-inline 3 fxarithmetic-shift - [(e1 e2) - (or (nanopass-case (L7 Expr) e2 - [(quote ,d) - (and (fixnum? d) - (if ($fxu< d (constant fixnum-bits)) - (%inline sll ,e1 (immediate ,d)) - (and (fx< (fx- (constant fixnum-bits)) d 0) - (%inline logand - ,(%inline sra ,e1 (immediate ,(fx- d))) - (immediate ,(- (constant fixnum-factor)))))))] - [else #f]) - (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) - (define-inline 2 fxarithmetic-shift - [(e1 e2) - (or (nanopass-case (L7 Expr) e2 - [(quote ,d) - (guard (fixnum? d) (fx< (fx- (constant fixnum-bits)) d 0)) - (bind #t (e1) - `(if ,(build-fixnums? (list e1)) - ,(%inline logand - ,(%inline sra ,e1 (immediate ,(fx- d))) - (immediate ,(- (constant fixnum-factor)))) - ,(build-libcall #t src sexpr fxarithmetic-shift e1 e2)))] - [else #f]) - (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) - (let () - (define dofxlogbit0 - (lambda (e1 e2) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (%inline logand ,e1 - (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) - (%inline logand ,e1 - ,(%inline lognot - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2))))))) - (define dofxlogbit1 - (lambda (e1 e2) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (%inline logor ,e1 - (immediate ,(fix (ash 1 (constant-value e2))))) - (%inline logor ,e1 - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2)))))) - (define-inline 3 fxlogbit0 - [(e1 e2) (dofxlogbit0 e2 e1)]) - (define-inline 3 fxlogbit1 - [(e1 e2) (dofxlogbit1 e2 e1)]) - (define-inline 3 fxcopy-bit - [(e1 e2 e3) - ;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here. - (and (fixnum-constant? e3) - (case (constant-value e3) - [(0) (dofxlogbit0 e1 e2)] - [(1) (dofxlogbit1 e1 e2)] - [else #f]))])) - (let () - (define dofxlogbit0 - (lambda (e1 e2 libcall) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (bind #t (e1) - `(if ,(build-fixnums? (list e1)) - ,(%inline logand ,e1 - (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) - ,(libcall e1 e2))) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logand ,e1 - ,(%inline lognot - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2)))) - ,(libcall e1 e2)))))) - (define dofxlogbit1 - (lambda (e1 e2 libcall) - (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) - (bind #t (e1) - `(if ,(build-fixnums? (list e1)) - ,(%inline logor ,e1 - (immediate ,(fix (ash 1 (constant-value e2))))) - ,(libcall e1 e2))) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logor ,e1 - ,(%inline sll (immediate ,(fix 1)) - ,(build-unfix e2))) - ,(libcall e1 e2)))))) - (define-inline 2 fxlogbit0 - [(e1 e2) (dofxlogbit0 e2 e1 - (lambda (e2 e1) - (build-libcall #t src sexpr fxlogbit0 e1 e2)))]) - (define-inline 2 fxlogbit1 - [(e1 e2) (dofxlogbit1 e2 e1 - (lambda (e2 e1) - (build-libcall #t src sexpr fxlogbit1 e1 e2)))]) - (define-inline 2 fxcopy-bit - [(e1 e2 e3) - (and (fixnum-constant? e3) - (case (constant-value e3) - [(0) (dofxlogbit0 e1 e2 - (lambda (e1 e2) - (build-libcall #t src sexpr fxcopy-bit e1 e2)))] - [(1) (dofxlogbit1 e1 e2 - (lambda (e1 e2) - (build-libcall #t src sexpr fxcopy-bit e1 e2)))] - [else #f]))])) - (define-inline 3 fxzero? - [(e) (or (relop-length RELOP= e) (%inline eq? ,e (immediate 0)))]) - (define-inline 3 fxpositive? - [(e) (or (relop-length RELOP> e) (%inline > ,e (immediate 0)))]) - (define-inline 3 fxnonnegative? - [(e) (or (relop-length RELOP>= e) (%inline >= ,e (immediate 0)))]) - (define-inline 3 fxnegative? - [(e) (or (relop-length RELOP< e) (%inline < ,e (immediate 0)))]) - (define-inline 3 fxnonpositive? - [(e) (or (relop-length RELOP<= e) (%inline <= ,e (immediate 0)))]) - (define-inline 3 fxeven? - [(e) (%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 0)))]) - (define-inline 3 fxodd? - [(e) (%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 1)))]) - - (define-inline 2 fxzero? - [(e) (or (relop-length RELOP= e) - (bind #t (e) - (build-simple-or - (%inline eq? ,e (immediate 0)) - `(if ,(build-fixnums? (list e)) - ,(%constant sfalse) - ,(build-libcall #t src sexpr fxzero? e)))))]) - (define-inline 2 fxpositive? - [(e) (or (relop-length RELOP> e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline > ,e (immediate 0)) - ,(build-libcall #t src sexpr fxpositive? e))))]) - (define-inline 2 fxnonnegative? - [(e) (or (relop-length RELOP>= e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline >= ,e (immediate 0)) - ,(build-libcall #t src sexpr fxnonnegative? e))))]) - (define-inline 2 fxnegative? - [(e) (or (relop-length RELOP< e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline < ,e (immediate 0)) - ,(build-libcall #t src sexpr fxnegative? e))))]) - (define-inline 2 fxnonpositive? - [(e) (or (relop-length RELOP<= e) - (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline <= ,e (immediate 0)) - ,(build-libcall #t src sexpr fxnonpositive? e))))]) - (define-inline 2 fxeven? - [(e) (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 0))) - ,(build-libcall #t src sexpr fxeven? e)))]) - (define-inline 2 fxodd? - [(e) (bind #t (e) - `(if ,(build-fixnums? (list e)) - ,(%inline eq? - ,(%inline logand ,e (immediate ,(fix 1))) - (immediate ,(fix 1))) - ,(build-libcall #t src sexpr fxodd? e)))]) - (let () - (define dofxlogbit? - (lambda (e1 e2) - (cond - [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) - (%inline logtest ,e2 (immediate ,(fix (ash 1 (constant-value e1)))))] - [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) - (%inline < ,e2 (immediate ,(fix 0)))] - [(fixnum-constant? e2) - (bind #t (e1) - `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) - ,(if (< (constant-value e2) 0) (%constant strue) (%constant sfalse)) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1)))))] - [else - (bind #t (e1 e2) - `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) - ,(%inline < ,e2 (immediate ,(fix 0))) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1)))))]))) - - (define-inline 3 fxbit-set? - [(e1 e2) (dofxlogbit? e2 e1)]) - - (define-inline 3 fxlogbit? - [(e1 e2) (dofxlogbit? e1 e2)])) - - (let () - (define dofxlogbit? - (lambda (e1 e2 libcall) - (cond - [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) - (bind #t (e2) - `(if ,(build-fixnums? (list e2)) - ,(%inline logtest ,e2 - (immediate ,(fix (ash 1 (constant-value e1))))) - ,(libcall e1 e2)))] - [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) - (bind #t (e2) - `(if ,(build-fixnums? (list e2)) - ,(%inline < ,e2 (immediate ,(fix 0))) - ,(libcall e1 e2)))] - [else - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1))) - ,(libcall e1 e2)))]))) - - (define-inline 2 fxbit-set? - [(e1 e2) (dofxlogbit? e2 e1 - (lambda (e2 e1) - (build-libcall #t src sexpr fxbit-set? e1 e2)))]) - (define-inline 2 fxlogbit? - [(e1 e2) (dofxlogbit? e1 e2 - (lambda (e1 e2) - (build-libcall #t src sexpr fxlogbit? e1 e2)))])) - - ; can avoid if in fxabs with: - ; t = sra(x, k) ; where k is ptr-bits - 1 - ; ; t is now -1 if x's sign bit set, otherwise 0 - ; x = xor(x, t) ; logical not if x negative, otherwise leave x alone - ; x = x - t ; add 1 to complete two's complement negation if - ; ; x was negative, otherwise leave x alone - ; tests on i3le indicate that the if is actually faster, even in a loop - ; where input alternates between positive and negative to defeat branch - ; prediction. - (define-inline 3 fxabs - [(e) (bind #t (e) - `(if ,(%inline < ,e (immediate ,(fix 0))) - ,(%inline - (immediate ,(fix 0)) ,e) - ,e))]) - - ;(define-inline 3 min ; needs library min - ; ; must take care to be inexactness-preserving - ; [(e0) e0] - ; [(e0 e1) - ; (bind #t (e0 e1) - ; `(if ,(build-fixnums? (list e0 e1)) - ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) - ; ,(build-libcall #t src sexpr min e0 e1)))] - ; [(e0 . e*) (reduce src sexpr moi e1 e*)]) - ; - ;(define-inline 3 max ; needs library max - ; ; must take care to be inexactness-preserving - ; [(e0) e0] - ; [(e0 e1) - ; (bind #t (e0 e1) - ; `(if ,(build-fixnums? (list e0 e1)) - ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) - ; ,(build-libcall #t src sexpr max e0 e1)))] - ; [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxmin - [(e) (ensure-single-valued e)] - [(e1 e2) (bind #t (e1 e2) - `(if ,(%inline < ,e1 ,e2) - ,e1 - ,e2))] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxmax - [(e) (ensure-single-valued e)] - [(e1 e2) (bind #t (e1 e2) - `(if ,(%inline < ,e2 ,e1) - ,e1 - ,e2))] - [(e1 . e*) (reduce src sexpr moi e1 e*)]) - - (define-inline 3 fxif - [(e1 e2 e3) - (bind #t (e1) - (%inline logor - ,(%inline logand ,e2 ,e1) - ,(%inline logand ,e3 - ,(%inline lognot ,e1))))]) - - (define-inline 3 fxbit-field - [(e1 e2 e3) - (and (constant? fixnum? e2) (constant? fixnum? e3) - (let ([start (constant-value e2)] [end (constant-value e3)]) - (if (fx= end start) - (%seq ,e1 (immediate ,(fix 0))) - (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) - (extract-unsigned-bitfield #f start end e1)))))]) - - (define-inline 3 fxcopy-bit-field - [(e1 e2 e3 e4) - (and (constant? fixnum? e2) (constant? fixnum? e3) - (let ([start (constant-value e2)] [end (constant-value e3)]) - (if (fx= end start) - e1 - (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) - (insert-bitfield #f start end (constant fixnum-bits) e1 e4)))))]) - - ;; could be done with one mutable variable instead of two, but this seems to generate - ;; the same code as the existing compiler - (define-inline 3 fxlength - [(e) - (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) - `(let ([,t ,(build-unfix e)]) - (seq - (if ,(%inline < ,t (immediate 0)) - (set! ,t ,(%inline lognot ,t)) - ,(%constant svoid)) - (let ([,result (immediate ,(fix 0))]) - ,((lambda (body) - (constant-case fixnum-bits - [(30) body] - [(61) - `(seq - (if ,(%inline < ,t (immediate #x100000000)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 32))) - (set! ,result - ,(%inline + ,result (immediate ,(fix 32)))))) - ,body)])) - (%seq - (if ,(%inline < ,t (immediate #x10000)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 16))) - (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) - (if ,(%inline < ,t (immediate #x100)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 8))) - (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) - ,(%inline + ,result - (inline ,(make-info-load 'unsigned-8 #f) ,%load - ,(%tc-ref fxlength-bv) ,t - ,(%constant bytevector-data-disp)))))))))]) - - (define-inline 3 fxfirst-bit-set - [(e) - (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) - (bind #t (e) - `(if ,(%inline eq? ,e (immediate ,(fix 0))) - (immediate ,(fix -1)) - (let ([,t ,(build-unfix e)] [,result (immediate ,(fix 0))]) - ,((lambda (body) - (constant-case fixnum-bits - [(30) body] - [(61) - `(seq - (if ,(%inline logtest ,t (immediate #xffffffff)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 32))) - (set! ,result ,(%inline + ,result (immediate ,(fix 32)))))) - ,body)])) - (%seq - (if ,(%inline logtest ,t (immediate #xffff)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 16))) - (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) - (if ,(%inline logtest ,t (immediate #xff)) - ,(%constant svoid) - (seq - (set! ,t ,(%inline srl ,t (immediate 8))) - (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) - ,(%inline + ,result - (inline ,(make-info-load 'unsigned-8 #f) ,%load - ,(%tc-ref fxfirst-bit-set-bv) - ,(%inline logand ,t (immediate #xff)) - ,(%constant bytevector-data-disp)))))))))]) - - (let () - (define-syntax type-pred - (syntax-rules () - [(_ name? mask type) - (define-inline 2 name? - [(e) (%type-check mask type ,e)])])) - (define-syntax typed-object-pred - (syntax-rules () - [(_ name? mask type) - (define-inline 2 name? - [(e) - (bind #t (e) - (%typed-object-check mask type ,e))])])) - (type-pred boolean? mask-boolean type-boolean) - (type-pred bwp-object? mask-bwp sbwp) - (type-pred char? mask-char type-char) - (type-pred eof-object? mask-eof seof) - (type-pred fixnum? mask-fixnum type-fixnum) - (type-pred flonum? mask-flonum type-flonum) - (type-pred null? mask-nil snil) - (type-pred pair? mask-pair type-pair) - (type-pred procedure? mask-closure type-closure) - (type-pred symbol? mask-symbol type-symbol) - (type-pred $unbound-object? mask-unbound sunbound) - (typed-object-pred bignum? mask-bignum type-bignum) - (typed-object-pred box? mask-box type-box) - (typed-object-pred mutable-box? mask-mutable-box type-mutable-box) - (typed-object-pred immutable-box? mask-mutable-box type-immutable-box) - (typed-object-pred bytevector? mask-bytevector type-bytevector) - (typed-object-pred mutable-bytevector? mask-mutable-bytevector type-mutable-bytevector) - (typed-object-pred immutable-bytevector? mask-mutable-bytevector type-immutable-bytevector) - (typed-object-pred $code? mask-code type-code) - (typed-object-pred $exactnum? mask-exactnum type-exactnum) - (typed-object-pred fxvector? mask-fxvector type-fxvector) - (typed-object-pred flvector? mask-flvector type-flvector) - (typed-object-pred $inexactnum? mask-inexactnum type-inexactnum) - (typed-object-pred $rtd-counts? mask-rtd-counts type-rtd-counts) - (typed-object-pred phantom-bytevector? mask-phantom type-phantom) - (typed-object-pred input-port? mask-input-port type-input-port) - (typed-object-pred output-port? mask-output-port type-output-port) - (typed-object-pred port? mask-port type-port) - (typed-object-pred ratnum? mask-ratnum type-ratnum) - (typed-object-pred $record? mask-record type-record) - (typed-object-pred string? mask-string type-string) - (typed-object-pred mutable-string? mask-mutable-string type-mutable-string) - (typed-object-pred immutable-string? mask-mutable-string type-immutable-string) - (typed-object-pred $system-code? mask-system-code type-system-code) - (typed-object-pred $tlc? mask-tlc type-tlc) - (typed-object-pred vector? mask-vector type-vector) - (typed-object-pred mutable-vector? mask-mutable-vector type-mutable-vector) - (typed-object-pred immutable-vector? mask-mutable-vector type-immutable-vector) - (typed-object-pred stencil-vector? mask-stencil-vector type-stencil-vector) - (typed-object-pred thread? mask-thread type-thread)) - (define-inline 3 $bigpositive? - [(e) (%type-check mask-signed-bignum type-positive-bignum - ,(%mref ,e ,(constant bignum-type-disp)))]) - (define-inline 3 csv7:record-field-accessible? - [(e1 e2) (%seq ,e1 ,e2 ,(%constant strue))]) - - (define-inline 2 cflonum? - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,(%constant strue) - ,(%typed-object-check mask-inexactnum type-inexactnum ,e)))]) - (define-inline 2 $immediate? - [(e) (bind #t (e) (%type-check mask-immediate type-immediate ,e))]) - (define-inline 3 $fixmediate - [(e) e]) - - (define-inline 3 $inexactnum-real-part - [(e) (build-$inexactnum-real-part e)]) - (define-inline 3 $inexactnum-imag-part - [(e) (build-$inexactnum-imag-part e)]) - - (define-inline 3 cfl-real-part - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,e - ,(build-$inexactnum-real-part e)))]) - - (define-inline 3 cfl-imag-part - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - (quote 0.0) - ,(build-$inexactnum-imag-part e)))]) - - (define-inline 3 $closure-ref - [(e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant closure-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant closure-data-disp))])]) - (define-inline 3 $closure-set! - [(e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant closure-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant closure-data-disp) e-new)])]) - (define-inline 3 $closure-code - [(e) (%inline - - ,(%mref ,e ,(constant closure-code-disp)) - ,(%constant code-data-disp))]) - (define-inline 3 $code-free-count - [(e) (build-fix (%mref ,e ,(constant code-closure-length-disp)))]) - (define-inline 3 $code-mutable-closure? - [(e) (%typed-object-check mask-code-mutable-closure type-code-mutable-closure ,e)]) - (define-inline 3 $code-arity-in-closure? - [(e) (%typed-object-check mask-code-arity-in-closure type-code-arity-in-closure ,e)]) - (define-inline 3 $code-single-valued? - [(e) (%typed-object-check mask-code-single-valued type-code-single-valued ,e)]) - (define-inline 2 $unbound-object - [() `(quote ,($unbound-object))]) - (define-inline 2 void - [() `(quote ,(void))]) - (define-inline 2 eof-object - [() `(quote #!eof)]) - (define-inline 2 cons - [(e1 e2) - (bind #f (e1 e2) - (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) - (%seq - (set! ,(%mref ,t ,(constant pair-car-disp)) ,e1) - (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e2) - ,t)))]) - (define-inline 2 box - [(e) - (bind #f (e) - (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) - (%seq - (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-box)) - (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) - ,t)))]) - (define-inline 2 box-immutable - [(e) - (bind #f (e) - (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) - (%seq - (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-immutable-box)) - (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) - ,t)))]) - (define-inline 3 $make-tlc - [(e-ht e-keyval e-next) - (bind #f (e-ht e-keyval e-next) - (bind #t ([t (%constant-alloc type-typed-object (constant size-tlc))]) - (%seq - (set! ,(%mref ,t ,(constant tlc-type-disp)) ,(%constant type-tlc)) - (set! ,(%mref ,t ,(constant tlc-ht-disp)) ,e-ht) - (set! ,(%mref ,t ,(constant tlc-keyval-disp)) ,e-keyval) - (set! ,(%mref ,t ,(constant tlc-next-disp)) ,e-next) - ,t)))]) - (define-inline 2 list - [e* (build-list e*)]) - (let () - (define (go e e*) - (bind #f (e) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) - (let loop ([e e] [e* e*] [i 0]) - (let ([e2 (car e*)] [e* (cdr e*)]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) - ,(if (null? e*) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,e2) - ,t) - (let ([next-i (fx+ i (constant size-pair))]) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) - ,(%inline + ,t (immediate ,next-i))) - ,(loop e2 e* next-i))))))))))) - (define-inline 2 list* - [(e) (ensure-single-valued e)] - [(e . e*) (go e e*)]) - (define-inline 2 cons* - [(e) (ensure-single-valued e)] - [(e . e*) (go e e*)])) - (define-inline 2 vector - [() `(quote #())] - [e* - (let ([n (length e*)]) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-vector) (fx* n (constant ptr-bytes))))]) - (let loop ([e* e*] [i 0]) - (if (null? e*) - `(seq - (set! ,(%mref ,t ,(constant vector-type-disp)) - (immediate ,(+ (fx* n (constant vector-length-factor)) - (constant type-vector)))) - ,t) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant vector-data-disp))) ,(car e*)) - ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))]) - (let () - (define (go e*) - (let ([n (length e*)]) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-fxvector) (fx* n (constant ptr-bytes))))]) - (let loop ([e* e*] [i 0]) - (if (null? e*) - `(seq - (set! ,(%mref ,t ,(constant fxvector-type-disp)) - (immediate ,(+ (fx* n (constant fxvector-length-factor)) - (constant type-fxvector)))) - ,t) - `(seq - (set! ,(%mref ,t ,(fx+ i (constant fxvector-data-disp))) ,(car e*)) - ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))) - (define-inline 2 fxvector - [() `(quote #vfx())] - [e* (and (andmap (lambda (x) (constant? target-fixnum? x)) e*) (go e*))]) - (define-inline 3 fxvector - [() `(quote #vfx())] - [e* (go e*)])) - (let () - (define (go e*) - (let ([n (length e*)]) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-flvector) (fx* n (constant flonum-bytes))))]) - (let loop ([e* e*] [i 0]) - (if (null? e*) - `(seq - (set! ,(%mref ,t ,(constant flvector-type-disp)) - (immediate ,(+ (fx* n (constant flvector-length-factor)) - (constant type-flvector)))) - ,t) - `(seq - (set! ,(%mref ,t ,%zero ,(fx+ i (constant flvector-data-disp)) fp) ,(car e*)) - ,(loop (cdr e*) (fx+ i (constant flonum-bytes)))))))))) - (define-inline 2 flvector - [() `(quote #vfl())] - [e* (and (andmap (lambda (x) (constant? flonum? x)) e*) (go e*))]) - (define-inline 3 flvector - [() `(quote #vfl())] - [e* (go e*)])) - (let () - (define (go e*) - (let ([n (length e*)]) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-string) (fx* n (constant string-char-bytes))))]) - (let loop ([e* e*] [i 0]) - (if (null? e*) - `(seq - (set! ,(%mref ,t ,(constant string-type-disp)) - (immediate ,(+ (fx* n (constant string-length-factor)) - (constant type-string)))) - ,t) - `(seq - (inline ,(make-info-load (string-char-type) #f) ,%store ,t ,%zero - (immediate ,(fx+ i (constant string-data-disp))) - ,(car e*)) - ,(loop (cdr e*) (fx+ i (constant string-char-bytes)))))))))) - (define-inline 2 string - [() `(quote "")] - [e* (and (andmap (lambda (x) (constant? char? x)) e*) (go e*))]) - (define-inline 3 string - [() `(quote "")] - [e* (go e*)])) - (let () ; level 2 car, cdr, caar, etc. - (define-syntax def-c..r* - (lambda (x) - (define (go ad*) - (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) - #`(define-inline 2 #,id - [(e) (let ([Lerr (make-local-label 'Lerr)]) - #,(let f ([ad* ad*]) - (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] - [ad* (cdr ad*)]) - (if (null? ad*) - #`(bind #t (e) - `(if ,(build-pair? e) - ,(#,builder e) - (label ,Lerr ,(build-libcall #t src sexpr #,id e)))) - #`(bind #t ([t #,(f ad*)]) - `(if ,(build-pair? t) - ,(#,builder t) - (goto ,Lerr)))))))]))) - (let f ([n 4] [ad* '()]) - (let ([f (lambda (ad*) - (let ([defn (go ad*)]) - (if (fx= n 1) - defn - #`(begin #,defn #,(f (fx- n 1) ad*)))))]) - #`(begin - #,(f (cons #\a ad*)) - #,(f (cons #\d ad*))))))) - def-c..r*) - (let () ; level 3 car, cdr, caar, etc. - (define-syntax def-c..r* - (lambda (x) - (define (go ad*) - (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) - #`(define-inline 3 #,id - [(e) #,(let f ([ad* ad*]) - (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] - [ad* (cdr ad*)]) - (if (null? ad*) - #`(#,builder e) - #`(#,builder #,(f ad*)))))]))) - (let f ([n 4] [ad* '()]) - (let ([f (lambda (ad*) - (let ([defn (go ad*)]) - (if (fx= n 1) - defn - #`(begin #,defn #,(f (fx- n 1) ad*)))))]) - #`(begin - #,(f (cons #\a ad*)) - #,(f (cons #\d ad*))))))) - def-c..r*) - (let () ; level 3 simple accessors, e.g., unbox, vector-length - (define-syntax inline-accessor - (syntax-rules () - [(_ prim disp) - (define-inline 3 prim - [(e) (%mref ,e ,(constant disp))])])) - (inline-accessor unbox box-ref-disp) - (inline-accessor $symbol-name symbol-name-disp) - (inline-accessor $symbol-property-list symbol-plist-disp) - (inline-accessor $system-property-list symbol-splist-disp) - (inline-accessor $symbol-hash symbol-hash-disp) - (inline-accessor $ratio-numerator ratnum-numerator-disp) - (inline-accessor $ratio-denominator ratnum-denominator-disp) - (inline-accessor $exactnum-real-part exactnum-real-disp) - (inline-accessor $exactnum-imag-part exactnum-imag-disp) - (inline-accessor binary-port-input-buffer port-ibuffer-disp) - (inline-accessor textual-port-input-buffer port-ibuffer-disp) - (inline-accessor binary-port-output-buffer port-obuffer-disp) - (inline-accessor textual-port-output-buffer port-obuffer-disp) - (inline-accessor $code-name code-name-disp) - (inline-accessor $code-arity-mask code-arity-mask-disp) - (inline-accessor $code-info code-info-disp) - (inline-accessor $code-pinfo* code-pinfo*-disp) - (inline-accessor $continuation-link continuation-link-disp) - (inline-accessor $continuation-winders continuation-winders-disp) - (inline-accessor $continuation-attachments continuation-attachments-disp) - (inline-accessor csv7:record-type-descriptor record-type-disp) - (inline-accessor $record-type-descriptor record-type-disp) - (inline-accessor record-rtd record-type-disp) - (inline-accessor record-type-uid record-type-uid-disp) - (inline-accessor $port-handler port-handler-disp) - (inline-accessor $port-info port-info-disp) - (inline-accessor port-name port-name-disp) - (inline-accessor $thread-tc thread-tc-disp) - ) - (constant-case architecture - [(pb) - ;; Don't try to inline seginfo access, because the C pointer size used - ;; in the table may not match the 64-bit `ptr` size - (void)] - [else - (let () - (define (build-seginfo maybe? e) - (let ([ptr (make-assigned-tmp 'ptr)] - [seginfo (make-assigned-tmp 'seginfo)]) - (define (build-level-3 seginfo k) - (constant-case segment-table-levels - [(3) - (let ([s3 (make-assigned-tmp 's3)]) - `(let ([,s3 ,(%mref ,seginfo - ,(%inline sll ,(%inline srl ,ptr (immediate ,(+ (constant segment-t1-bits) - (constant segment-t2-bits)))) - (immediate ,(constant log2-ptr-bytes))) - ,0)]) - ,(if maybe? - `(if ,(%inline eq? ,s3 (immediate 0)) - (immediate 0) - ,(k s3)) - (k s3))))] - [else (k seginfo)])) - (define (build-level-2 s3 k) - (constant-case segment-table-levels - [(2 3) - (let ([s2 (make-assigned-tmp 's2)]) - `(let ([,s2 ,(%mref ,s3 ,(%inline logand - ,(%inline srl ,ptr (immediate ,(fx- (constant segment-t1-bits) - (constant log2-ptr-bytes)))) - (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1) - (constant log2-ptr-bytes)))) - 0)]) - ,(if maybe? - `(if ,(%inline eq? ,s2 (immediate 0)) - (immediate 0) - ,(k s2)) - (k s2))))] - [else (k s3)])) - `(let ([,ptr ,(%inline srl ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) - (immediate ,(constant segment-offset-bits)))]) - (let ([,seginfo (literal ,(make-info-literal #f 'entry (lookup-c-entry segment-info) 0))]) - ,(build-level-3 seginfo - (lambda (s3) - (build-level-2 s3 - (lambda (s2) - (%mref ,s2 ,(%inline sll ,(%inline logand ,ptr - (immediate ,(fx- (fxsll 1 (constant segment-t1-bits)) 1))) - (immediate ,(constant log2-ptr-bytes))) - 0))))))))) - (define (build-space-test e space) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - (if ,(%type-check mask-immediate type-immediate ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #T e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,(let ([s `(inline ,(make-info-load 'unsigned-8 #f) ,%load ,si ,%zero (immediate 0))]) - (%inline eq? (immediate ,space) ,s)))))))) - - (define-inline 2 $maybe-seginfo - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - (if ,(%type-check mask-immediate type-immediate ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #t e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,si))))))]) - (define-inline 2 $seginfo - [(e) - (bind #t (e) (build-seginfo #f e))]) - (define-inline 2 $seginfo-generation - [(e) - (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))]) - (define-inline 2 $seginfo-space - [(e) - (bind #f (e) - (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-space-disp)))]) - (define-inline 2 $list-bits-ref - [(e) - (bind #t (e) - (let ([si (make-assigned-tmp 'si)] - [list-bits (make-assigned-tmp 'list-bits)] - [offset (make-assigned-tmp 'offset)] - [byte (make-assigned-tmp 'byte)]) - `(let ([,si ,(build-seginfo #f e)]) - (let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))]) - (if ,(%inline eq? ,list-bits (immediate 0)) - (immediate 0) - (let ([,offset ,(%inline srl ,(%inline logand ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) - (immediate ,(fx- (constant bytes-per-segment) 1))) - (immediate ,(constant log2-ptr-bytes)))]) - (let ([,byte (inline ,(make-info-load 'unsigned-8 #f) ,%load ,list-bits ,%zero ,(%inline srl ,offset (immediate 3)))]) - ,(build-fix (%inline logand ,(%inline srl ,byte ,(%inline logand ,offset (immediate 7))) - (immediate ,(constant list-bits-mask)))))))))))]) - (define-inline 2 $generation - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #t e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,(build-object-ref #f 'unsigned-8 si %zero 1))))))]) - (define-inline 2 weak-pair? - [(e) (bind #t (e) (build-space-test e (constant space-weakpair)))]) - (define-inline 2 ephemeron-pair? - [(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))]))]) - - (define-inline 2 unbox - [(e) - (bind #t (e) - `(if ,(%typed-object-check mask-box type-box ,e) - ,(%mref ,e ,(constant box-ref-disp)) - ,(build-libcall #t src sexpr unbox e)))]) - (let () - (define-syntax def-len - (syntax-rules () - [(_ prim type-disp length-offset) - (define-inline 3 prim - [(e) (extract-length (%mref ,e ,(constant type-disp)) (constant length-offset))])])) - (def-len vector-length vector-type-disp vector-length-offset) - (def-len fxvector-length fxvector-type-disp fxvector-length-offset) - (def-len flvector-length flvector-type-disp flvector-length-offset) - (def-len string-length string-type-disp string-length-offset) - (def-len bytevector-length bytevector-type-disp bytevector-length-offset) - (def-len $bignum-length bignum-type-disp bignum-length-offset) - (def-len stencil-vector-mask stencil-vector-type-disp stencil-vector-mask-offset)) - (let () - (define-syntax def-len - (syntax-rules () - [(_ prim mask type type-disp length-offset) - (define-inline 2 prim - [(e) (let ([Lerr (make-local-label 'Lerr)]) - (bind #t (e) - `(if ,(%type-check mask-typed-object type-typed-object ,e) - ,(bind #t ([t/l (%mref ,e ,(constant type-disp))]) - `(if ,(%type-check mask type ,t/l) - ,(extract-length t/l (constant length-offset)) - (goto ,Lerr))) - (label ,Lerr ,(build-libcall #t #f sexpr prim e)))))])])) - (def-len vector-length mask-vector type-vector vector-type-disp vector-length-offset) - (def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset) - (def-len flvector-length mask-flvector type-flvector flvector-type-disp flvector-length-offset) - (def-len string-length mask-string type-string string-type-disp string-length-offset) - (def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset) - (def-len stencil-vector-mask mask-stencil-vector type-stencil-vector stencil-vector-type-disp stencil-vector-mask-offset)) - ; TODO: consider adding integer-valued?, rational?, rational-valued?, - ; real?, and real-valued? - (define-inline 2 integer? - [(e) (bind #t (e) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-simple-or - (%typed-object-check mask-bignum type-bignum ,e) - (build-and - (%type-check mask-flonum type-flonum ,e) - `(call ,(make-info-call src sexpr #f #f #f) #f ,(lookup-primref 3 'flinteger?) ,e)))))]) - (let () - (define build-number? - (lambda (e) - (bind #t (e) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-simple-or - (%type-check mask-flonum type-flonum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (%type-check mask-other-number type-other-number - ,(%mref ,e ,(constant bignum-type-disp))))))))) - (define-inline 2 number? - [(e) (build-number? e)]) - (define-inline 2 complex? - [(e) (build-number? e)])) - (define-inline 3 set-car! - [(e1 e2) (build-dirty-store e1 (constant pair-car-disp) e2)]) - (define-inline 3 set-cdr! - [(e1 e2) (build-dirty-store e1 (constant pair-cdr-disp) e2)]) - (define-inline 3 set-box! - [(e1 e2) (build-dirty-store e1 (constant box-ref-disp) e2)]) - (define-inline 3 box-cas! - [(e1 e2 e3) - (bind #t (e2) - (build-dirty-store e1 %zero (constant box-ref-disp) e3 (make-build-cas e2) build-cas-seq))]) - (define-inline 3 $set-symbol-name! - [(e1 e2) (build-dirty-store e1 (constant symbol-name-disp) e2)]) - (define-inline 3 $set-symbol-property-list! - [(e1 e2) (build-dirty-store e1 (constant symbol-plist-disp) e2)]) - (define-inline 3 $set-system-property-list! - [(e1 e2) (build-dirty-store e1 (constant symbol-splist-disp) e2)]) - (define-inline 3 $set-port-info! - [(e1 e2) (build-dirty-store e1 (constant port-info-disp) e2)]) - (define-inline 3 set-port-name! - [(e1 e2) (build-dirty-store e1 (constant port-name-disp) e2)]) - (define-inline 2 set-box! - [(e-box e-new) - (bind #t (e-box) - (dirty-store-bind #t (e-new) - `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) - ,(build-dirty-store e-box (constant box-ref-disp) e-new) - ,(build-libcall #t src sexpr set-box! e-box e-new))))]) - (define-inline 2 box-cas! - [(e-box e-old e-new) - (bind #t (e-box e-old) - (dirty-store-bind #t (e-new) - `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) - ,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq) - ,(build-libcall #t src sexpr box-cas! e-box e-old e-new))))]) - (define-inline 2 set-car! - [(e-pair e-new) - (bind #t (e-pair) - (dirty-store-bind #t (e-new) - `(if ,(%type-check mask-pair type-pair ,e-pair) - ,(build-dirty-store e-pair (constant pair-car-disp) e-new) - ,(build-libcall #t src sexpr set-car! e-pair e-new))))]) - (define-inline 2 set-cdr! - [(e-pair e-new) - (bind #t (e-pair) - (dirty-store-bind #t (e-new) - `(if ,(%type-check mask-pair type-pair ,e-pair) - ,(build-dirty-store e-pair (constant pair-cdr-disp) e-new) - ,(build-libcall #t src sexpr set-cdr! e-pair e-new))))]) - (define-inline 3 $set-symbol-hash! - ; no need for dirty store---e2 should be a fixnum - [(e1 e2) `(set! ,(%mref ,e1 ,(constant symbol-hash-disp)) ,e2)]) - (define-inline 2 memory-order-acquire - [() (if-feature pthreads - (constant-case architecture - [(arm32 arm64) (%seq ,(%inline acquire-fence) (quote ,(void)))] - [else `(quote ,(void))]) - `(quote ,(void)))]) - (define-inline 2 memory-order-release - [() (if-feature pthreads - (constant-case architecture - [(arm32 arm64) (%seq ,(%inline release-fence) (quote ,(void)))] - [else `(quote ,(void))]) - `(quote ,(void)))]) - (let () - (define-syntax define-tlc-parameter - (syntax-rules () - [(_ name disp) - (define-inline 3 name - [(e-x) (%mref ,e-x ,(constant disp))])] - [(_ name name! disp) - (begin - (define-tlc-parameter name disp) - (define-inline 3 name! - [(e-x e-new) (build-dirty-store e-x (constant disp) e-new)]))])) - (define-tlc-parameter $tlc-keyval tlc-keyval-disp) - (define-tlc-parameter $tlc-ht tlc-ht-disp) - (define-tlc-parameter $tlc-next $set-tlc-next! tlc-next-disp)) - (define-inline 2 $top-level-value - [(e) (nanopass-case (L7 Expr) e - [(quote ,d) - (guard (symbol? d)) - (if (any-set? (prim-mask (or primitive system)) ($sgetprop d '*flags* 0)) - (Symref d) - (bind #t (e) - (bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) - `(if ,(%type-check mask-unbound sunbound ,t) - ,(build-libcall #t #f sexpr $top-level-value e) - ,t))))] - [else - (bind #t (e) - (let ([Lfail (make-local-label 'tlv-fail)]) - `(if ,(%type-check mask-symbol type-symbol ,e) - ,(bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) - `(if ,(%type-check mask-unbound sunbound ,t) - (goto ,Lfail) - ,t)) - (label ,Lfail ,(build-libcall #t #f sexpr $top-level-value e)))))])]) - (define-inline 3 $top-level-value - [(e) (nanopass-case (L7 Expr) e - [(quote ,d) (guard (symbol? d)) (Symref d)] - [else (%mref ,e ,(constant symbol-value-disp))])]) - (let () - (define (go e-sym e-value) - (bind #t (e-sym) - `(seq - ,(build-dirty-store e-sym (constant symbol-value-disp) e-value) - (set! ,(%mref ,e-sym ,(constant symbol-pvalue-disp)) - (literal - ,(make-info-literal #f 'library - (lookup-libspec nonprocedure-code) - (constant code-data-disp))))))) - (define-inline 3 $set-top-level-value! - [(e-sym e-value) (go e-sym e-value)]) - (define-inline 2 $set-top-level-value! - [(e-sym e-value) (and (constant? symbol? e-sym) (go e-sym e-value))])) - (define-inline 3 $top-level-bound? - [(e-sym) - (build-not - (%type-check mask-unbound sunbound - ,(nanopass-case (L7 Expr) e-sym - [(quote ,d) (guard (symbol? d)) (Symref d)] - [else (%mref ,e-sym ,(constant symbol-value-disp))])))]) - (let () - (define parse-format - (lambda (who src cntl-arg args) - (nanopass-case (L7 Expr) cntl-arg - [(quote ,d) - (guard (c [(and (assertion-violation? c) - (format-condition? c) - (message-condition? c) - (irritants-condition? c)) - ($source-warning 'compile - src #t - "~? in call to ~s" - (condition-message c) - (condition-irritants c) - who) - #f]) - (#%$parse-format-string who d (length args)))] - [else #f]))) - (define fmt->expr - ($make-fmt->expr - (lambda (d) `(quote ,d)) - (lambda (e1 e2) `(seq ,e1 ,e2)) - (lambda (src sexpr prim arg*) - `(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 prim) - ,arg* ...)))) - (define build-format - (lambda (who src sexpr op-arg cntl-arg arg*) - (let ([x (parse-format who src cntl-arg arg*)]) - (and x - (cond - [(and (fx= (length x) 1) - (string? (car x)) - (nanopass-case (L7 Expr) op-arg - [(quote ,d) (eq? d #f)] - [else #f])) - (%primcall src sexpr string-copy (quote ,(car x)))] - [(and (nanopass-case (L7 Expr) op-arg - [(quote ,d) (not (eq? d #f))] - [else #t]) - (let-values ([(op-arg dobind) (binder #t 'ptr op-arg)] - [(arg* dobind*) (list-binder #t 'ptr arg*)]) - (let ([e (fmt->expr src sexpr x op-arg arg*)]) - (and e (dobind (dobind* e))))))] - [else - (%primcall src sexpr $dofmt (quote ,who) ,op-arg ,cntl-arg - (quote ,x) - ,(build-list arg*))]))))) - (define-inline 2 errorf - [(e-who e-str . e*) - (parse-format 'errorf src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'errorf) ,e-who ,e-str ,e* ...))]) - (define-inline 2 assertion-violationf - [(e-who e-str . e*) - (parse-format 'assertion-violationf src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'assertion-violationf) ,e-who ,e-str ,e* ...))]) - (define-inline 2 $oops - [(e-who e-str . e*) - (parse-format '$oops src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$oops) ,e-who ,e-str ,e* ...))]) - (define-inline 2 $impoops - [(e-who e-str . e*) - (parse-format '$impoops src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$impoops) ,e-who ,e-str ,e* ...))]) - (define-inline 2 warningf - [(e-who e-str . e*) - (parse-format 'warningf src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref 'warningf) ,e-who ,e-str ,e* ...))]) - (define-inline 2 $source-violation - [(e-who e-src e-start? e-str . e*) - (parse-format '$source-violation src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$source-violation) - ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) - (define-inline 2 $source-warning - [(e-who e-src e-start? e-str . e*) - (parse-format '$source-warning src e-str e*) - `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref '$source-warning) - ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) - (define-inline 2 fprintf - [(e-op e-str . e*) - (parse-format 'fprintf src e-str e*) - #f]) - (define-inline 3 fprintf - [(e-op e-str . e*) (build-format 'fprintf src sexpr e-op e-str e*)]) - (define-inline 2 printf - [(e-str . e*) - (build-format 'printf src sexpr (%tc-ref current-output) e-str e*)]) - (define-inline 2 format - [(e . e*) - (nanopass-case (L7 Expr) e - [(quote ,d) - (if (string? d) - (build-format 'format src sexpr `(quote #f) e e*) - (and (not (null? e*)) - (cond - [(eq? d #f) (build-format 'format src sexpr e (car e*) (cdr e*))] - [(eq? d #t) (build-format 'format src sexpr - (%tc-ref current-output) - (car e*) (cdr e*))] - [else #f])))] - [else #f])])) - (let () - (define hand-coded-closure? - (lambda (name) - (not (memq name '(nuate nonprocedure-code error-invoke invoke - $wrapper-apply wrapper-apply arity-wrapper-apply - popcount-slow cpu-features))))) - (define-inline 2 $hand-coded - [(name) - (nanopass-case (L7 Expr) name - [(quote ,d) - (guard (symbol? d)) - (let ([l (make-local-label 'hcl)]) - (set! new-l* (cons l new-l*)) - (set! new-le* (cons (with-output-language (L9 CaseLambdaExpr) `(hand-coded ,d)) new-le*)) - (if (hand-coded-closure? d) - `(literal ,(make-info-literal #f 'closure l 0)) - `(label-ref ,l 0)))] - [(seq (profile ,src) ,[e]) `(seq (profile ,src) ,e)] - [else ($oops '$hand-coded "~s is not a quoted symbol" name)])])) - (define-inline 2 $tc - [() %tc]) - (define-inline 3 $tc-field - [(e-fld e-tc) - (nanopass-case (L7 Expr) e-fld - [(quote ,d) - (let () - (define-syntax a - (lambda (x) - #`(case d - #,@(fold-left - (lambda (ls field) - (apply - (lambda (name type disp len) - (if (eq? type 'ptr) - (cons - (with-syntax ([name (datum->syntax #'* name)]) - #'[(name) (%tc-ref ,e-tc name)]) - ls) - ls)) - field)) - '() (getprop 'tc '*fields* '())) - [else #f]))) - a)] - [else #f])] - [(e-fld e-tc e-val) - (nanopass-case (L7 Expr) e-fld - [(quote ,d) - (let () - (define-syntax a - (lambda (x) - #`(case d - #,@(fold-left - (lambda (ls field) - (apply - (lambda (name type disp len) - (if (eq? type 'ptr) - (cons - (with-syntax ([name (datum->syntax #'* name)]) - #'[(name) `(set! ,(%tc-ref ,e-tc name) ,e-val)]) - ls) - ls)) - field)) - '() (getprop 'tc '*fields* '())) - [else #f]))) - a)] - [else #f])]) - (let () - (define-syntax define-tc-parameter - (syntax-rules () - [(_ name tc-name) - (begin - (define-inline 2 name - [() (%tc-ref tc-name)] - [(x) #f]) - (define-inline 3 name - [() (%tc-ref tc-name)] - [(x) `(set! ,(%tc-ref tc-name) ,x)]))])) - - (define-tc-parameter current-input-port current-input) - (define-tc-parameter current-output-port current-output) - (define-tc-parameter current-error-port current-error) - (define-tc-parameter generate-inspector-information generate-inspector-information) - (define-tc-parameter generate-procedure-source-information generate-procedure-source-information) - (define-tc-parameter generate-profile-forms generate-profile-forms) - (define-tc-parameter $compile-profile compile-profile) - (define-tc-parameter optimize-level optimize-level) - (define-tc-parameter subset-mode subset-mode) - (define-tc-parameter $suppress-primitive-inlining suppress-primitive-inlining) - (define-tc-parameter $block-counter block-counter) - (define-tc-parameter $sfd sfd) - (define-tc-parameter $current-mso current-mso) - (define-tc-parameter $target-machine target-machine) - (define-tc-parameter $current-stack-link stack-link) - (define-tc-parameter $current-winders winders) - (define-tc-parameter $current-attachments attachments) - (define-tc-parameter default-record-equal-procedure default-record-equal-procedure) - (define-tc-parameter default-record-hash-procedure default-record-hash-procedure) - ) - - (let () - (define (make-wrapper-closure-alloc e-proc e-arity-mask e-data libspec) - (bind #t ([c (%constant-alloc type-closure (fx* (if e-data 4 3) (constant ptr-bytes)))]) - (%seq - (set! ,(%mref ,c ,(constant closure-code-disp)) - (literal ,(make-info-literal #f 'library libspec (constant code-data-disp)))) - (set! ,(%mref ,c ,(constant closure-data-disp)) ,e-proc) - (set! ,(%mref ,c ,(fx+ (constant ptr-bytes) (constant closure-data-disp))) ,e-arity-mask) - ,(if e-data - (%seq - (set! ,(%mref ,c ,(fx+ (fx* (constant ptr-bytes) 2) (constant closure-data-disp))) ,e-data) - ,c) - c)))) - (define-inline 3 $make-wrapper-procedure - [(e-proc e-arity-mask) - (bind #f (e-proc e-arity-mask) - (make-wrapper-closure-alloc e-proc e-arity-mask #f (lookup-libspec $wrapper-apply)))]) - (define-inline 3 make-wrapper-procedure - [(e-proc e-arity-mask e-data) - (bind #f (e-proc e-arity-mask e-data) - (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec wrapper-apply)))]) - (define-inline 3 make-arity-wrapper-procedure - [(e-proc e-arity-mask e-data) - (bind #f (e-proc e-arity-mask e-data) - (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec arity-wrapper-apply)))])) - - (define-inline 3 $install-guardian - [(e-obj e-rep e-tconc ordered?) - (bind #f (e-obj e-rep e-tconc ordered?) - (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) - (%seq - (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) - (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) ,e-rep) - (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) - (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) - (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,ordered?) - (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) - (set! ,(%tc-ref guardian-entries) ,t))))]) - - (define-inline 3 $install-ftype-guardian - [(e-obj e-tconc) - (bind #f (e-obj e-tconc) - (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) - (%seq - (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) - (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) (immediate ,(constant ftype-guardian-rep))) - (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) - (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) - (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,(%constant sfalse)) - (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) - (set! ,(%tc-ref guardian-entries) ,t))))]) - - (define-inline 2 guardian? - [(e) - (bind #t (e) - (build-and - (%type-check mask-closure type-closure ,e) - (%type-check mask-guardian-code type-guardian-code - ,(%mref - ,(%inline - - ,(%mref ,e ,(constant closure-code-disp)) - ,(%constant code-data-disp)) - ,(constant code-type-disp)))))]) - - (define-inline 3 $make-phantom-bytevector - [() - (bind #f () - (bind #t ([t (%constant-alloc type-typed-object (constant size-phantom))]) - (%seq - (set! ,(%mref ,t ,(constant phantom-type-disp)) - ,(%constant type-phantom)) - (set! ,(%mref ,t ,(constant phantom-length-disp)) - (immediate 0)) - ,t)))]) - - (define-inline 3 phantom-bytevector-length - [(e-ph) - (bind #f (e-ph) - (unsigned->ptr (%mref ,e-ph ,(constant phantom-length-disp)) - (constant ptr-bits)))]) - - (define-inline 2 virtual-register-count - [() `(quote ,(constant virtual-register-count))]) - (let () - (define constant-ref - (lambda (e-idx) - (nanopass-case (L7 Expr) e-idx - [(quote ,d) - (guard (and (fixnum? d) ($fxu< d (constant virtual-register-count)))) - (%mref ,%tc ,(fx+ (constant tc-virtual-registers-disp) (fx* d (constant ptr-bytes))))] - [else #f]))) - (define constant-set - (lambda (e-idx e-val) - (let ([ref (constant-ref e-idx)]) - (and ref `(set! ,ref ,e-val))))) - (define index-check - (lambda (e-idx libcall e) - `(if (if ,(%type-check mask-fixnum type-fixnum ,e-idx) - ,(%inline u< ,e-idx (immediate ,(fix (constant virtual-register-count)))) - ,(%constant sfalse)) - ,e - ,libcall))) - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (define-inline 3 virtual-register - [(e-idx) - (or (constant-ref e-idx) - (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))]) - (define-inline 2 virtual-register - [(e-idx) - (or (constant-ref e-idx) - (bind #t (e-idx) - (index-check e-idx - (build-libcall #t src sexpr virtual-register e-idx) - (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))))]) - (define-inline 3 set-virtual-register! - [(e-idx e-val) - (or (constant-set e-idx e-val) - `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val))]) - (define-inline 2 set-virtual-register! - [(e-idx e-val) - (or (constant-set e-idx e-val) - (bind #t (e-idx) - (bind #f (e-val) - (index-check e-idx - (build-libcall #t src sexpr set-virtual-register! e-idx) - `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val)))))])) - - (define-inline 2 $thread-list - [() `(literal ,(make-info-literal #t 'entry (lookup-c-entry thread-list) 0))]) - (when-feature pthreads - (define-inline 2 $raw-tc-mutex - [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-tc-mutex) 0))]) - (define-inline 2 $raw-terminated-cond - [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-terminated-cond) 0))]) - (define-inline 2 $raw-collect-cond - [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-cond) 0))]) - (define-inline 2 $raw-collect-thread0-cond - [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-thread0-cond) 0))])) - (define-inline 2 not - [(e) `(if ,e ,(%constant sfalse) ,(%constant strue))]) - (define-inline 2 most-negative-fixnum - [() `(quote ,(constant most-negative-fixnum))]) - (define-inline 2 most-positive-fixnum - [() `(quote ,(constant most-positive-fixnum))]) - (define-inline 2 least-fixnum - [() `(quote ,(constant most-negative-fixnum))]) - (define-inline 2 greatest-fixnum - [() `(quote ,(constant most-positive-fixnum))]) - (define-inline 2 fixnum-width - [() `(quote ,(constant fixnum-bits))]) - (constant-case native-endianness - [(unknown) (void)] - [else - (define-inline 2 native-endianness - [() `(quote ,(constant native-endianness))])]) - (define-inline 2 directory-separator - [() `(quote ,(if-feature windows #\\ #\/))]) - (let () ; level 2 char=?, r6rs:char=?, etc. - (define-syntax char-pred - (syntax-rules () - [(_ op r6rs:op inline-op) - (let () - (define (go2 src sexpr e1 e2) - (bind #t (e1 e2) - `(if ,(build-chars? e1 e2) - ,(%inline inline-op ,e1 ,e2) - ,(build-libcall #t src sexpr op e1 e2)))) - (define (go3 src sexpr e1 e2 e3) - (and (constant? char? e1) - (constant? char? e3) - (bind #t (e2) - `(if ,(%type-check mask-char type-char ,e2) - ,(build-and - (%inline inline-op ,e1 ,e2) - (%inline inline-op ,e2 ,e3)) - ; could also pass e2 and e3: - ,(build-libcall #t src sexpr op e1 e2))))) - (define-inline 2 op - [(e1 e2) (go2 src sexpr e1 e2)] - [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] - [(e1 . e*) #f]) - (define-inline 2 r6rs:op - [(e1 e2) (go2 src sexpr e1 e2)] - [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] - [(e1 e2 . e*) #f]))])) - (char-pred char=? r6rs:char>=? >=) - (char-pred char>? r6rs:char>? >)) - (let () ; level 3 char=?, r6rs:char=?, etc. - (define-syntax char-pred - (syntax-rules () - [(_ op r6rs:op inline-op) - (let () - (define (go2 e1 e2) - (%inline inline-op ,e1 ,e2)) - (define (go3 e1 e2 e3) - (bind #t (e2) - (bind #f (e3) - (build-and - (go2 e1 e2) - (go2 e2 e3))))) - (define-inline 3 op - [(e) `(seq ,e ,(%constant strue))] - [(e1 e2) (go2 e1 e2)] - [(e1 e2 e3) (go3 e1 e2 e3)] - [(e1 . e*) #f]) - (define-inline 3 r6rs:op - [(e1 e2) (go2 e1 e2)] - [(e1 e2 e3) (go3 e1 e2 e3)] - [(e1 e2 . e*) #f]))])) - (char-pred char=? r6rs:char>=? >=) - (char-pred char>? r6rs:char>? >)) - (define-inline 3 map - [(e-proc e-ls) - (or (nanopass-case (L7 Expr) e-proc - [,pr - (and (all-set? (prim-mask unsafe) (primref-flags pr)) - (let ([name (primref-name pr)]) - (or (and (eq? name 'car) (build-libcall #f src sexpr map-car e-ls)) - (and (eq? name 'cdr) (build-libcall #f src sexpr map-cdr e-ls)))))] - [else #f]) - (build-libcall #f src sexpr map1 e-proc e-ls))] - [(e-proc e-ls1 e-ls2) - (or (nanopass-case (L7 Expr) e-proc - [,pr - (and (eq? (primref-name pr) 'cons) - (build-libcall #f src sexpr map-cons e-ls1 e-ls2))] - [else #f]) - (build-libcall #f src sexpr map2 e-proc e-ls1 e-ls2))] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 andmap - [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 for-all - [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 ormap - [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 exists - [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 fold-left - [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-left1 e-proc e-base e-ls)] - [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-left2 e-proc e-base e-ls1 e-ls2)] - [(e-proc e-base e-ls . e-ls*) #f]) - (define-inline 3 fold-right - [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-right1 e-proc e-base e-ls)] - [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-right2 e-proc e-base e-ls1 e-ls2)] - [(e-proc e-base e-ls . e-ls*) #f]) - (define-inline 3 for-each - [(e-proc e-ls) (build-libcall #f src sexpr for-each1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr for-each2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 vector-map - [(e-proc e-ls) (build-libcall #f src sexpr vector-map1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-map2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 vector-for-each - [(e-proc e-ls) (build-libcall #f src sexpr vector-for-each1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-for-each2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 string-for-each - [(e-proc e-ls) (build-libcall #f src sexpr string-for-each1 e-proc e-ls)] - [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr string-for-each2 e-proc e-ls1 e-ls2)] - [(e-proc e-ls . e-ls*) #f]) - (define-inline 3 reverse - [(e) (build-libcall #f src sexpr reverse e)]) - (let () - (define inline-getprop - (lambda (plist-offset e-sym e-key e-dflt) - (let ([t-ls (make-assigned-tmp 't-ls)] [t-cdr (make-tmp 't-cdr)] [Ltop (make-local-label 'Ltop)]) - (bind #t (e-key e-dflt) - ; indirect symbol after evaluating e-key and e-dflt - `(let ([,t-ls ,(%mref ,e-sym ,plist-offset)]) - (label ,Ltop - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,e-dflt - (let ([,t-cdr ,(%mref ,t-ls ,(constant pair-cdr-disp))]) - (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) - ,(%mref ,t-cdr ,(constant pair-car-disp)) - (seq - (set! ,t-ls ,(%mref ,t-cdr ,(constant pair-cdr-disp))) - (goto ,Ltop))))))))))) - (define-inline 3 getprop - [(e-sym e-key) (inline-getprop (constant symbol-plist-disp) e-sym e-key (%constant sfalse))] - [(e-sym e-key e-dflt) (inline-getprop (constant symbol-plist-disp) e-sym e-key e-dflt)]) - (define-inline 3 $sgetprop - [(e-sym e-key e-dflt) (inline-getprop (constant symbol-splist-disp) e-sym e-key e-dflt)])) - (define-inline 3 assq - [(e-key e-ls) - (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) - (bind #t (e-key) - `(let ([,t-ls ,e-ls]) - (label ,Ltop - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,(%constant sfalse) - ,(bind #t ([t-a (%mref ,t-ls ,(constant pair-car-disp))]) - `(if ,(%inline eq? ,(%mref ,t-a ,(constant pair-car-disp)) ,e-key) - ,t-a - (seq - (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) - (goto ,Ltop)))))))))]) - (define-inline 3 length - [(e-ls) - (let ([t-ls (make-assigned-tmp 't-ls)] - [t-n (make-assigned-tmp 't-n)] - [Ltop (make-local-label 'Ltop)]) - (bind #t (e-ls) - `(if ,(%inline eq? ,e-ls ,(%constant snil)) - (immediate ,(fix 0)) - (let ([,t-ls ,e-ls] [,t-n (immediate ,(fix 0))]) - (label ,Ltop - ,(%seq - (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) - (set! ,t-n ,(%inline + ,t-n (immediate ,(fix 1)))) - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,t-n - (goto ,Ltop))))))))]) - (define-inline 3 append - ; TODO: hand-coded library routine that allocates the new pairs in a block - [() (%constant snil)] - [(e-ls) e-ls] - [(e-ls1 e-ls2) (build-libcall #f src sexpr append e-ls1 e-ls2)] - [(e-ls1 e-ls2 e-ls3) - (build-libcall #f src sexpr append e-ls1 - (build-libcall #f #f sexpr append e-ls2 e-ls3))] - [(e-ls . e-ls*) #f]) - (define-inline 3 apply - [(e0 e1) (build-libcall #f src sexpr apply0 e0 e1)] - [(e0 e1 e2) (build-libcall #f src sexpr apply1 e0 e1 e2)] - [(e0 e1 e2 e3) (build-libcall #f src sexpr apply2 e0 e1 e2 e3)] - [(e0 e1 e2 e3 e4) (build-libcall #f src sexpr apply3 e0 e1 e2 e3 e4)] - [(e0 e1 . e*) #f]) - (define-inline 2 fxsll - [(e0 e1) (build-libcall #f src sexpr fxsll e0 e1)]) - (define-inline 2 fxarithmetic-shift-left - [(e0 e1) (build-libcall #f src sexpr fxarithmetic-shift-left e0 e1)]) - (define-inline 2 fxsll/wraparound - [(e1 e2) - (bind #t (e1 e2) - `(if ,(nanopass-case (L7 Expr) e2 - [(quote ,d) - (guard (target-fixnum? d) - ($fxu< d (fx+ 1 (constant fixnum-bits)))) - (build-fixnums? (list e1 e2))] - [else - (build-and (build-fixnums? (list e1 e2)) - (%inline u< ,e2 (immediate ,(fix (fx+ 1 (constant fixnum-bits))))))]) - ,(%inline sll ,e1 ,(build-unfix e2)) - ,(build-libcall #t src sexpr fxsll/wraparound e1 e2)))]) - (define-inline 3 display-string - [(e-s) (build-libcall #f src sexpr display-string e-s (%tc-ref current-output))] - [(e-s e-op) (build-libcall #f src sexpr display-string e-s e-op)]) - (define-inline 3 call-with-current-continuation - [(e) (build-libcall #f src sexpr callcc e)]) - (define-inline 3 call/cc - [(e) (build-libcall #f src sexpr callcc e)]) - (define-inline 3 call/1cc - [(e) (build-libcall #f src sexpr call1cc e)]) - (define-inline 2 $event - [() (build-libcall #f src sexpr event)]) - (define-inline 3 eq-hashtable-ref - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-ref e1 e2 e3)]) - (define-inline 3 eq-hashtable-ref-cell - [(e1 e2) (build-libcall #f src sexpr eq-hashtable-ref-cell e1 e2)]) - (define-inline 3 eq-hashtable-contains? - [(e1 e2) (build-libcall #f src sexpr eq-hashtable-contains? e1 e2)]) - (define-inline 3 eq-hashtable-set! - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-set! e1 e2 e3)]) - (define-inline 3 eq-hashtable-update! - [(e1 e2 e3 e4) (build-libcall #f src sexpr eq-hashtable-update! e1 e2 e3 e4)]) - (define-inline 3 eq-hashtable-cell - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-cell e1 e2 e3)]) - (define-inline 3 eq-hashtable-try-atomic-cell - [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-try-atomic-cell e1 e2 e3)]) - (define-inline 3 eq-hashtable-delete! - [(e1 e2) (build-libcall #f src sexpr eq-hashtable-delete! e1 e2)]) - (define-inline 3 symbol-hashtable-ref - [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-ref e1 e2 e3)]) - (define-inline 3 symbol-hashtable-ref-cell - [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-ref-cell e1 e2)]) - (define-inline 3 symbol-hashtable-contains? - [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-contains? e1 e2)]) - (define-inline 3 symbol-hashtable-set! - [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-set! e1 e2 e3)]) - (define-inline 3 symbol-hashtable-update! - [(e1 e2 e3 e4) (build-libcall #f src sexpr symbol-hashtable-update! e1 e2 e3 e4)]) - (define-inline 3 symbol-hashtable-cell - [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-cell e1 e2 e3)]) - (define-inline 3 symbol-hashtable-delete! - [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-delete! e1 e2)]) - (define-inline 2 bytevector-s8-set! - [(e1 e2 e3) (build-libcall #f src sexpr bytevector-s8-set! e1 e2 e3)]) - (define-inline 2 bytevector-u8-set! - [(e1 e2 e3) (build-libcall #f src sexpr bytevector-u8-set! e1 e2 e3)]) - (define-inline 3 bytevector=? - [(e1 e2) (build-libcall #f src sexpr bytevector=? e1 e2)]) - (let () - (define eqvop-flonum - (lambda (e1 e2) - (nanopass-case (L7 Expr) e1 - [(quote ,d) (and (flonum? d) - (bind #t (e2) - (build-and - (%type-check mask-flonum type-flonum ,e2) - (if ($nan? d) - ;; NaN: invert `fl=` on self - (bind #t (e2) - (build-not (build-fl= e2 e2))) - ;; Non-NaN: compare bits - (constant-case ptr-bits - [(32) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (let ([d0 (if (eq? (constant native-endianness) (native-endianness)) 0 4)]) - (let ([word1 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) d0))] - [word2 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) (fx- 4 d0)))]) - (build-and - (%inline eq? - ,(%mref ,e2 ,(constant flonum-data-disp)) - (immediate ,word1)) - (%inline eq? - ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4)) - (immediate ,word2)))))] - [(64) - (let ([word ($object-ref 'integer-64 d (constant flonum-data-disp))]) - (%inline eq? - ,(%mref ,e2 ,(constant flonum-data-disp)) - (immediate ,word)))] - [else ($oops 'compiler-internal - "eqv doesn't handle ptr-bits = ~s" - (constant ptr-bits))])))))] - [else #f]))) - (define eqok-help? - (lambda (obj) - (or (symbol? obj) - (char? obj) - (target-fixnum? obj) - (null? obj) - (boolean? obj) - (eqv? obj "") - (eqv? obj '#()) - (eqv? obj '#vu8()) - (eqv? obj '#0=#0#) - (eq? obj (void)) - (eof-object? obj) - (bwp-object? obj) - ($unbound-object? obj) - (eqv? obj '#vfx())))) - (define eqvok-help? number?) - (define eqvnever-help? (lambda (obj) (not (number? obj)))) - (define e*ok? - (lambda (e*ok-help?) - (lambda (e) - (nanopass-case (L7 Expr) e - [(quote ,d) (e*ok-help? d)] - [else #f])))) - (define eqok? (e*ok? eqok-help?)) - (define eqvok? (e*ok? eqvok-help?)) - (define eqvnever? (e*ok? eqvnever-help?)) - (define-inline 2 eqv? - [(e1 e2) (or (eqvop-null-fptr e1 e2) - (relop-length RELOP= e1 e2) - (eqvop-flonum e1 e2) - (eqvop-flonum e2 e1) - (if (or (eqok? e1) (eqok? e2) - (eqvnever? e1) (eqvnever? e2)) - (build-eq? e1 e2) - (build-eqv? src sexpr e1 e2)))]) - (let () - (define xform-equal? - (lambda (src sexpr e1 e2) - (nanopass-case (L7 Expr) e1 - [(quote ,d1) - (let xform ([d1 d1] [e2 e2] [n 3] [k (lambda (e n) e)]) - (if (eqok-help? d1) - (k (build-eq? `(quote ,d1) e2) n) - (if (eqvok-help? d1) - (k (build-eqv? src sexpr `(quote ,d1) e2) n) - (and (fx> n 0) - (pair? d1) - (let-values ([(e2 dobind) (binder #t 'ptr e2)]) - (xform (car d1) (build-car e2) (fx- n 1) - (lambda (a n) - (xform (cdr d1) (build-cdr e2) n - (lambda (d n) - (k (dobind - (build-and - (build-pair? e2) - (build-and a d))) - n))))))))))] - [else #f]))) - (define-inline 2 equal? - [(e1 e2) (or (eqvop-null-fptr e1 e2) - (relop-length RELOP= e1 e2) - (xform-equal? src sexpr e1 e2) - (xform-equal? src sexpr e2 e1))])) - (let () - (define mem*ok? - (lambda (e*ok-help?) - (lambda (x) - (nanopass-case (L7 Expr) x - [(quote ,d) - (and (list? d) - (let f ([d d]) - (or (null? d) - (and (e*ok-help? (car d)) - (f (cdr d))))))] - [else #f])))) - (define memqok? (mem*ok? eqok-help?)) - (define memvok? (mem*ok? eqvok-help?)) - (define mem*->e*?s - (lambda (build-e*? limit) - (lambda (e-key e-ls) - (nanopass-case (L7 Expr) e-ls - [(quote ,d) - (and (let f ([d d] [n 0]) - (or (null? d) - (and (pair? d) - (fx< n limit) - (f (cdr d) (fx1+ n))))) - (bind #t (e-key) - (let f ([ls d]) - (if (null? ls) - `(quote #f) - `(if ,(build-e*? e-key `(quote ,(car ls))) - (quote ,ls) - ,(f (cdr ls)))))))] - [else #f])))) - (define memq->eq?s (mem*->e*?s build-eq? 8)) - (define (memv->eqv?s src sexpr) (mem*->e*?s (make-build-eqv? src sexpr) 4)) - (define do-memq - (lambda (src sexpr e-key e-ls) - (or (memq->eq?s e-key e-ls) - (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) - (bind #t (e-key) - `(let ([,t-ls ,e-ls]) - (label ,Ltop - (if ,(%inline eq? ,t-ls ,(%constant snil)) - ,(%constant sfalse) - (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) - ,t-ls - (seq - (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) - (goto ,Ltop))))))))))) - (define do-memv - (lambda (src sexpr e-key e-ls) - (or ((memv->eqv?s src sexpr) e-key e-ls) - (build-libcall #f src sexpr memv e-key e-ls)))) - (define-inline 3 memq - [(e-key e-ls) (do-memq src sexpr e-key e-ls)]) - (define-inline 3 memv - [(e-key e-ls) - (if (or (eqok? e-key) (memqok? e-ls)) - (do-memq src sexpr e-key e-ls) - (do-memv src sexpr e-key e-ls))]) - (define-inline 3 member - [(e-key e-ls) - (if (or (eqok? e-key) (memqok? e-ls)) - (do-memq src sexpr e-key e-ls) - (and (or (eqvok? e-key) (memvok? e-ls)) - (do-memv src sexpr e-key e-ls)))]) - (define-inline 2 memq - [(e-key e-ls) (memq->eq?s e-key e-ls)]) - (define-inline 2 memv - [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) - ((memv->eqv?s src sexpr) e-key e-ls))]) - (define-inline 2 member - [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) - (and (memvok? e-ls) ((memv->eqv?s src sexpr) e-key e-ls)))]))) - ; NB: for all of the I/O routines, consider putting optimize-level 2 code out-of-line - ; w/o going all the way to the port handler, i.e., always defer to library routine but - ; have library routine do the checks and run the optimize-level 3 version...this could - ; save a lot of code - ; NB: verify that the inline checks don't always fail, i.e., don't always send us to the - ; library routine - (let () - (define (go src sexpr e-p check? update? do-libcall) - (let ([Llib (and check? (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if Llib - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-binary-input-port type-binary-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-update - (lambda (t0 e-icount body) - (if update? - `(seq - (set! ,e-icount ,(%inline + ,t0 (immediate 1))) - ,body) - body))) - (bind #t (e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-p)) - ,(maybe-add-update t0 e-icount - ; TODO: this doesn't completely fall away when used in effect context - (build-fix - `(inline ,(make-info-load 'unsigned-8 #f) ,%load - ,t0 - ,(%mref ,e-p ,(constant port-ilast-disp)) - (immediate 0))))))))))) - (define (unsafe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-u8 e-p)) - (define (safe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-u8 e-p)) - (define (unsafe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-u8 e-p)) - (define (safe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-u8 e-p)) - (define-inline 3 lookahead-u8 - [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-u8-libcall)]) - (define-inline 2 lookahead-u8 - [(e-p) (go src sexpr e-p #t #f safe-lookahead-u8-libcall)]) - (define-inline 3 get-u8 - [(e-p) (go src sexpr e-p #f #t unsafe-get-u8-libcall)]) - (define-inline 2 get-u8 - [(e-p) (go src sexpr e-p #t #t safe-get-u8-libcall)])) - (let () - (define (go src sexpr e-p check? update? do-libcall) - (let ([Llib (and check? (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if Llib - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-textual-input-port type-textual-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-update - (lambda (t0 e-icount body) - (if update? - `(seq - (set! ,e-icount ,(%inline + ,t0 ,(%constant string-char-bytes))) - ,body) - body))) - (bind #t (e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-p)) - ,(maybe-add-update t0 e-icount - ; TODO: this doesn't completely fall away when used in effect context - `(inline ,(make-info-load (string-char-type) #f) ,%load - ,t0 - ,(%mref ,e-p ,(constant port-ilast-disp)) - (immediate 0)))))))))) - (define (unsafe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-char e-p)) - (define (safe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-char e-p)) - (define (unsafe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-peek-char e-p)) - (define (safe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-peek-char e-p)) - (define (unsafe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-char e-p)) - (define (safe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-char e-p)) - (define (unsafe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-read-char e-p)) - (define (safe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-read-char e-p)) - (define-inline 3 lookahead-char - [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-char-libcall)]) - (define-inline 2 lookahead-char - [(e-p) (go src sexpr e-p #t #f safe-lookahead-char-libcall)]) - (define-inline 3 peek-char - [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] - [(e-p) (go src sexpr e-p #f #f unsafe-peek-char-libcall)]) - (define-inline 2 peek-char - [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] - [(e-p) (go src sexpr e-p #t #f safe-peek-char-libcall)]) - (define-inline 3 get-char - [(e-p) (go src sexpr e-p #f #t unsafe-get-char-libcall)]) - (define-inline 2 get-char - [(e-p) (go src sexpr e-p #t #t safe-get-char-libcall)]) - (define-inline 3 read-char - [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] - [(e-p) (go src sexpr e-p #f #t unsafe-read-char-libcall)]) - (define-inline 2 read-char - [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] - [(e-p) (go src sexpr e-p #t #t safe-read-char-libcall)])) - (let () - (define (go src sexpr e-p e-c check-port? check-char? do-libcall) - (let ([const-char? (constant? char? e-c)]) - (let ([Llib (and (or check-char? check-port? (not const-char?)) (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-textual-input-port type-textual-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-eof-check - (lambda (e-c body) - (if const-char? - body - `(if ,(%inline eq? ,e-c ,(%constant seof)) - (goto ,Llib) - ,body)))) - (define maybe-add-char-check - (lambda (e-c body) - (if check-char? - `(if ,(%type-check mask-char type-char ,e-c) - ,body - (goto ,Llib)) - body))) - (bind #t (e-c e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (maybe-add-eof-check e-c - (maybe-add-char-check e-c - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 - ,(%inline - - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - ,(%constant string-data-disp)) - ,(%mref ,e-p ,(constant port-ilast-disp)))) - ,(maybe-add-label Llib (do-libcall src sexpr e-p e-c)) - (set! ,e-icount ,(%inline - ,t0 ,(%constant string-char-bytes))))))))))))) - (define (unsafe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unget-char e-p e-c)) - (define (safe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unget-char e-p e-c)) - (define (unsafe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unread-char e-c e-p)) - (define (safe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unread-char e-c e-p)) - (define-inline 3 unget-char - [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-unget-char-libcall)]) - (define-inline 2 unget-char - [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unget-char-libcall)]) - (define-inline 3 unread-char - [(e-c) (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall)] - [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-unread-char-libcall)]) - (define-inline 2 unread-char - [(e-c) (if (constant? char? e-c) - (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall) - (go src sexpr (%tc-ref current-input) e-c #f #t safe-unread-char-libcall))] - [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unread-char-libcall)])) - (let () - (define octet? - (lambda (x) - (and (fixnum? x) (fx<= 0 x 255)))) - (define maybe-add-octet-check - (lambda (check-octet? Llib e-o body) - (if check-octet? - `(if ,(%type-check mask-octet type-octet ,e-o) - ,body - (goto ,Llib)) - body))) - (let () - (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) - (let ([const-octet? (constant? octet? e-o)]) - (let ([Llib (and (or check-octet? check-port? (not const-octet?)) (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-binary-input-port type-binary-input-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define maybe-add-eof-check - (lambda (e-o body) - (if const-octet? - body - `(if ,(%inline eq? ,e-o ,(%constant seof)) - (goto ,Llib) - ,body)))) - (bind #t (e-o e-p) - (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) - (maybe-add-port-check e-p - (maybe-add-eof-check e-o - (maybe-add-octet-check check-octet? Llib e-o - (bind #t ([t0 e-icount]) - `(if ,(%inline eq? ,t0 - ,(%inline - - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - ,(%constant bytevector-data-disp)) - ,(%mref ,e-p ,(constant port-ilast-disp)))) - ,(maybe-add-label Llib (do-libcall src sexpr e-p e-o)) - (set! ,e-icount ,(%inline - ,t0 (immediate 1))))))))))))) - (define (unsafe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr unsafe-unget-u8 e-p e-o)) - (define (safe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr safe-unget-u8 e-p e-o)) - (define-inline 3 unget-u8 - [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-unget-u8-libcall)]) - (define-inline 2 unget-u8 - [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-unget-u8-libcall)])) - (let () - (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) - (let ([Llib (and (or check-octet? check-port?) (make-local-label 'Llib))]) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-binary-output-port type-binary-output-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define add-update - (lambda (t0 e-ocount body) - `(seq - (set! ,e-ocount ,(%inline + ,t0 (immediate 1))) - ,body))) - (bind check-octet? (e-o) - (bind #t (e-p) - (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) - (maybe-add-octet-check check-octet? Llib e-o - (maybe-add-port-check e-p - (bind #t ([t0 e-ocount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-o e-p)) - ,(add-update t0 e-ocount - `(inline ,(make-info-load 'unsigned-8 #f) ,%store - ,t0 - ,(%mref ,e-p ,(constant port-olast-disp)) - (immediate 0) - ,(build-unfix e-o)))))))))))) - (define (unsafe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr unsafe-put-u8 e-p e-o)) - (define (safe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr safe-put-u8 e-p e-o)) - (define-inline 3 put-u8 - [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-put-u8-libcall)]) - (define-inline 2 put-u8 - [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-put-u8-libcall)]))) - (let () - (define (go src sexpr e-p e-c check-port? check-char? do-libcall) - (let ([Llib (and (or check-char? check-port?) (make-local-label 'Llib))]) - (define maybe-add-char-check - (lambda (e-c body) - (if check-char? - `(if ,(%type-check mask-char type-char ,e-c) - ,body - (goto ,Llib)) - body))) - (define maybe-add-port-check - (lambda (e-p body) - (if check-port? - `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(%type-check mask-textual-output-port type-textual-output-port - ,(%mref ,e-p ,(constant typed-object-type-disp))) - ,(%constant sfalse)) - ,body - (goto ,Llib)) - body))) - (define add-update - (lambda (t0 e-ocount body) - `(seq - (set! ,e-ocount ,(%inline + ,t0 ,(%constant string-char-bytes))) - ,body))) - (bind check-char? (e-c) - (bind #t (e-p) - (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) - (maybe-add-char-check e-c - (maybe-add-port-check e-p - (bind #t ([t0 e-ocount]) - `(if ,(%inline eq? ,t0 (immediate 0)) - ,(maybe-add-label Llib (do-libcall src sexpr e-c e-p)) - ,(add-update t0 e-ocount - `(inline ,(make-info-load (string-char-type) #f) ,%store - ,t0 - ,(%mref ,e-p ,(constant port-olast-disp)) - (immediate 0) - ,e-c))))))))))) - (define (unsafe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-put-char e-p e-c)) - (define (safe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-put-char e-p e-c)) - (define (unsafe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-write-char e-c e-p)) - (define (safe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-write-char e-c e-p)) - (define (unsafe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-newline e-p)) - (define (safe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-newline e-p)) - (define-inline 3 put-char - [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-put-char-libcall)]) - (define-inline 2 put-char - [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-put-char-libcall)]) - (define-inline 3 write-char - [(e-c) (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall)] - [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-write-char-libcall)]) - (define-inline 2 write-char - [(e-c) (if (constant? char? e-c) - (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall) - (go src sexpr (%tc-ref current-output) e-c #f #t safe-write-char-libcall))] - [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-write-char-libcall)]) - (define-inline 3 newline - [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] - [(e-p) (go src sexpr e-p `(quote #\newline) #f #f unsafe-newline-libcall)]) - (define-inline 2 newline - [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] - [(e-p) (go src sexpr e-p `(quote #\newline) #t #f safe-newline-libcall)])) - (let () - (define build-fxop? - (lambda (op overflow-flag e1 e2 adjust k) - (let ([Lfail (make-local-label 'Lfail)]) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(bind #f ([t `(inline ,null-info ,op ,e1 ,(adjust e2))]) - `(if (inline ,(make-info-condition-code overflow-flag #f #t) ,%condition-code) - (label ,Lfail ,(k e1 e2)) - ,t)) - (goto ,Lfail)))))) - (define-inline 2 + - [() `(immediate ,(fix 0))] - [(e) (build-fxop? %+/ovfl 'overflow e `(quote 0) values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] - [(e1 e2) (build-fxop? %+/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] - ; TODO: handle 3-operand case ala fx+, w/3-operand library + - [(e1 . e*) #f]) - (define-inline 2 * - [() `(immediate ,(fix 1))] - [(e) (build-fxop? %*/ovfl 'multiply-overflow e `(quote 1) build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] - ; TODO: swap e1 & e2 if e1 is constant - [(e1 e2) (build-fxop? %*/ovfl 'multiply-overflow e1 e2 build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] - ; TODO: handle 3-operand case ala fx+, w/3-operand library * - [(e1 . e*) #f]) - (define-inline 2 - - [(e) (build-fxop? %-/ovfl 'overflow `(quote 0) e values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] - [(e1 e2) (build-fxop? %-/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] - ; TODO: handle 3-operand case ala fx+, w/3-operand library - - [(e1 e2 . e*) #f])) - (let () - (define build-fxop? - (lambda (op e k) - (let ([Lfail (make-local-label 'Lfail)]) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(bind #f ([t `(inline ,null-info ,op ,e (immediate ,(fix 1)))]) - `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) - (label ,Lfail ,(k e)) - ,t)) - (goto ,Lfail)))))) - - (define-syntax define-inline-1op - (syntax-rules () - [(_ op name) - (define-inline 2 name - [(e) (build-fxop? op e (lambda (e) (build-libcall #t src sexpr name e)))])])) - - (define-inline-1op %-/ovfl 1-) - (define-inline-1op %-/ovfl -1+) - (define-inline-1op %-/ovfl sub1) - (define-inline-1op %+/ovfl 1+) - (define-inline-1op %+/ovfl add1)) - - (define-inline 2 / - [(e) (build-libcall #f src sexpr / `(immediate ,(fix 1)) e)] - [(e1 e2) (build-libcall #f src sexpr / e1 e2)] - [(e1 . e*) #f]) - - (let () - (define (zgo src sexpr e e1 e2) - (build-simple-or - (%inline eq? ,e (immediate 0)) - `(if ,(build-fixnums? (list e)) - ,(%constant sfalse) - ,(build-libcall #t src sexpr = e1 e2)))) - (define (go src sexpr e1 e2) - (or (eqvop-null-fptr e1 e2) - (relop-length RELOP= e1 e2) - (cond - [(constant? (lambda (x) (eqv? x 0)) e1) - (bind #t (e2) (zgo src sexpr e2 e1 e2))] - [(constant? (lambda (x) (eqv? x 0)) e2) - (bind #t (e1) (zgo src sexpr e1 e1 e2))] - [else (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline eq? ,e1 ,e2) - ,(build-libcall #t src sexpr = e1 e2)))]))) - (define-inline 2 = - [(e1 e2) (go src sexpr e1 e2)] - [(e1 . e*) #f]) - (define-inline 2 r6rs:= - [(e1 e2) (go src sexpr e1 e2)] - [(e1 e2 . e*) #f])) - (let () - (define-syntax define-relop-inline - (syntax-rules () - [(_ name r6rs:name relop op) - (let () - (define builder - (lambda (e1 e2 libcall) - (or (relop-length relop e1 e2) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline op ,e1 ,e2) - ,(libcall e1 e2)))))) - (define-inline 2 name - [(e1 e2) - (builder e1 e2 - (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] - ; TODO: handle 3-operand case w/3-operand library routine - [(e1 . e*) #f]) - (define-inline 2 r6rs:name - [(e1 e2) - (builder e1 e2 - (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] - ; TODO: handle 3-operand case w/3-operand library routine - [(e1 e2 . e*) #f]))])) - (define-relop-inline < r6rs:< RELOP< <) - (define-relop-inline <= r6rs:<= RELOP<= <=) - (define-relop-inline >= r6rs:>= RELOP>= >=) - (define-relop-inline > r6rs:> RELOP> >)) - (define-inline 3 positive? ; 3 so opt-level 2 errors come from positive? - [(e) (handle-prim src sexpr 3 '> (list e `(quote 0)))]) - (define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from nonnegative? - [(e) (handle-prim src sexpr 3 '>= (list e `(quote 0)))]) - (define-inline 3 negative? ; 3 so opt-level 2 errors come from negative? - [(e) (handle-prim src sexpr 3 '< (list e `(quote 0)))]) - (define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from nonpositive? - [(e) (handle-prim src sexpr 3 '<= (list e `(quote 0)))]) - (define-inline 2 zero? - [(e) - (or (relop-length RELOP= e) - (nanopass-case (L7 Expr) e - [(call ,info ,mdcl ,pr ,e) - (guard - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (make-ftype-pointer-null? e)] - [else - (bind #t (e) - (build-simple-or - (%inline eq? ,e (immediate ,(fix 0))) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - ,(build-libcall #t src sexpr zero? e))))]))]) - (define-inline 2 positive? [(e) (relop-length RELOP> e)]) - (define-inline 2 nonnegative? [(e) (relop-length RELOP>= e)]) - (define-inline 2 negative? [(e) (relop-length RELOP< e)]) - (define-inline 2 nonpositive? [(e) (relop-length RELOP<= e)]) - (let () - (define-syntax define-logorop-inline - (syntax-rules () - [(_ name ...) - (let () - (define build-logop - (lambda (src sexpr e1 e2 libcall) - (bind #t (e1 e2) - (bind #t ([t (%inline logor ,e1 ,e2)]) - `(if ,(%type-check mask-fixnum type-fixnum ,t) - ,t - ,(libcall src sexpr e1 e2)))))) - (let () - (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) - (define-inline 2 name - [() `(immediate ,(fix 0))] - [(e) (build-logop src sexpr e `(immediate ,(fix 0)) libcall)] - [(e1 e2) (build-logop src sexpr e1 e2 libcall)] - [(e1 . e*) #f])) - ...)])) - (define-logorop-inline logor logior bitwise-ior)) - (let () - (define-syntax define-logop-inline - (syntax-rules () - [(_ op unit name ...) - (let () - (define build-logop - (lambda (src sexpr e1 e2 libcall) - (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline op ,e1 ,e2) - ,(libcall src sexpr e1 e2))))) - (let () - (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) - (define-inline 2 name - [() `(immediate ,(fix unit))] - [(e) (build-logop src sexpr e `(immediate ,(fix unit)) libcall)] - [(e1 e2) (build-logop src sexpr e1 e2 libcall)] - [(e1 . e*) #f])) - ...)])) - (define-logop-inline logand -1 logand bitwise-and) - (define-logop-inline logxor 0 logxor bitwise-xor)) - (let () - (define build-lognot - (lambda (e libcall) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%inline logxor ,e (immediate ,(fxlognot (constant mask-fixnum)))) - ,(libcall e))))) - - (define-inline 2 lognot - [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr lognot e)))]) - (define-inline 2 bitwise-not - [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr bitwise-not e)))])) - - (let () - (define build-logbit? - (lambda (e1 e2 libcall) - (or (nanopass-case (L7 Expr) e1 - [(quote ,d) - (or (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline logtest ,e2 (immediate ,(fix (ash 1 d)))) - ,(libcall e1 e2)))) - (and (and (target-fixnum? d) (> d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline < ,e2 (immediate ,(fix 0))) - ,(libcall e1 e2)))))] - [else #f]) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) - ,(%inline logtest - ,(%inline sra ,e2 ,(build-unfix e1)) - (immediate ,(fix 1))) - ,(libcall e1 e2)))))) - - (define-inline 2 logbit? - [(e1 e2) (build-logbit? e1 e2 (lambda (e1 e2) (build-libcall #t src sexpr logbit? e1 e2)))]) - (define-inline 2 bitwise-bit-set? - [(e1 e2) (build-logbit? e2 e1 (lambda (e2 e1) (build-libcall #t src sexpr bitwise-bit-set? e1 e2)))])) - - (define-inline 2 logbit1 - [(e1 e2) (or (nanopass-case (L7 Expr) e1 - [(quote ,d) - (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline logor ,e2 (immediate ,(fix (ash 1 d)))) - ,(build-libcall #t src sexpr logbit1 e1 e2))))] - [else #f]) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logor ,e2 - ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1))) - ,(build-libcall #t src sexpr logbit1 e1 e2))))]) - (define-inline 2 logbit0 - [(e1 e2) (or (nanopass-case (L7 Expr) e1 - [(quote ,d) - (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) - (bind #t (e2) - `(if ,(%type-check mask-fixnum type-fixnum ,e2) - ,(%inline logand ,e2 (immediate ,(fix (lognot (ash 1 d))))) - ,(build-libcall #t src sexpr logbit0 e1 e2))))] - [else #f]) - (bind #t (e1 e2) - `(if ,(build-and - (build-fixnums? (list e1 e2)) - (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) - ,(%inline logand ,e2 - ,(%inline lognot - ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1)))) - ,(build-libcall #t src sexpr logbit0 e1 e2))))]) - (define-inline 2 logtest - [(e1 e2) (bind #t (e1 e2) - `(if ,(build-fixnums? (list e1 e2)) - ,(%inline logtest ,e1 ,e2) - ,(build-libcall #t src sexpr logtest e1 e2)))]) - (define-inline 3 $flhash - [(e) (bind #t (e) - `(if ,(build-fl= e e) - ,(%inline logand - ,(%inline srl - ,(constant-case ptr-bits - [(32) (%inline + - ,(%mref ,e ,(constant flonum-data-disp)) - ,(%mref ,e ,(fx+ (constant flonum-data-disp) 4)))] - [(64) (%mref ,e ,(constant flonum-data-disp))]) - (immediate 1)) - (immediate ,(- (constant fixnum-factor)))) - ;; +nan.0 - (immediate ,(fix #xfa1e))))]) - (let () - (define build-flonum-extractor - (lambda (pos size e1) - (let ([cnt (- pos (constant fixnum-offset))] - [mask (* (- (expt 2 size) 1) (expt 2 (constant fixnum-offset)))]) - (%inline logand - ,(let ([body (constant-case native-endianness - [(unknown) - (constant-case ptr-bits - [(64) - (%inline srl ,(%mref ,e1 ,(constant flonum-data-disp)) (immediate 32))] - [(32) - (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)])] - [else - `(inline ,(make-info-load 'integer-32 #f) ,%load ,e1 ,%zero - (immediate ,(constant-case native-endianness - [(little) (fx+ (constant flonum-data-disp) 4)] - [(big) (constant flonum-data-disp)])))])]) - (let ([body (if (fx> cnt 0) - (%inline srl ,body (immediate ,cnt)) - body)]) - (if (fx< cnt 0) - (%inline sll ,body (immediate ,(fx- 0 cnt))) - body))) - (immediate ,mask))))) - - (define-inline 3 fllp - [(e) (build-flonum-extractor 19 12 e)]) - - (define-inline 3 $flonum-sign - [(e) (build-flonum-extractor 31 1 e)]) - - (define-inline 3 $flonum-exponent - [(e) (build-flonum-extractor 20 11 e)])) - - (define-inline 3 $fleqv? - [(e1 e2) - (bind #t (e1 e2) - `(if ,(build-fl= e1 e1) ; check e1 not +nan.0 - ,(constant-case ptr-bits - [(32) (build-and - (%inline eq? - ,(%mref ,e1 ,(constant flonum-data-disp)) - ,(%mref ,e2 ,(constant flonum-data-disp))) - (%inline eq? - ,(%mref ,e1 ,(fx+ (constant flonum-data-disp) 4)) - ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4))))] - [(64) (%inline eq? - ,(%mref ,e1 ,(constant flonum-data-disp)) - ,(%mref ,e2 ,(constant flonum-data-disp)))] - [else ($oops 'compiler-internal - "$fleqv doesn't handle ptr-bits = ~s" - (constant ptr-bits))]) - ;; If e1 is +nan.0, see if e2 is +nan.0: - ,(build-not (build-fl= e2 e2))))]) - - (let () - (define build-fp-op-1 - (lambda (op e) - (bind #f fp (e) - (if (procedure? op) (op e) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t)) ,op ,e)))))) - (define build-fp-op-2 - (lambda (op e1 e2) - (bind #f fp (e1 e2) - (if (procedure? op) (op e1 e2) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t #t)) ,op ,e1 ,e2)))))) - (define build-fl-adjust-sign - (lambda (e combine base) - `(unboxed-fp - ,(constant-case ptr-bits - [(64) - (let ([t (make-tmp 'flsgn)]) - `(let ([,t (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto ,e)]) - (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,t ,base))))] - [(32) - (let ([thi (make-tmp 'flsgnh)] - [tlo (make-tmp 'flsgnl)]) - (bind #t fp (e) - `(let ([,thi (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)] - [,tlo (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/lo ,e)]) - (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,thi ,base) ,tlo))))])))) - (define build-flabs - (lambda (e) - (build-fl-adjust-sign e %logand (%inline srl (immediate -1) (immediate 1))))) - (define build-flneg - (lambda (e) - (build-fl-adjust-sign e %logxor (%inline sll (immediate -1) (immediate ,(fx- (constant ptr-bits) 1)))))) - (define build-fl-call - (lambda (entry . e*) - `(foreign-call ,(with-output-language (Ltype Type) - (make-info-foreign '(atomic) (map (lambda (e) `(fp-double-float)) e*) `(fp-double-float) #t)) - (literal ,(make-info-literal #f 'entry entry 0)) - ,e* ...))) - - (define-inline 3 fl+ - [() `(quote 0.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-fp-op-2 %fp+ e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl+ e1 e*)]) - - (define-inline 3 fl* - [() `(quote 1.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-fp-op-2 %fp* e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl* e1 e*)]) - - (define-inline 3 fl- - [(e) (build-flneg e)] - [(e1 e2) (build-fp-op-2 %fp- e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl- e1 e*)]) - - (define-inline 3 fl/ - [(e) (build-fp-op-2 %fp/ `(quote 1.0) e)] - [(e1 e2) (build-fp-op-2 %fp/ e1 e2)] - [(e1 . e*) (reduce-fp src sexpr 3 'fl/ e1 e*)]) - - (define-inline 3 flsqrt - [(e) - (constant-case architecture - [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] - [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])]) - - (define-inline 3 flsingle - [(e) (build-fp-op-1 %fpsingle e)]) - - (define-inline 3 flabs - [(e) (build-flabs e)]) - - (let () - (define-syntax define-fl-call - (syntax-rules () - [(_ id extra ...) - (define-inline 3 id - [(e) (build-fl-call (lookup-c-entry id) e)] - extra ...)])) - (define-syntax define-fl2-call - (syntax-rules () - [(_ id id2) - (define-fl-call id - [(e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)])])) - (define-fl-call flround) ; no support in SSE2 for flround, though this was added in SSE4.1 - (define-fl-call flfloor) - (define-fl-call flceiling) - (define-fl-call fltruncate) - (define-fl-call flsin) - (define-fl-call flcos) - (define-fl-call fltan) - (define-fl-call flasin) - (define-fl-call flacos) - (define-fl2-call flatan flatan2) - (define-fl-call flexp) - (define-fl2-call fllog fllog2)) - - (define-inline 3 flexpt - [(e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)]) - - (let () - (define build-fl-make-rectangular - (lambda (e1 e2) - (bind #f (e1 e2) - (bind #t ([t (%constant-alloc type-typed-object (constant size-inexactnum))]) - (%seq - (set! ,(%mref ,t ,(constant inexactnum-type-disp)) - ,(%constant type-inexactnum)) - (set! ,(%mref ,t ,%zero ,(constant inexactnum-real-disp) fp) - ,(%mref ,e1 ,%zero ,(constant flonum-data-disp) fp)) - (set! ,(%mref ,t ,%zero ,(constant inexactnum-imag-disp) fp) - ,(%mref ,e2 ,%zero ,(constant flonum-data-disp) fp)) - ,t))))) - - (define-inline 3 fl-make-rectangular - [(e1 e2) (build-fl-make-rectangular e1 e2)]) - - (define-inline 3 cfl- - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,(build-flneg e) - ,(build-fl-make-rectangular - (build-flneg (build-$inexactnum-real-part e)) - (build-flneg (build-$inexactnum-imag-part e)))))] - [(e1 e2) (build-libcall #f src sexpr cfl- e1 e2)] - ; TODO: add 3 argument version of cfl- library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl- e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl+ - [() `(quote 0.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-libcall #f src sexpr cfl+ e1 e2)] - ; TODO: add 3 argument version of cfl+ library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl+ e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl* - [() `(quote 1.0)] - [(e) (ensure-single-valued e)] - [(e1 e2) (build-libcall #f src sexpr cfl* e1 e2)] - ; TODO: add 3 argument version of cfl* library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl* e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl/ - [(e) (build-libcall #f src sexpr cfl/ `(quote 1.0) e)] - [(e1 e2) (build-libcall #f src sexpr cfl/ e1 e2)] - ; TODO: add 3 argument version of cfl/ library function - #;[(e1 e2 e3) (build-libcall #f src sexpr cfl/ e1 e2 e3)] - [(e1 e2 . e*) #f]) - - (define-inline 3 cfl-conjugate - [(e) (bind #t (e) - `(if ,(%type-check mask-flonum type-flonum ,e) - ,e - ,(build-fl-make-rectangular - (build-$inexactnum-real-part e) - (build-flneg (build-$inexactnum-imag-part e)))))])) - - (define-inline 3 $make-exactnum - [(e1 e2) (bind #f (e1 e2) - (bind #t ([t (%constant-alloc type-typed-object (constant size-exactnum))]) - (%seq - (set! ,(%mref ,t ,(constant exactnum-type-disp)) - ,(%constant type-exactnum)) - (set! ,(%mref ,t ,(constant exactnum-real-disp)) ,e1) - (set! ,(%mref ,t ,(constant exactnum-imag-disp)) ,e2) - ,t)))]) - - (let () - (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) - (define build-fl= - (case-lambda - [(e) (if (constant nan-single-comparison-true?) - (%seq ,e (quote #t)) - (bind #t fp (e) (build-fl= e e)))] - [(e1 e2) (bind #f fp (e1 e2) - `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))])) - (define (build-fl<= e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp<= ,e1 ,e2)) - - (let () - (define-syntax define-fl-cmp-inline - (lambda (x) - (syntax-case x () - [(_ op r6rs:op builder inequality? swapped?) - (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] - [reducer (if (datum inequality?) - #'(reduce-fp-compare reduce-inequality) - #'(reduce-fp-compare reduce-equality))]) - #'(begin - (define-inline 3 op - [(e) (build-fl= e)] - [(e1 e2) (builder args ...)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) - (define-inline 3 r6rs:op - [(e1 e2) (builder args ...)] - [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)])))]))) - - (define-fl-cmp-inline fl= fl=? build-fl= #f #f) - (define-fl-cmp-inline fl< fl fl>? build-fl< #t #t) - (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) - (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) - (let () - (define-syntax build-bind-and-check - (syntax-rules () - [(_ src sexpr op e1 e2 body) - (if (known-flonum-result? e1) - (if (known-flonum-result? e2) - body - (bind #t (e2) - `(if ,(%type-check mask-flonum type-flonum ,e2) - ,body - ,(build-libcall #t src sexpr op e2 e2)))) - (if (known-flonum-result? e2) - (bind #t (e1) - `(if ,(%type-check mask-flonum type-flonum ,e1) - ,body - ,(build-libcall #t src sexpr op e1 e1))) - (bind #t (e1 e2) - `(if ,(build-and - (%type-check mask-flonum type-flonum ,e1) - (%type-check mask-flonum type-flonum ,e2)) - ,body - ,(build-libcall #t src sexpr op e1 e2)))))])) - (define build-check-fp-arguments - (lambda (e* build-libcall k) - (let loop ([e* e*] [check-e* '()] [all-e* '()]) - (cond - [(null? e*) - (let loop ([check-e* (reverse check-e*)]) - (cond - [(null? check-e*) (apply k (reverse all-e*))] - [(null? (cdr check-e*)) - (let ([e1 (car check-e*)]) - `(if ,(%type-check mask-flonum type-flonum ,e1) - ,(loop '()) - ,(build-libcall e1 e1)))] - [else - (let ([e1 (car check-e*)] - [e2 (cadr check-e*)]) - `(if ,(build-and - (%type-check mask-flonum type-flonum ,e1) - (%type-check mask-flonum type-flonum ,e2)) - ,(loop (cddr check-e*)) - ,(build-libcall e1 e2)))]))] - [else - (let ([e1 (car e*)]) - (if (known-flonum-result? e1) - (loop (cdr e*) check-e* (cons e1 all-e*)) - (bind #t (e1) - (loop (cdr e*) (cons e1 check-e*) (cons e1 all-e*)))))])))) - (define-syntax define-fl-cmp-inline - (lambda (x) - (syntax-case x () - [(_ op r6rs:op builder inequality? swapped?) - (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] - [reducer (if (datum inequality?) - #'(reduce-fp-compare reduce-inequality) - #'(reduce-fp-compare reduce-equality))]) - #'(begin - (define-inline 2 op - [(e1) (if (known-flonum-result? e1) - (build-fl= e1) - (bind #t (e1) - `(if ,(%type-check mask-flonum type-flonum ,e1) - ,(build-fl= e1) - ,(build-libcall #t src sexpr op e1 e1))))] - [(e1 e2) (build-bind-and-check src sexpr op e1 e2 (builder args ...))] - [(e1 e2 . e*) (and - (fx<= (length e*) (fx- inline-args-limit 2)) - (build-check-fp-arguments (cons* e1 e2 e*) - (lambda (e1 e2) (build-libcall #t src sexpr op e1 e2)) - (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))]) - (define-inline 2 r6rs:op - [(e1 e2) (build-bind-and-check src sexpr r6rs:op e1 e2 (builder args ...))] - [(e1 e2 . e*) (and - (fx<= (length e*) (fx- inline-args-limit 2)) - (build-check-fp-arguments (cons* e1 e2 e*) - (lambda (e1 e2) (build-libcall #t src sexpr r6rs:op e1 e2)) - (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))])))]))) - - (define-fl-cmp-inline fl= fl=? build-fl= #f #f) - (define-fl-cmp-inline fl< fl fl>? build-fl< #t #t) - (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) - (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) - (let () - (define build-cfl= - ; NB: e1 and e2 must be bound - (lambda (e1 e2) - `(if ,(%type-check mask-flonum type-flonum ,e1) - (if ,(%type-check mask-flonum type-flonum ,e2) - ,(build-fl= e1 e2) - ,(build-and - (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e2)) - (build-fl= e1 (build-$inexactnum-real-part e2)))) - (if ,(%type-check mask-flonum type-flonum ,e2) - ,(build-and - (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e1)) - (build-fl= e2 (build-$inexactnum-real-part e1))) - ,(build-and - (build-fl= - (build-$inexactnum-imag-part e1) - (build-$inexactnum-imag-part e2)) - (build-fl= - (build-$inexactnum-real-part e1) - (build-$inexactnum-real-part e2))))))) - (define-inline 3 cfl= - [(e) (if (constant nan-single-comparison-true?) - (%seq ,e (quote #t)) - (bind #f (e) (build-cfl= e e)))] - [(e1 e2) (bind #f (e1 e2) (build-cfl= e1 e2))] - ; TODO: should we avoid building for more then the 3 item case? - [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]))) - - (let () - (define build-checked-fp-op - (case-lambda - [(e k) - (if (known-flonum-result? e) - e - (bind #t (e) - `(if ,(build-flonums? (list e)) - ,e - ,(k e))))] - [(e1 op k) ; `op` can be a procedure that produces an unboxed value - (if (known-flonum-result? e1) - (build-fp-op-1 op e1) - (bind #t (e1) - (let ([e (build-fp-op-1 op e1)] - [k (lambda (e) - `(if ,(build-flonums? (list e1)) - ,e - ,(k e1)))]) - ((lift-fp-unboxed k) e))))] - [(e1 e2 op k) ; `op` can be a procedure that produces an unboxed value - ;; uses result of `e1` or `e2` twice for error if other is always a flonum - (let ([build (lambda (e1 e2) - (build-fp-op-2 op e1 e2))]) - (if (known-flonum-result? e1) - (if (known-flonum-result? e2) - (build e1 e2) - (bind #t (e2) - (build e1 `(if ,(build-flonums? (list e2)) - ,e2 - ,(k e2 e2))))) - (if (known-flonum-result? e2) - (bind #t (e1) - (build `(if ,(build-flonums? (list e1)) - ,e1 - ,(k e1 e1)) - e2)) - (bind #t (e1 e2) - (let ([e (build e1 e2)] - [k (lambda (e) - `(if ,(build-flonums? (list e1 e2)) - ,e - ,(k e1 e2)))]) - ((lift-fp-unboxed k) e))))))])) - - (define-inline 2 fl+ - [() `(quote 0.0)] - [(e) (build-checked-fp-op e - (lambda (e) - (build-libcall #t src sexpr fl+ e `(quote 0.0))))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp+ - (lambda (e1 e2) - (build-libcall #t src sexpr fl+ e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl+ e1 e*)]) - - (define-inline 2 fl* - [() `(quote 1.0)] - [(e) (build-checked-fp-op e - (lambda (e) - (build-libcall #t src sexpr fl* e `(quote 1.0))))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp* - (lambda (e1 e2) - (build-libcall #t src sexpr fl* e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl* e1 e*)]) - - (define-inline 2 fl- - [(e) (build-checked-fp-op e build-flneg - (lambda (e) - (build-libcall #t src sexpr flnegate e)))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp- - (lambda (e1 e2) - (build-libcall #t src sexpr fl- e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl- e1 e*)]) - - (define-inline 2 fl/ - [(e) (build-checked-fp-op `(quote 1.0) e %fp/ - (lambda (e1 e2) - (build-libcall #t src sexpr fl/ e1 e2)))] - [(e1 e2) (build-checked-fp-op e1 e2 %fp/ - (lambda (e1 e2) - (build-libcall #t src sexpr fl/ e1 e2)))] - [(e1 . e*) (reduce-fp src sexpr 2 'fl/ e1 e*)]) - - (define-inline 2 flabs - [(e) (build-checked-fp-op e build-flabs - (lambda (e) - (build-libcall #t src sexpr flabs e)))]) - - (define-inline 2 flsqrt - [(e) - (build-checked-fp-op e - (lambda (e) - (constant-case architecture - [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] - [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])) - (lambda (e) - (build-libcall #t src sexpr flsqrt e)))]) - - (define-inline 2 flsingle - [(e) - (build-checked-fp-op e - (lambda (e) (build-fp-op-1 %fpsingle e)) - (lambda (e) - (build-libcall #t src sexpr flsingle e)))]) - - (let () - (define-syntax define-fl-call - (syntax-rules () - [(_ id) - (define-inline 2 id - [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) - (lambda (e) - (build-libcall #t src sexpr id e)))])])) - (define-syntax define-fl2-call - (syntax-rules () - [(_ id id2) - (define-inline 2 id - [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) - (lambda (e) - (build-libcall #t src sexpr id e)))] - [(e1 e2) (build-checked-fp-op e1 e2 (lambda (e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)) - (lambda (e1 e2) - (build-libcall #t src sexpr id2 e1 e2)))])])) - (define-fl-call flround) - (define-fl-call flfloor) - (define-fl-call flceiling) - (define-fl-call fltruncate) - (define-fl-call flsin) - (define-fl-call flcos) - (define-fl-call fltan) - (define-fl-call flasin) - (define-fl-call flacos) - (define-fl2-call flatan flatan2) - (define-fl-call flexp) - (define-fl2-call fllog fllog2)) - - (define-inline 2 flexpt - [(e1 e2) (build-checked-fp-op e1 e2 - (lambda (e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)) - (lambda (e1 e2) - (build-libcall #t src sexpr flexpt e1 e2)))]) - - ;; NB: assuming that we have a trunc instruction for now, will need to change to support Sparc - (define-inline 3 flonum->fixnum - [(e-x) (bind #f fp (e-x) - (build-fix - `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)))]) - (define-inline 2 flonum->fixnum - [(e-x) (build-checked-fp-op e-x - (lambda (e-x) - (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) - (bind #t (e-x) - `(if ,(build-and - (build-fl< e-x `(quote ,(constant too-positive-flonum-for-fixnum))) - (build-fl< `(quote ,(constant too-negative-flonum-for-fixnum)) e-x)) - ,(build-fix - `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)) - ;; We have to box the flonum to report an error: - ,(let ([t (make-tmp 't)]) - `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) - (seq - (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e-x) - ,(build-libcall #t src sexpr flonum->fixnum t))))))) - (lambda (e-x) - (build-libcall #t src sexpr flonum->fixnum e-x)))]))) - - (let () - (define build-fixnum->flonum - ; NB: x must already be bound in order to ensure it is done before the flonum is allocated - (lambda (e-x k) - (k `(unboxed-fp ,(%inline fpt ,(build-unfix e-x)))))) - (define-inline 3 fixnum->flonum - [(e-x) (bind #f (e-x) (build-fixnum->flonum e-x values))]) - (define-inline 2 fixnum->flonum - [(e-x) (bind #t (e-x) - (build-fixnum->flonum e-x - (lift-fp-unboxed - (lambda (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e-x) - ,e - ,(build-libcall #t src sexpr fixnum->flonum e-x))))))]) - (define-inline 2 real->flonum - [(e-x) - (if (known-flonum-result? e-x) - e-x - (bind #t (e-x) - `(if ,(%type-check mask-fixnum type-fixnum ,e-x) - ,(build-fixnum->flonum e-x values) - (if ,(%type-check mask-flonum type-flonum ,e-x) - ,e-x - ,(build-libcall #t src sexpr real->flonum e-x `(quote real->flonum))))))])) - (define-inline 3 $real->flonum - [(x who) (build-$real->flonum src sexpr x who)]) - (define-inline 2 $record - [(tag . args) (build-$record tag args)]) - (define-inline 3 $object-address - [(e-ptr e-offset) - (unsigned->ptr - (%inline + ,e-ptr ,(build-unfix e-offset)) - (type->width ptr-type))]) - (define-inline 3 $address->object - [(e-addr e-roffset) - (bind #f (e-roffset) - (%inline - - ,(ptr->integer e-addr (type->width ptr-type)) - ,(build-unfix e-roffset)))]) - (define-inline 2 $object-ref - [(type base offset) - (nanopass-case (L7 Expr) type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (build-object-ref #f type base offset)))] - [else #f])]) - (define-inline 2 $swap-object-ref - [(type base offset) - (nanopass-case (L7 Expr) type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (build-object-ref #t type base offset)))] - [else #f])]) - (define-inline 3 foreign-ref - [(e-type e-addr e-offset) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (bind #f (e-offset) - (build-object-ref #f type - (ptr->integer e-addr (constant ptr-bits)) - e-offset))))] - [else #f])]) - (define-inline 3 $foreign-swap-ref - [(e-type e-addr e-offset) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (bind #f (e-offset) - (build-object-ref #t type - (ptr->integer e-addr (constant ptr-bits)) - e-offset))))] - [else #f])]) - (define-inline 2 $object-set! - [(type base offset value) - (nanopass-case (L7 Expr) type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) - (build-object-set! type base offset value)))] - [else #f])]) - (define-inline 3 foreign-set! - [(e-type e-addr e-offset e-value) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean))) - (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) - (bind #f (e-offset e-value) - (build-object-set! type - (ptr->integer e-addr (constant ptr-bits)) - e-offset - e-value))))] - [else #f])]) - (define-inline 3 $foreign-swap-set! - [(e-type e-addr e-offset e-value) - (nanopass-case (L7 Expr) e-type - [(quote ,d) - (let ([type (filter-foreign-type d)]) - (and (memq type (record-datatype list)) - (not (memq type '(char wchar boolean single-float))) - (>= (constant ptr-bits) (type->width type)) - (bind #f (e-offset e-value) - (build-swap-object-set! type - (ptr->integer e-addr (constant ptr-bits)) - e-offset - e-value))))] - [else #f])]) - (define-inline 2 $make-fptr - [(e-ftype e-addr) - (nanopass-case (L7 Expr) e-addr - [(call ,info ,mdcl ,pr ,e1) - (guard - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (bind #f (e-ftype e1) - (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) - (%seq - (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) - (set! ,(%mref ,t ,(constant record-data-disp)) - ,(%mref ,e1 ,(constant record-data-disp))) - ,t)))] - [else - (bind #f (e-ftype e-addr) - (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) - (%seq - (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) - (set! ,(%mref ,t ,(constant record-data-disp)) - ,(ptr->integer e-addr (constant ptr-bits))) - ,t)))])]) - (define-inline 3 ftype-pointer-address - [(e-fptr) - (build-object-ref #f - (constant-case ptr-bits - [(64) 'unsigned-64] - [(32) 'unsigned-32]) - e-fptr %zero (constant record-data-disp))]) - (define-inline 3 ftype-pointer-null? - [(e-fptr) (make-ftype-pointer-null? e-fptr)]) - (define-inline 3 ftype-pointer=? - [(e1 e2) (make-ftype-pointer-equal? e1 e2)]) - (let () - (define build-fx+raw - (lambda (fx-arg raw-arg) - (if (constant? (lambda (x) (eqv? x 0)) fx-arg) - raw-arg - (%inline + ,raw-arg ,(build-unfix fx-arg))))) - (define $extract-fptr-address - (lambda (e-fptr) - (define suppress-unsafe-cast - (lambda (e-fptr) - (nanopass-case (L7 Expr) e-fptr - [(call ,info1 ,mdcl1 ,pr1 (quote ,d) (call ,info2 ,mdcl2 ,pr2 ,e)) - (guard - (eq? (primref-name pr1) '$make-fptr) - (all-set? (prim-mask unsafe) (primref-flags pr2)) - (eq? (primref-name pr2) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr2))) - e] - [else e-fptr]))) - (nanopass-case (L7 Expr) e-fptr - ; skip allocation and dereference of ftype-pointer for $fptr-fptr-ref - [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd - (guard - (eq? (primref-name pr) '$fptr-fptr-ref) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e2)]) - (bind #f (e-index e3) - `(inline ,(make-info-load ptr-type #f) ,%load - ,($extract-fptr-address e1) - ,e-index (immediate ,imm-offset))))] - ; skip allocation and dereference of ftype-pointer for $fptr-&ref - [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd - (guard - (eq? (primref-name pr) '$fptr-&ref) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (build-fx+raw e2 ($extract-fptr-address e1))] - ; skip allocation and dereference of ftype-pointer for $make-fptr - [(call ,info ,mdcl ,pr ,e1 ,e2) ; e1, e2 = ftd, (ptr) addr - (guard - (eq? (primref-name pr) '$make-fptr) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (nanopass-case (L7 Expr) e2 - [(call ,info ,mdcl ,pr ,e3) - (guard - (eq? (primref-name pr) 'ftype-pointer-address) - (all-set? (prim-mask unsafe) (primref-flags pr))) - (bind #f (e1) - (%mref ,e3 ,(constant record-data-disp)))] - [else - (bind #f (e1) - (ptr->integer e2 (constant ptr-bits)))])] - [else - `(inline ,(make-info-load ptr-type #f) ,%load ,(suppress-unsafe-cast e-fptr) ,%zero - ,(%constant record-data-disp))]))) - (let () - (define-inline 3 $fptr-offset-addr - [(e-fptr e-offset) - ; bind offset before doing the load (a) to maintain applicative order---the - ; load can cause an invalid memory reference---and (b) so that the raw value - ; isn't live across any calls - (bind #f (e-offset) - (build-fx+raw e-offset - ($extract-fptr-address e-fptr)))]) - (define-inline 3 $fptr-&ref - [(e-fptr e-offset e-ftd) - ; see comment in $fptr-offset-addr - (bind #f (e-offset e-ftd) - (build-$record e-ftd - (list (build-fx+raw e-offset ($extract-fptr-address e-fptr)))))])) - (define-inline 3 $fptr-fptr-ref - [(e-fptr e-offset e-ftd) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #f (e-index) - (build-$record e-ftd - (list `(inline ,(make-info-load ptr-type #f) ,%load - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset))))))]) - (define-inline 3 $fptr-fptr-set! - [(e-fptr e-offset e-val) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #f ([e-addr ($extract-fptr-address e-fptr)] e-index e-val) - `(inline ,(make-info-load ptr-type #f) ,%store ,e-addr ,e-index (immediate ,imm-offset) - (inline ,(make-info-load ptr-type #f) ,%load ,e-val ,%zero - ,(%constant record-data-disp)))))]) - (let () - (define $do-fptr-ref-inline - (lambda (swapped? type e-fptr e-offset) - (bind #f (e-offset) - (build-object-ref swapped? type ($extract-fptr-address e-fptr) e-offset)))) - (define-syntax define-fptr-ref-inline - (lambda (x) - (define build-inline - (lambda (name type ref maybe-k) - #`(define-inline 3 #,name - [(e-fptr e-offset) - #,((lambda (body) (if maybe-k #`(#,maybe-k #,body) body)) - #`($do-fptr-ref-inline #,ref #,type e-fptr e-offset))]))) - (syntax-case x () - [(_ name ?type ref) (build-inline #'name #'?type #'ref #f)] - [(_ name ?type ref ?k) (build-inline #'name #'?type #'ref #'?k)]))) - - (define-fptr-ref-inline $fptr-ref-integer-8 'integer-8 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-8 'unsigned-8 #f) - - (define-fptr-ref-inline $fptr-ref-integer-16 'integer-16 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-16 'unsigned-16 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-16 'integer-16 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-16 'unsigned-16 #t) - - (when-known-endianness - (define-fptr-ref-inline $fptr-ref-integer-24 'integer-24 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-24 'unsigned-24 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-24 'integer-24 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-24 'unsigned-24 #t)) - - (define-fptr-ref-inline $fptr-ref-integer-32 'integer-32 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-32 'unsigned-32 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-32 'integer-32 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-32 'unsigned-32 #t) - - (when-known-endianness - (define-fptr-ref-inline $fptr-ref-integer-40 'integer-40 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-40 'unsigned-40 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-40 'integer-40 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-40 'unsigned-40 #t) - - (define-fptr-ref-inline $fptr-ref-integer-48 'integer-48 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-48 'unsigned-48 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-48 'integer-48 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-48 'unsigned-48 #t) - - (define-fptr-ref-inline $fptr-ref-integer-56 'integer-56 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-56 'unsigned-56 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-56 'integer-56 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-56 'unsigned-56 #t)) - - (define-fptr-ref-inline $fptr-ref-integer-64 'integer-64 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-64 'unsigned-64 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-64 'integer-64 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-64 'unsigned-64 #t) - - (define-fptr-ref-inline $fptr-ref-double-float 'double-float #f) - (define-fptr-ref-inline $fptr-ref-swap-double-float 'double-float #t) - - (define-fptr-ref-inline $fptr-ref-single-float 'single-float #f) - (define-fptr-ref-inline $fptr-ref-swap-single-float 'single-float #t) - - (define-fptr-ref-inline $fptr-ref-char 'unsigned-8 #f - (lambda (x) (build-integer->char x))) - - (define-fptr-ref-inline $fptr-ref-wchar - (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) - #f - (lambda (x) (build-integer->char x))) - (define-fptr-ref-inline $fptr-ref-swap-wchar - (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) - #t - (lambda (x) (build-integer->char x))) - - (define-fptr-ref-inline $fptr-ref-boolean - (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) - #f - (lambda (x) - `(if ,(%inline eq? ,x (immediate 0)) - ,(%constant sfalse) - ,(%constant strue)))) - (define-fptr-ref-inline $fptr-ref-swap-boolean - (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) - #t - (lambda (x) - `(if ,(%inline eq? ,x (immediate 0)) - ,(%constant sfalse) - ,(%constant strue)))) - - (define-fptr-ref-inline $fptr-ref-fixnum 'fixnum #f) - (define-fptr-ref-inline $fptr-ref-swap-fixnum 'fixnum #t)) - (let () - (define $do-fptr-set!-inline - (lambda (set type e-fptr e-offset e-val) - (bind #f (e-offset) - (set type ($extract-fptr-address e-fptr) e-offset e-val)))) - (define-syntax define-fptr-set!-inline - (lambda (x) - (define build-body - (lambda (type set maybe-massage-val) - #``(seq ,e-info - #,(let ([body #`($do-fptr-set!-inline #,set #,type e-fptr e-offset e-val)]) - (if maybe-massage-val - #`,(bind #f (e-offset [e-val (#,maybe-massage-val e-val)]) #,body) - #`,(bind #f (e-offset e-val) #,body)))))) - (define build-inline - (lambda (name check-64? body) - #`(define-inline 3 #,name - [(e-info e-fptr e-offset e-val) - #,(if check-64? - #`(and (fx>= (constant ptr-bits) 64) #,body) - body)]))) - (syntax-case x () - [(_ check-64? name ?type set) - (build-inline #'name (datum check-64?) (build-body #'?type #'set #f))] - [(_ check-64? name ?type set ?massage-value) - (build-inline #'name (datum check-64?) (build-body #'?type #'set #'?massage-value))]))) - - (define-fptr-set!-inline #f $fptr-set-integer-8! 'integer-8 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-8! 'unsigned-8 build-object-set!) - - (define-fptr-set!-inline #f $fptr-set-integer-16! 'integer-16 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-16! 'unsigned-16 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-integer-16! 'integer-16 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-unsigned-16! 'unsigned-16 build-swap-object-set!) - - (when-known-endianness - (define-fptr-set!-inline #f $fptr-set-integer-24! 'integer-24 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-24! 'unsigned-24 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-integer-24! 'integer-24 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-unsigned-24! 'unsigned-24 build-swap-object-set!)) - - (define-fptr-set!-inline #f $fptr-set-integer-32! 'integer-32 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-32! 'unsigned-32 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-integer-32! 'integer-32 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-unsigned-32! 'unsigned-32 build-swap-object-set!) - - (when-known-endianness - (define-fptr-set!-inline #t $fptr-set-integer-40! 'integer-40 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-40! 'unsigned-40 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-40! 'integer-40 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-40! 'unsigned-40 build-swap-object-set!) - - (define-fptr-set!-inline #t $fptr-set-integer-48! 'integer-48 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-48! 'unsigned-48 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-48! 'integer-48 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-48! 'unsigned-48 build-swap-object-set!) - - (define-fptr-set!-inline #t $fptr-set-integer-56! 'integer-56 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-56! 'unsigned-56 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-56! 'integer-56 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-56! 'unsigned-56 build-swap-object-set!)) - - (define-fptr-set!-inline #t $fptr-set-integer-64! 'integer-64 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-64! 'unsigned-64 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-64! 'integer-64 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-64! 'unsigned-64 build-swap-object-set!) - - (define-fptr-set!-inline #f $fptr-set-double-float! 'double-float build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-double-float! 'double-float build-swap-object-set!) - - (define-fptr-set!-inline #f $fptr-set-single-float! 'single-float build-object-set!) - - (define-fptr-set!-inline #f $fptr-set-char! 'unsigned-8 build-object-set! - (lambda (z) (build-char->integer z))) - - (define-fptr-set!-inline #f $fptr-set-wchar! - (constant-case wchar-bits - [(16) 'unsigned-16] - [(32) 'unsigned-32]) - build-object-set! - (lambda (z) (build-char->integer z))) - (define-fptr-set!-inline #f $fptr-set-swap-wchar! - (constant-case wchar-bits - [(16) 'unsigned-16] - [(32) 'unsigned-32]) - build-swap-object-set! - (lambda (z) (build-char->integer z))) - - (define-fptr-set!-inline #f $fptr-set-boolean! - (constant-case int-bits - [(32) 'unsigned-32] - [(64) 'unsigned-64]) - build-object-set! - (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) - (define-fptr-set!-inline #f $fptr-set-swap-boolean! - (constant-case int-bits - [(32) 'unsigned-32] - [(64) 'unsigned-64]) - build-swap-object-set! - (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) - - (define-fptr-set!-inline #f $fptr-set-fixnum! 'fixnum build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-fixnum! 'fixnum build-swap-object-set!)) - (let () - (define-syntax define-fptr-bits-ref-inline - (lambda (x) - (syntax-case x () - [(_ name signed? type swapped?) - #'(define-inline 3 name - [(e-fptr e-offset e-start e-end) - (and (fixnum-constant? e-start) (fixnum-constant? e-end) - (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) - (and (<= (type->width 'type) (constant ptr-bits)) - (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) - ((if signed? fx<= fx<) (fx- imm-end imm-start) (constant fixnum-bits)) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #f (e-index) - (build-int-load swapped? 'type ($extract-fptr-address e-fptr) e-index imm-offset - (lambda (x) - ((if signed? extract-signed-bitfield extract-unsigned-bitfield) #t imm-start imm-end x))))))))])]))) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-8 #t unsigned-8 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-8 #f unsigned-8 #f) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-16 #t unsigned-16 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-16 #f unsigned-16 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-16 #t unsigned-16 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-16 #f unsigned-16 #t) - - (when-known-endianness - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-24 #t unsigned-24 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-24 #f unsigned-24 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-24 #t unsigned-24 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-24 #f unsigned-24 #t)) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-32 #t unsigned-32 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-32 #f unsigned-32 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-32 #t unsigned-32 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-32 #f unsigned-32 #t) - - (when-known-endianness - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-40 #t unsigned-40 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-40 #f unsigned-40 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-40 #t unsigned-40 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-40 #f unsigned-40 #t) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-48 #t unsigned-48 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-48 #f unsigned-48 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-48 #t unsigned-48 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-48 #f unsigned-48 #t) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-56 #t unsigned-56 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-56 #f unsigned-56 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-56 #t unsigned-56 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-56 #f unsigned-56 #t)) - - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-64 #t unsigned-64 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-64 #f unsigned-64 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-64 #t unsigned-64 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-64 #f unsigned-64 #t)) - (let () - (define-syntax define-fptr-bits-set-inline - (lambda (x) - (syntax-case x () - [(_ check-64? name type swapped?) - (with-syntax ([(checks ...) #'((fixnum-constant? e-start) (fixnum-constant? e-end))]) - (with-syntax ([(checks ...) (if (datum check-64?) - #'((fx>= (constant ptr-bits) 64) checks ...) - #'(checks ...))]) - #`(define-inline 3 name - [(e-fptr e-offset e-start e-end e-val) - (and - checks ... - (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) - (and (<= (type->width 'type) (constant ptr-bits)) - (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) - (fx< (fx- imm-end imm-start) (constant fixnum-bits)) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #t (e-index) - (bind #f (e-val) - (bind #t ([e-addr ($extract-fptr-address e-fptr)]) - (build-int-load swapped? 'type e-addr e-index imm-offset - (lambda (x) - (build-int-store swapped? 'type e-addr e-index imm-offset - (insert-bitfield #t imm-start imm-end (type->width 'type) x - e-val)))))))))))])))]))) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-8! unsigned-8 #f) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-16! unsigned-16 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-16! unsigned-16 #t) - - (when-known-endianness - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-24! unsigned-24 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-24! unsigned-24 #t)) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-32! unsigned-32 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-32! unsigned-32 #t) - - (when-known-endianness - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-40! unsigned-40 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-40! unsigned-40 #t) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-48! unsigned-48 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-48! unsigned-48 #t) - - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-56! unsigned-56 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-56! unsigned-56 #t)) - - (define-fptr-bits-set-inline #t $fptr-set-bits-unsigned-64! unsigned-64 #f) - (define-fptr-bits-set-inline #t $fptr-set-bits-swap-unsigned-64! unsigned-64 #t)) - (define-inline 3 $fptr-locked-decr! - [(e-fptr e-offset) - `(seq - ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (%inline locked-decr! - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset))) - (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) - (define-inline 3 $fptr-locked-incr! - [(e-fptr e-offset) - `(seq - ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (%inline locked-incr! - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset))) - (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) - (let () - (define clear-lock - (lambda (e-fptr e-offset) - (let ([lock-type (constant-case ptr-bits [(32) 'integer-32] [(64) 'integer-64])]) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - `(inline ,(make-info-load lock-type #f) ,%store - ,($extract-fptr-address e-fptr) - ,e-index (immediate ,imm-offset) (immediate 0)))))) - (define-inline 3 $fptr-init-lock! - [(e-fptr e-offset) (clear-lock e-fptr e-offset)]) - (define-inline 3 $fptr-unlock! - [(e-fptr e-offset) (clear-lock e-fptr e-offset)])) - (define-inline 3 $fptr-lock! - [(e-fptr e-offset) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #t ([e-base ($extract-fptr-address e-fptr)]) - (%inline lock! ,e-base ,e-index (immediate ,imm-offset))))]) - (define-inline 3 $fptr-spin-lock! - [(e-fptr e-offset) - (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) - (bind #t ([e-base ($extract-fptr-address e-fptr)]) - (bind #t (e-index) - (let ([L1 (make-local-label 'L1)] [L2 (make-local-label 'L2)]) - `(label ,L1 - (if ,(%inline lock! ,e-base ,e-index (immediate ,imm-offset)) - ,(%constant svoid) - (seq - (pariah) - (label ,L2 - (seq - ,(%inline pause) - (if ,(%inline eq? (mref ,e-base ,e-index ,imm-offset uptr) (immediate 0)) - (goto ,L1) - (goto ,L2)))))))))))])) - (let () - (define build-port-flags-set? - (lambda (e-p e-flags) - (%inline logtest - ,(%mref ,e-p ,(constant port-type-disp)) - ,(nanopass-case (L7 Expr) e-flags - [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] - [else (%inline sll ,e-flags - (immediate ,(fx- (constant port-flags-offset) (constant fixnum-offset))))])))) - (define build-port-input-empty? - (lambda (e-p) - (%inline eq? - ,(%mref ,e-p ,(constant port-icount-disp)) - (immediate 0)))) - (define-inline 3 binary-port? - [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-binary)))]) - (define-inline 3 textual-port? - [(e-p) (build-not (build-port-flags-set? e-p `(quote ,(constant port-flag-binary))))]) - (define-inline 3 port-closed? - [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-closed)))]) - (define-inline 3 $port-flags-set? - [(e-p e-flags) (build-port-flags-set? e-p e-flags)]) - (define-inline 3 port-eof? - [(e-p) - (bind #t (e-p) - `(if ,(build-port-input-empty? e-p) - (if ,(build-port-flags-set? e-p `(quote ,(constant port-flag-eof))) - (immediate ,(constant strue)) - ,(build-libcall #t src sexpr unsafe-port-eof? e-p)) - (immediate ,(constant sfalse))))]) - (define-inline 2 port-eof? - [(e-p) - (let ([Llib (make-local-label 'Llib)]) - (bind #t (e-p) - `(if ,(%type-check mask-typed-object type-typed-object ,e-p) - ,(bind #t ([t0 (%mref ,e-p ,(constant typed-object-type-disp))]) - `(if ,(%type-check mask-input-port type-input-port ,t0) - (if ,(build-port-input-empty? e-p) - (if ,(%inline logtest ,t0 - (immediate ,(ash (constant port-flag-eof) (constant port-flags-offset)))) - (immediate ,(constant strue)) - (label ,Llib ,(build-libcall #t src sexpr safe-port-eof? e-p))) - (immediate ,(constant sfalse))) - (goto ,Llib))) - (goto ,Llib))))]) - (define-inline 3 port-input-empty? - [(e-p) (build-port-input-empty? e-p)]) - (define-inline 3 port-output-full? - [(e-p) - (%inline eq? - ,(%mref ,e-p ,(constant port-ocount-disp)) - (immediate 0))])) - (let () - (define build-set-port-flags! - (lambda (e-p e-flags) - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-type-disp)) - ,(%inline logor - ,(%mref ,e-p ,(constant port-type-disp)) - ,(nanopass-case (L7 Expr) e-flags - [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] - [else - (translate e-flags - (constant fixnum-offset) - (constant port-flags-offset))])))))) - (define build-reset-port-flags! - (lambda (e-p e-flags) - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-type-disp)) - ,(%inline logand - ,(%mref ,e-p ,(constant port-type-disp)) - ,(nanopass-case (L7 Expr) e-flags - [(quote ,d) `(immediate ,(lognot (ash d (constant port-flags-offset))))] - [else - (%inline lognot - ,(translate e-flags - (constant fixnum-offset) - (constant port-flags-offset)))])))))) - (define-inline 3 $set-port-flags! - [(e-p e-flags) (build-set-port-flags! e-p e-flags)]) - (define-inline 3 $reset-port-flags! - [(e-p e-flags) (build-reset-port-flags! e-p e-flags)]) - (define-inline 3 mark-port-closed! - [(e-p) (build-set-port-flags! e-p `(quote ,(constant port-flag-closed)))]) - (let () - (define (go e-p e-bool flag) - (let ([e-flags `(quote ,flag)]) - (nanopass-case (L7 Expr) e-bool - [(quote ,d) - ((if d build-set-port-flags! build-reset-port-flags!) e-p e-flags)] - [else - (bind #t (e-p) - `(if ,e-bool - ,(build-set-port-flags! e-p e-flags) - ,(build-reset-port-flags! e-p e-flags)))]))) - (define-inline 3 set-port-bol! - [(e-p e-bool) (go e-p e-bool (constant port-flag-bol))]) - (define-inline 3 set-port-eof! - [(e-p e-bool) (go e-p e-bool (constant port-flag-eof))]))) - (let () - (define (build-port-input-size port-type e-p) - (bind #t (e-p) - (translate - (%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%mref ,e-p ,(constant port-ibuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-input-size - [(e-p) (build-port-input-size 'textual e-p)]) - (define-inline 3 binary-port-input-size - [(e-p) (build-port-input-size 'binary e-p)])) - (let () - (define (build-port-output-size port-type e-p) - (bind #t (e-p) - (translate - (%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%mref ,e-p ,(constant port-obuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-output-size - [(e-p) (build-port-output-size 'textual e-p)]) - (define-inline 3 binary-port-output-size - [(e-p) (build-port-output-size 'binary e-p)])) - (let () - (define (build-port-input-index port-type e-p) - (bind #t (e-p) - (translate - ; TODO: use lea2? - (%inline + - ,(%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%mref ,e-p ,(constant port-ibuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,(%mref ,e-p ,(constant port-icount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-input-index - [(e-p) (build-port-input-index 'textual e-p)]) - (define-inline 3 binary-port-input-index - [(e-p) (build-port-input-index 'binary e-p)])) - (let () - (define (build-port-output-index port-type e-p) - (bind #t (e-p) - (translate - (%inline + - ,(%inline - - ,(%inline - - ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%mref ,e-p ,(constant port-obuffer-disp))) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,(%mref ,e-p ,(constant port-ocount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-output-index - [(e-p) (build-port-output-index 'textual e-p)]) - (define-inline 3 binary-port-output-index - [(e-p) (build-port-output-index 'binary e-p)])) - (let () - (define (build-port-input-count port-type e-p) - (bind #t (e-p) - (translate - (%inline - - (immediate 0) - ,(%mref ,e-p ,(constant port-icount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-input-count - [(e-p) (build-port-input-count 'textual e-p)]) - (define-inline 3 binary-port-input-count - [(e-p) (build-port-input-count 'binary e-p)])) - (let () - (define (build-port-output-count port-type e-p) - (bind #t (e-p) - (translate - (%inline - - (immediate 0) - ,(%mref ,e-p ,(constant port-ocount-disp))) - (if (eq? port-type 'textual) (constant string-char-offset) 0) - (constant fixnum-offset)))) - (define-inline 3 textual-port-output-count - [(e-p) (build-port-output-count 'textual e-p)]) - (define-inline 3 binary-port-output-count - [(e-p) (build-port-output-count 'binary e-p)])) - (let () - (define (build-set-port-input-size! port-type e-p e-x) - ; actually, set last to buffer[0] + size; count to size - (bind #t (e-p) - (bind #t ([e-x (translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0))]) - `(seq - (set! ,(%mref ,e-p ,(constant port-icount-disp)) - ,(%inline - (immediate 0) ,e-x)) - (set! ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%inline + - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,e-x)))))) - (define-inline 3 set-textual-port-input-size! - [(e-p e-x) (build-set-port-input-size! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-input-size! - [(e-p e-x) (build-set-port-input-size! 'binary e-p e-x)])) - (let () - (define (build-set-port-output-size! port-type e-p e-x) - ; actually, set last to buffer[0] + size; count to size - (bind #t (e-p) - (bind #t ([e-x (translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0))]) - `(seq - (set! ,(%mref ,e-p ,(constant port-ocount-disp)) - ,(%inline - (immediate 0) ,e-x)) - (set! ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%inline + - ,(%inline + - ,(%mref ,e-p ,(constant port-obuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))) - ,e-x)))))) - (define-inline 3 set-textual-port-output-size! - [(e-p e-x) (build-set-port-output-size! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-output-size! - [(e-p e-x) (build-set-port-output-size! 'binary e-p e-x)])) - (let () - (define (build-set-port-input-index! port-type e-p e-x) - ; actually, set count to index - size, where size = last - buffer[0] - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-icount-disp)) - ,(%inline - - ,(translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0)) - ,(%inline - - ,(%mref ,e-p ,(constant port-ilast-disp)) - ,(%inline + - ,(%mref ,e-p ,(constant port-ibuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp))))))))) - (define-inline 3 set-textual-port-input-index! - [(e-p e-x) (build-set-port-input-index! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-input-index! - [(e-p e-x) (build-set-port-input-index! 'binary e-p e-x)])) - (let () - (define (build-set-port-output-index! port-type e-p e-x) - ; actually, set count to index - size, where size = last - buffer[0] - (bind #t (e-p) - `(set! ,(%mref ,e-p ,(constant port-ocount-disp)) - ,(%inline - - ,(translate e-x - (constant fixnum-offset) - (if (eq? port-type 'textual) (constant string-char-offset) 0)) - ,(%inline - - ,(%mref ,e-p ,(constant port-olast-disp)) - ,(%inline + - ,(%mref ,e-p ,(constant port-obuffer-disp)) - (immediate - ,(if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp))))))))) - (define-inline 3 set-textual-port-output-index! - [(e-p e-x) (build-set-port-output-index! 'textual e-p e-x)]) - (define-inline 3 set-binary-port-output-index! - [(e-p e-x) (build-set-port-output-index! 'binary e-p e-x)])) - (let () - (define (make-build-set-port-buffer! port-type ibuffer-disp icount-disp ilast-disp) - (lambda (e-p e-b new?) - (bind #t (e-p e-b) - `(seq - ,(if new? - `(set! ,(%mref ,e-p ,ibuffer-disp) ,e-b) - (build-dirty-store e-p ibuffer-disp e-b)) - ,(bind #t ([e-length (if (eq? port-type 'textual) - (translate - (%inline logand - ,(%mref ,e-b ,(constant string-type-disp)) - (immediate ,(fx- (expt 2 (constant string-length-offset))))) - (constant string-length-offset) - (constant string-char-offset)) - (%inline srl - ,(%mref ,e-b ,(constant bytevector-type-disp)) - ,(%constant bytevector-length-offset)))]) - `(seq - (set! ,(%mref ,e-p ,icount-disp) - ,(%inline - (immediate 0) ,e-length)) - (set! ,(%mref ,e-p ,ilast-disp) - ,(%lea ,e-b ,e-length - (if (eq? port-type 'textual) - (constant string-data-disp) - (constant bytevector-data-disp)))))))))) - (define (make-port e-name e-handler e-ib e-ob e-info flags set-ibuf! set-obuf!) - (bind #f (e-name e-handler e-info e-ib e-ob) - (bind #t ([e-p (%constant-alloc type-typed-object (constant size-port))]) - (%seq - (set! ,(%mref ,e-p ,(constant port-type-disp)) (immediate ,flags)) - (set! ,(%mref ,e-p ,(constant port-handler-disp)) ,e-handler) - (set! ,(%mref ,e-p ,(constant port-name-disp)) ,e-name) - (set! ,(%mref ,e-p ,(constant port-info-disp)) ,e-info) - ,(set-ibuf! e-p e-ib #t) - ,(set-obuf! e-p e-ob #t) - ,e-p)))) - (define (make-build-clear-count count-disp) - (lambda (e-p e-b new?) - `(set! ,(%mref ,e-p ,count-disp) (immediate 0)))) - (let () - (define build-set-textual-port-input-buffer! - (make-build-set-port-buffer! 'textual - (constant port-ibuffer-disp) - (constant port-icount-disp) - (constant port-ilast-disp))) - (define build-set-textual-port-output-buffer! - (make-build-set-port-buffer! 'textual - (constant port-obuffer-disp) - (constant port-ocount-disp) - (constant port-olast-disp))) - (define-inline 3 set-textual-port-input-buffer! - [(e-p e-b) (build-set-textual-port-input-buffer! e-p e-b #f)]) - (define-inline 3 set-textual-port-output-buffer! - [(e-p e-b) (build-set-textual-port-output-buffer! e-p e-b #f)]) - (let () - (define (go e-name e-handler e-ib e-info) - (make-port e-name e-handler e-ib `(quote "") e-info - (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE)) - build-set-textual-port-input-buffer! - (make-build-clear-count (constant port-ocount-disp)))) - (define-inline 3 $make-textual-input-port - [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] - [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) - (let () - (define (go e-name e-handler e-ob e-info) - (make-port e-name e-handler `(quote "") e-ob e-info - (constant type-output-port) - (make-build-clear-count (constant port-icount-disp)) - build-set-textual-port-output-buffer!)) - (define-inline 3 $make-textual-output-port - [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] - [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) - (let () - (define (go e-name e-handler e-ib e-ob e-info) - (make-port e-name e-handler e-ib e-ob e-info - (constant type-io-port) - build-set-textual-port-input-buffer! - build-set-textual-port-output-buffer!)) - (define-inline 3 $make-textual-input/output-port - [(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))] - [(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)]))) - (let () - (define build-set-binary-port-input-buffer! - (make-build-set-port-buffer! 'binary - (constant port-ibuffer-disp) - (constant port-icount-disp) - (constant port-ilast-disp))) - (define build-set-binary-port-output-buffer! - (make-build-set-port-buffer! 'binary - (constant port-obuffer-disp) - (constant port-ocount-disp) - (constant port-olast-disp))) - (define-inline 3 set-binary-port-input-buffer! - [(e-p e-b) (build-set-binary-port-input-buffer! e-p e-b #f)]) - (define-inline 3 set-binary-port-output-buffer! - [(e-p e-b) (build-set-binary-port-output-buffer! e-p e-b #f)]) - (let () - (define (go e-name e-handler e-ib e-info) - (make-port e-name e-handler e-ib `(quote #vu8()) e-info - (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE) (constant PORT-FLAG-BINARY)) - build-set-binary-port-input-buffer! - (make-build-clear-count (constant port-ocount-disp)))) - (define-inline 3 $make-binary-input-port - [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] - [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) - (let () - (define (go e-name e-handler e-ob e-info) - (make-port e-name e-handler `(quote #vu8()) e-ob e-info - (fxlogor (constant type-output-port) (constant PORT-FLAG-BINARY)) - (make-build-clear-count (constant port-icount-disp)) - build-set-binary-port-output-buffer!)) - (define-inline 3 $make-binary-output-port - [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] - [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) - (let () - (define (go e-name e-handler e-ib e-ob e-info) - (make-port e-name e-handler e-ib e-ob e-info - (fxlogor (constant type-io-port) (constant PORT-FLAG-BINARY)) - build-set-binary-port-input-buffer! - build-set-binary-port-output-buffer!)) - (define-inline 3 $make-binary-input/output-port - [(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))] - [(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)])))) - (let () - (define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector never-immutable-flag)) - (define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector never-immutable-flag)) - (define-inline 2 $fxvector-ref-check? - [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-ref-check e-fv e-i #f))]) - (define-inline 2 $fxvector-set!-check? - [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-set!-check e-fv e-i #f))]) - (let () - (define (go e-fv e-i) - (cond - [(expr->index e-i 1 (constant maximum-fxvector-length)) => - (lambda (index) - (%mref ,e-fv - ,(+ (fix index) (constant fxvector-data-disp))))] - [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))])) - (define-inline 3 fxvector-ref - [(e-fv e-i) (go e-fv e-i)]) - (define-inline 2 fxvector-ref - [(e-fv e-i) - (bind #t (e-fv e-i) - `(if ,(build-fxvector-ref-check e-fv e-i #f) - ,(go e-fv e-i) - ,(build-libcall #t src sexpr fxvector-ref e-fv e-i)))])) - (let () - (define (go e-fv e-i e-new) - `(set! - ,(cond - [(expr->index e-i 1 (constant maximum-fxvector-length)) => - (lambda (index) - (%mref ,e-fv - ,(+ (fix index) (constant fxvector-data-disp))))] - [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))]) - ,e-new)) - (define-inline 3 fxvector-set! - [(e-fv e-i e-new) - (go e-fv e-i e-new)]) - (define-inline 2 fxvector-set! - [(e-fv e-i e-new) - (bind #t (e-fv e-i e-new) - `(if ,(build-fxvector-set!-check e-fv e-i e-new) - ,(go e-fv e-i e-new) - ,(build-libcall #t src sexpr fxvector-set! e-fv e-i e-new)))]))) - (let () - (define build-flvector-ref-check (build-ref-check flvector-type-disp maximum-flvector-length flvector-length-offset type-flvector mask-flvector never-immutable-flag)) - (define build-flvector-set!-check (build-ref-check flvector-type-disp maximum-flvector-length flvector-length-offset type-flvector mask-flvector never-immutable-flag)) - (define-inline 2 $flvector-ref-check? - [(e-fv e-i) (bind #t (e-fv e-i) (build-flvector-ref-check e-fv e-i #f))]) - (define-inline 2 $flvector-set!-check? - [(e-fv e-i) (bind #t (e-fv e-i) (build-flvector-set!-check e-fv e-i #f))]) - (let () - (define (go e-fv e-i) - (cond - [(expr->index e-i 1 (constant maximum-flvector-length)) => - (lambda (index) - `(unboxed-fp ,(%mref ,e-fv ,%zero ,(+ (fx* index (constant flonum-bytes)) (constant flvector-data-disp)) fp)))] - [else `(unboxed-fp ,(%mref ,e-fv ,(build-double-scale e-i) ,(constant flvector-data-disp) fp))])) - (define-inline 3 flvector-ref - [(e-fv e-i) (go e-fv e-i)]) - (define-inline 2 flvector-ref - [(e-fv e-i) - (bind #t (e-fv e-i) - `(if ,(build-flvector-ref-check e-fv e-i #f) - ,(go e-fv e-i) - ,(build-libcall #t src sexpr flvector-ref e-fv e-i)))])) - (let () - (define (go e-fv e-i e-new) - `(set! - ,(cond - [(expr->index e-i 1 (constant maximum-flvector-length)) => - (lambda (index) - (%mref ,e-fv ,%zero ,(+ (fx* index (constant flonum-bytes)) (constant flvector-data-disp)) fp))] - [else (%mref ,e-fv ,(build-double-scale e-i) ,(constant flvector-data-disp) fp)]) - ,e-new)) - (define (checked-go src sexpr e-fv e-i e-new add-check) - `(if ,(add-check (build-flvector-set!-check e-fv e-i #f)) - ,(go e-fv e-i e-new) - ,(build-libcall #t src sexpr flvector-set! e-fv e-i e-new))) - (define-inline 3 flvector-set! - [(e-fv e-i e-new) - (go e-fv e-i e-new)]) - (define-inline 2 flvector-set! - [(e-fv e-i e-new) - (bind #t (e-fv e-i) - (if (known-flonum-result? e-new) - (bind #t fp (e-new) - (checked-go src sexpr e-fv e-i e-new values)) - (bind #t (e-new) - (checked-go src sexpr e-fv e-i e-new - (lambda (e) - (build-and e (build-flonums? (list e-new))))))))]))) - (let () - (define build-string-ref-check - (lambda (e-s e-i) - ((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string string-immutable-flag) e-s e-i #f))) - (define build-string-set!-check - (lambda (e-s e-i) - ((build-ref-check string-type-disp maximum-string-length string-length-offset type-mutable-string mask-mutable-string string-immutable-flag) e-s e-i #f))) - (define-inline 2 $string-ref-check? - [(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))]) - (define-inline 2 $string-set!-check? - [(e-s e-i) (bind #t (e-s e-i) (build-string-set!-check e-s e-i))]) - (let () - (define (go e-s e-i) - (cond - [(expr->index e-i 1 (constant maximum-string-length)) => - (lambda (index) - `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s ,%zero - (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp)))))] - [else - `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s - ,(translate e-i - (constant fixnum-offset) - (constant string-char-offset)) - ,(%constant string-data-disp))])) - (define-inline 3 string-ref - [(e-s e-i) (go e-s e-i)]) - (define-inline 2 string-ref - [(e-s e-i) - (bind #t (e-s e-i) - `(if ,(build-string-ref-check e-s e-i) - ,(go e-s e-i) - ,(build-libcall #t src sexpr string-ref e-s e-i)))])) - (let () - (define (go e-s e-i e-new) - (cond - [(expr->index e-i 1 (constant maximum-string-length)) => - (lambda (index) - `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s ,%zero - (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp))) - ,e-new))] - [else - `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s - ,(translate e-i - (constant fixnum-offset) - (constant string-char-offset)) - ,(%constant string-data-disp) - ,e-new)])) - (define-inline 3 string-set! - [(e-s e-i e-new) (go e-s e-i e-new)]) - (define-inline 2 string-set! - [(e-s e-i e-new) - (bind #t (e-s e-i e-new) - `(if ,(let ([e-ref-check (build-string-set!-check e-s e-i)]) - (if (constant? char? e-new) - e-ref-check - (build-and e-ref-check (%type-check mask-char type-char ,e-new)))) - ,(go e-s e-i e-new) - ,(build-libcall #t src sexpr string-set! e-s e-i e-new)))]) - (define-inline 3 $string-set-immutable! - [(e-s) ((build-set-immutable! string-type-disp string-immutable-flag) e-s)]))) - (let () - (define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector vector-immutable-flag)) - (define build-vector-set!-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-mutable-vector mask-mutable-vector vector-immutable-flag)) - (define-inline 2 $vector-ref-check? - [(e-v e-i) (bind #t (e-v e-i) (build-vector-ref-check e-v e-i #f))]) - (define-inline 2 $vector-set!-check? - [(e-v e-i) (bind #t (e-v e-i) (build-vector-set!-check e-v e-i #f))]) - (let () - (define (go e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant vector-data-disp))])) - (define-inline 3 vector-ref - [(e-v e-i) (go e-v e-i)]) - (define-inline 2 vector-ref - [(e-v e-i) - (bind #t (e-v e-i) - `(if ,(build-vector-ref-check e-v e-i #f) - ,(go e-v e-i) - ,(build-libcall #t src sexpr vector-ref e-v e-i)))])) - (let () - (define (go e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant vector-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new)])) - (define-inline 3 vector-set! - [(e-v e-i e-new) (go e-v e-i e-new)]) - (define-inline 2 vector-set! - [(e-v e-i e-new) - (bind #t (e-v e-i) - (dirty-store-bind #t (e-new) - `(if ,(build-vector-set!-check e-v e-i #f) - ,(go e-v e-i e-new) - ,(build-libcall #t src sexpr vector-set! e-v e-i e-new))))]) - (define-inline 3 $vector-set-immutable! - [(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)])) - (let () - (define (go e-v e-i e-old e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v %zero (+ (fix d) (constant vector-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] - [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) - (define-inline 3 vector-cas! - [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)]) - (define-inline 2 vector-cas! - [(e-v e-i e-old e-new) - (bind #t (e-v e-i e-old) - (dirty-store-bind #t (e-new) - `(if ,(build-vector-set!-check e-v e-i #f) - ,(go e-v e-i e-old e-new) - ,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new))))])) - (let () - (define (go e-v e-i e-new) - `(set! - ,(nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant vector-data-disp))]) - ,e-new)) - (define-inline 3 vector-set-fixnum! - [(e-v e-i e-new) (go e-v e-i e-new)]) - (define-inline 2 vector-set-fixnum! - [(e-v e-i e-new) - (bind #t (e-v e-i e-new) - `(if ,(build-vector-set!-check e-v e-i e-new) - ,(go e-v e-i e-new) - ,(build-libcall #t src sexpr vector-set-fixnum! e-v e-i e-new)))]))) - (let () - (define (go e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))])) - (define-inline 3 stencil-vector-ref - [(e-v e-i) (go e-v e-i)])) - (let () - (define (go e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant stencil-vector-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant stencil-vector-data-disp) e-new)])) - (define-inline 3 stencil-vector-set! - [(e-v e-i e-new) (go e-v e-i e-new)])) - (let () - (define (go e-v e-i e-new) - `(set! - ,(nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))]) - ,e-new)) - (define-inline 3 $stencil-vector-set! - [(e-v e-i e-new) (go e-v e-i e-new)])) - (let () - (define (go e-v e-i) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (%mref ,e-v ,(+ (fix d) (constant record-data-disp)))] - [else (%mref ,e-v ,e-i ,(constant record-data-disp))])) - (define-inline 3 $record-ref - [(e-v e-i) (go e-v e-i)])) - (let () - (define (go e-v e-i e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v (+ (fix d) (constant record-data-disp)) e-new)] - [else (build-dirty-store e-v e-i (constant record-data-disp) e-new)])) - (define-inline 3 $record-set! - [(e-v e-i e-new) (go e-v e-i e-new)])) - (let () - (define (go e-v e-i e-old e-new) - (nanopass-case (L7 Expr) e-i - [(quote ,d) - (guard (target-fixnum? d)) - (build-dirty-store e-v %zero (+ (fix d) (constant record-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] - [else (build-dirty-store e-v e-i (constant record-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) - (define-inline 3 $record-cas! - [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)])) - (let () - (define build-bytevector-ref-check - (lambda (e-bits e-bv e-i check-mutable?) - (nanopass-case (L7 Expr) e-bits - [(quote ,d) - (guard (and (fixnum? d) (fx> d 0) (fx= (* (fxquotient d 8) 8) d))) - (let ([bits d] [bytes (fxquotient d 8)]) - (bind #t (e-bv e-i) - (build-and - (%type-check mask-typed-object type-typed-object ,e-bv) - (bind #t ([t (%mref ,e-bv ,(constant bytevector-type-disp))]) - (build-and - (if check-mutable? - (%type-check mask-mutable-bytevector type-mutable-bytevector ,t) - (%type-check mask-bytevector type-bytevector ,t)) - (cond - [(expr->index e-i bytes (constant maximum-bytevector-length)) => - (lambda (index) - (%inline u< - (immediate ,(logor (ash (+ index (fx- bytes 1)) (constant bytevector-length-offset)) - (constant type-bytevector) (constant bytevector-immutable-flag))) - ,t))] - [else - (build-and - ($type-check (fxlogor (fix (fx- bytes 1)) (constant mask-fixnum)) (constant type-fixnum) e-i) - (%inline u< - ; NB. add cannot overflow or change negative to positive when - ; low-order (log2 bytes) bits of fixnum value are zero, as - ; guaranteed by type-check above - ,(if (fx= bytes 1) - e-i - (%inline + ,e-i (immediate ,(fix (fx- bytes 1))))) - ,(%inline logand - ,(translate t - (constant bytevector-length-offset) - (constant fixnum-offset)) - (immediate ,(- (constant fixnum-factor))))))]))))))] - [(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))] - [else #f]))) - (define-inline 2 $bytevector-ref-check? - [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #f)]) - (define-inline 2 $bytevector-set!-check? - [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #t)])) - (let () - (define build-bytevector-fill - (let ([filler (make-build-fill 1 (constant bytevector-data-disp))]) - (lambda (e-bv e-bytes e-fill) - (bind #t uptr ([e-fill (build-unfix e-fill)]) - (filler e-bv e-bytes e-fill))))) - (let () - (define do-make-bytevector - (lambda (e-length maybe-e-fill) - ; NB: caller must bind maybe-e-fill - (safe-assert (or (not maybe-e-fill) (no-need-to-bind? #f maybe-e-fill))) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(bytevector)) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-bytevector) n))]) - `(seq - (set! ,(%mref ,t ,(constant bytevector-type-disp)) - (immediate ,(fx+ (fx* n (constant bytevector-length-factor)) - (constant type-bytevector)))) - ,(if maybe-e-fill - (build-bytevector-fill t `(immediate ,n) maybe-e-fill) - t))))) - (bind #t (e-length) - (let ([t-bytes (make-tmp 'tbytes 'uptr)] [t-vec (make-tmp 'tvec)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(bytevector)) - (let ([,t-bytes ,(build-unfix e-length)]) - (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,t-bytes - (immediate ,(fx+ (constant header-size-bytevector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-vec ,(constant bytevector-type-disp)) - ,(build-type/length t-bytes - (constant type-bytevector) - 0 - (constant bytevector-length-offset))) - ,(if maybe-e-fill - (build-bytevector-fill t-vec t-bytes maybe-e-fill) - t-vec)))))))))) - (let () - (define valid-length? - (lambda (e-length) - (constant? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= 0 x (constant maximum-bytevector-length)))) - e-length))) - (define-inline 2 make-bytevector - [(e-length) (and (valid-length? e-length) (do-make-bytevector e-length #f))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) e-fill) - (do-make-bytevector e-length e-fill))])) - (define-inline 3 make-bytevector - [(e-length) (do-make-bytevector e-length #f)] - [(e-length e-fill) (bind #f (e-fill) (do-make-bytevector e-length e-fill))])) - (define-inline 3 bytevector-fill! - [(e-bv e-fill) - (bind #t (e-bv e-fill) - `(seq - ,(build-bytevector-fill e-bv - (%inline srl - ,(%mref ,e-bv ,(constant bytevector-type-disp)) - ,(%constant bytevector-length-offset)) - e-fill) - ,(%constant svoid)))]) - (define-inline 2 bytevector->immutable-bytevector - [(e-bv) - (nanopass-case (L7 Expr) e-bv - [(quote ,d) - (guard (bytevector? d) (= 0 (bytevector-length d))) - `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-bytevector) 0))] - [else #f])])) - - (let () - (define build-bytevector - (lambda (e*) - (define (find-k n) - (constant-case native-endianness - [(unknown) - (values 1 'unsigned-8)] - [else - (let loop ([bytes (constant-case ptr-bits [(32) 4] [(64) 8])] - [type* (constant-case ptr-bits - [(32) '(unsigned-32 unsigned-16 unsigned-8)] - [(64) '(unsigned-64 unsigned-32 unsigned-16 unsigned-8)])]) - (let ([bytes/2 (fxsrl bytes 1)]) - (if (fx<= n bytes/2) - (loop bytes/2 (cdr type*)) - (values bytes (car type*)))))])) - (define (build-chunk k n e*) - (define (build-shift e shift) - (if (fx= shift 0) e (%inline sll ,e (immediate ,shift)))) - (let loop ([k (constant-case native-endianness - [(little) (fxmin k n)] - [(big) k] - [(unknown) (safe-assert (= k 1)) 1])] - [e* (constant-case native-endianness - [(little) (reverse (if (fx<= n k) e* (list-head e* k)))] - [(big) e*] - [(unknown) e*])] - [constant-part 0] - [expression-part #f] - [expression-shift 0] - [mask? #f]) ; no need to mask the high-order byte - (if (fx= k 0) - (if expression-part - (let ([expression-part (build-shift expression-part expression-shift)]) - (if (= constant-part 0) - expression-part - (%inline logor ,expression-part (immediate ,constant-part)))) - `(immediate ,constant-part)) - (let ([k (fx- k 1)] - [constant-part (ash constant-part 8)] - [expression-shift (fx+ expression-shift 8)]) - (if (null? e*) - (loop k e* constant-part expression-part expression-shift #t) - (let ([e (car e*)] [e* (cdr e*)]) - (if (fixnum-constant? e) - (loop k e* (logor constant-part (logand (constant-value e) #xff)) expression-part expression-shift #t) - (loop k e* constant-part - (let* ([e (build-unfix e)] - [e (if mask? (%inline logand ,e (immediate #xff)) e)]) - (if expression-part - (%inline logor ,(build-shift expression-part expression-shift) ,e) - e)) - 0 #t)))))))) - (let ([len (length e*)]) - (if (fx= len 0) - `(quote ,(bytevector)) - (list-bind #f (e*) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-bytevector) len))]) - `(seq - (set! ,(%mref ,t ,(constant bytevector-type-disp)) - (immediate ,(+ (* len (constant bytevector-length-factor)) - (constant type-bytevector)))) - ; build and store k-octet (k = 4 on 32-bit machines, k = 8 on 64-bit - ; machines) chunks, taking endianness into account. for the last - ; chunk, set k = 1, 2, 4, or 8 depending on the number of octets - ; remaining, padding with zeros as necessary. - ,(let f ([e* e*] [n (length e*)] [offset (constant bytevector-data-disp)]) - (let-values ([(k type) (find-k n)]) - `(seq - (inline ,(make-info-load type #f) ,%store ,t ,%zero (immediate ,offset) - ,(build-chunk k n e*)) - ,(if (fx<= n k) - t - (f (list-tail e* k) (fx- n k) (fx+ offset k))))))))))))) - - (define-inline 2 bytevector - [e* (and (andmap - (lambda (x) - (constant? - (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) - x)) - e*) - (build-bytevector e*))]) - - (define-inline 3 bytevector - [e* (build-bytevector e*)])) - - (let () - (define byte-offset - (lambda (off) - (cond - [(nanopass-case (L7 Expr) off - [(quote ,d) - (and (and (integer? d) (exact? d)) - (let ([n (+ d (constant bytevector-data-disp))]) - (and (target-fixnum? n) - `(quote ,n))))] - [else #f])] - [else (%inline + ,off - (quote ,(constant bytevector-data-disp)))]))) - - (define-inline 3 bytevector-copy! - [(bv1 off1 bv2 off2 n) - (%primcall src sexpr $byte-copy! ,bv1 ,(byte-offset off1) ,bv2 ,(byte-offset off2) ,n)])) - - (define-inline 3 bytevector-truncate! - [(bv len) - (if (fixnum-constant? len) - (let ([len (constant-value len)]) - (if (fx= len 0) - `(quote ,(bytevector)) - (bind #t (bv) - `(seq - (set! ,(%mref ,bv ,(constant bytevector-type-disp)) - (immediate ,(fx+ (fx* len (constant bytevector-length-factor)) - (constant type-bytevector)))) - ,bv)))) - (bind #t (bv len) - `(if ,(%inline eq? ,len (immediate 0)) - (quote ,(bytevector)) - (seq - (set! ,(%mref ,bv ,(constant bytevector-type-disp)) - ,(build-type/length len - (constant type-bytevector) - (constant fixnum-offset) - (constant bytevector-length-offset))) - ,bv))))]) - - (define-inline 3 $bytevector-set-immutable! - [(bv) ((build-set-immutable! bytevector-type-disp bytevector-immutable-flag) bv)]) - - (let () - (define bv-index-offset - (lambda (offset-expr) - (if (fixnum-constant? offset-expr) - (values %zero (+ (constant bytevector-data-disp) (constant-value offset-expr))) - (values (build-unfix offset-expr) (constant bytevector-data-disp))))) - - (define bv-offset-okay? - (lambda (x mask) - (constant? (lambda (x) (and (target-fixnum? x) (>= x 0) (eq? (logand x mask) 0))) x))) - - (let () - (define-syntax define-bv-8-inline - (syntax-rules () - [(_ name type) - (define-inline 2 name - [(e-bv e-offset) - (bind #t (e-bv e-offset) - `(if ,(handle-prim #f #f 3 '$bytevector-ref-check? (list `(quote 8) e-bv e-offset)) - ,(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref #f 'type e-bv e-index imm-offset)) - ,(build-libcall #t src sexpr name e-bv e-offset)))])])) - - (define-bv-8-inline bytevector-s8-ref integer-8) - (define-bv-8-inline bytevector-u8-ref unsigned-8)) - - (let () - (define-syntax define-bv-native-ref-inline - (lambda (x) - (syntax-case x () - [(_ name type) - #'(define-inline 3 name - [(e-bv e-offset) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref #f 'type e-bv e-index imm-offset))])]))) - - (define-bv-native-ref-inline bytevector-s8-ref integer-8) - (define-bv-native-ref-inline bytevector-u8-ref unsigned-8) - - (define-bv-native-ref-inline bytevector-s16-native-ref integer-16) - (define-bv-native-ref-inline bytevector-u16-native-ref unsigned-16) - - (define-bv-native-ref-inline bytevector-s32-native-ref integer-32) - (define-bv-native-ref-inline bytevector-u32-native-ref unsigned-32) - - (define-bv-native-ref-inline bytevector-s64-native-ref integer-64) - (define-bv-native-ref-inline bytevector-u64-native-ref unsigned-64) - - (define-bv-native-ref-inline bytevector-ieee-single-native-ref single-float) - (define-bv-native-ref-inline bytevector-ieee-double-native-ref double-float) - - ;; Inline to enable unboxing: - (define-inline 2 bytevector-ieee-double-native-ref - [(e-bv e-offset) - (bind #t (e-bv e-offset) - (let ([info (make-info-call #f #f #f #f #f)]) - `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-ref-check?) (quote 64) ,e-bv ,e-offset) - (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-ref) ,e-bv ,e-offset) - ,(build-libcall #t src sexpr bytevector-ieee-double-native-ref e-bv e-offset))))])) - - (let () - (define-syntax define-bv-native-int-set!-inline - (lambda (x) - (syntax-case x () - [(_ check-64? name type) - (with-syntax ([body #'(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-set! 'type e-bv e-index imm-offset e-val))]) - (with-syntax ([body (if (datum check-64?) - #'(and (>= (constant ptr-bits) 64) body) - #'body)]) - #'(define-inline 3 name - [(e-bv e-offset e-val) body])))]))) - - (define-bv-native-int-set!-inline #f bytevector-s8-set! integer-8) - (define-bv-native-int-set!-inline #f bytevector-u8-set! unsigned-8) - (define-bv-native-int-set!-inline #f $bytevector-set! unsigned-8) - - (define-bv-native-int-set!-inline #f bytevector-s16-native-set! integer-16) - (define-bv-native-int-set!-inline #f bytevector-u16-native-set! unsigned-16) - - (define-bv-native-int-set!-inline #f bytevector-s32-native-set! integer-32) - (define-bv-native-int-set!-inline #f bytevector-u32-native-set! unsigned-32) - - (define-bv-native-int-set!-inline #t bytevector-s64-native-set! integer-64) - (define-bv-native-int-set!-inline #t bytevector-u64-native-set! unsigned-64)) - - (let () - (define-syntax define-bv-native-ieee-set!-inline - (lambda (x) - (syntax-case x () - [(_ name type) - #'(define-inline 3 name - [(e-bv e-offset e-val) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (bind #f (e-bv e-index) - (build-object-set! 'type e-bv e-index imm-offset - (build-$real->flonum src sexpr e-val `(quote name)))))])]))) - - (define-bv-native-ieee-set!-inline bytevector-ieee-single-native-set! single-float) - (define-bv-native-ieee-set!-inline bytevector-ieee-double-native-set! double-float) - - ;; Inline to enable unboxing: - (define-inline 2 bytevector-ieee-double-native-set! - [(e-bv e-offset e-val) - (bind #t (e-bv e-offset) - (let ([info (make-info-call #f #f #f #f #f)]) - `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-set!-check?) (quote 64) ,e-bv ,e-offset) - ;; checks to make sure e-val produces a real number: - (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-set!) ,e-bv ,e-offset ,e-val) - ,(build-libcall #t src sexpr bytevector-ieee-double-native-set! e-bv e-offset))))])) - - (let () - (define-syntax define-bv-int-ref-inline - (lambda (x) - (define p2? - (lambda (n) - (let f ([i 1]) - (or (fx= i n) - (and (not (fx> i n)) (f (fxsll i 1))))))) - (syntax-case x () - [(_ name type mask) - #`(define-inline 3 name - [(e-bv e-offset e-eness) - (and (or (constant unaligned-integers) - (and #,(p2? (fx+ (datum mask) 1)) (bv-offset-okay? e-offset mask))) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) - 'type e-bv e-index imm-offset)))])]))) - - (define-bv-int-ref-inline bytevector-s16-ref integer-16 1) - (define-bv-int-ref-inline bytevector-u16-ref unsigned-16 1) - - (when-known-endianness - (define-bv-int-ref-inline bytevector-s24-ref integer-24 1) - (define-bv-int-ref-inline bytevector-u24-ref unsigned-24 1)) - - (define-bv-int-ref-inline bytevector-s32-ref integer-32 3) - (define-bv-int-ref-inline bytevector-u32-ref unsigned-32 3) - - (when-known-endianness - (define-bv-int-ref-inline bytevector-s40-ref integer-40 3) - (define-bv-int-ref-inline bytevector-u40-ref unsigned-40 3) - - (define-bv-int-ref-inline bytevector-s48-ref integer-48 3) - (define-bv-int-ref-inline bytevector-u48-ref unsigned-48 3) - - (define-bv-int-ref-inline bytevector-s56-ref integer-56 7) - (define-bv-int-ref-inline bytevector-u56-ref unsigned-56 7)) - - (define-bv-int-ref-inline bytevector-s64-ref integer-64 7) - (define-bv-int-ref-inline bytevector-u64-ref unsigned-64 7)) - - (let () - (define-syntax define-bv-ieee-ref-inline - (lambda (x) - (syntax-case x () - [(_ name type mask) - #'(define-inline 3 name - [(e-bv e-offset e-eness) - (and (or (constant unaligned-floats) - (bv-offset-okay? e-offset mask)) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref #f 'type e-bv e-index imm-offset)))])]))) - - (define-bv-ieee-ref-inline bytevector-ieee-single-ref single-float 3) - (define-bv-ieee-ref-inline bytevector-ieee-double-ref double-float 7)) - - (let () - (define-syntax define-bv-int-set!-inline - (lambda (x) - (syntax-case x () - [(_ check-64? name type mask) - (with-syntax ([body #'(and (or (constant unaligned-integers) - (and mask (bv-offset-okay? e-offset mask))) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (if (eq? (constant-value e-eness) (constant native-endianness)) - (build-object-set! 'type e-bv e-index imm-offset e-value) - (build-swap-object-set! 'type e-bv e-index imm-offset e-value))))]) - (with-syntax ([body (if (datum check-64?) - #'(and (>= (constant ptr-bits) 64) body) - #'body)]) - #'(define-inline 3 name - [(e-bv e-offset e-value e-eness) body])))]))) - - (define-bv-int-set!-inline #f bytevector-s16-set! integer-16 1) - (define-bv-int-set!-inline #f bytevector-u16-set! unsigned-16 1) - - (define-bv-int-set!-inline #f bytevector-s24-set! integer-24 #f) - (define-bv-int-set!-inline #f bytevector-u24-set! unsigned-24 #f) - - (define-bv-int-set!-inline #f bytevector-s32-set! integer-32 3) - (define-bv-int-set!-inline #f bytevector-u32-set! unsigned-32 3) - - (define-bv-int-set!-inline #t bytevector-s40-set! integer-40 #f) - (define-bv-int-set!-inline #t bytevector-u40-set! unsigned-40 #f) - - (define-bv-int-set!-inline #t bytevector-s48-set! integer-48 #f) - (define-bv-int-set!-inline #t bytevector-u48-set! unsigned-48 #f) - - (define-bv-int-set!-inline #t bytevector-s56-set! integer-56 #f) - (define-bv-int-set!-inline #t bytevector-u56-set! unsigned-56 #f) - - (define-bv-int-set!-inline #t bytevector-s64-set! integer-64 7) - (define-bv-int-set!-inline #t bytevector-u64-set! unsigned-64 7)) - - (let () - (define-syntax define-bv-ieee-set!-inline - (lambda (x) - (syntax-case x () - [(_ name type mask) - #'(define-inline 3 name - [(e-bv e-offset e-value e-eness) - (and (or (constant unaligned-floats) (bv-offset-okay? e-offset mask)) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (bind #f (e-bv e-index) - (build-object-set! 'type e-bv e-index imm-offset - (build-$real->flonum src sexpr e-value - `(quote name))))))])]))) - - (define-bv-ieee-set!-inline bytevector-ieee-single-set! single-float 3) - (define-bv-ieee-set!-inline bytevector-ieee-double-set! double-float 7)) - - (let () - (define anyint-ref-helper - (lambda (type mask e-bv e-offset e-eness) - (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) - type e-bv e-index imm-offset))))) - (define-syntax define-bv-anyint-ref-inline - (syntax-rules () - [(_ name type8 type16 type32 type64) - (define-inline 3 name - [(e-bv e-offset e-eness e-size) - (and (fixnum-constant? e-size) - (case (constant-value e-size) - [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - `(seq - ,e-eness - ,(build-object-ref #f 'type8 e-bv e-index imm-offset)))] - [(2) (anyint-ref-helper 'type16 #b1 e-bv e-offset e-eness)] - [(4) (anyint-ref-helper 'type32 #b11 e-bv e-offset e-eness)] - [(8) (anyint-ref-helper 'type64 #b111 e-bv e-offset e-eness)] - [else #f]))])])) - - (define-bv-anyint-ref-inline bytevector-sint-ref - integer-8 integer-16 integer-32 integer-64) - (define-bv-anyint-ref-inline bytevector-uint-ref - unsigned-8 unsigned-16 unsigned-32 unsigned-64)) - - (let () - (define anyint-set!-helper - (lambda (type mask e-bv e-offset e-value e-eness) - (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) - (safe-assert (not (eq? (constant native-endianness) 'unknown))) - (constant? (lambda (x) (memq x '(big little))) e-eness) - (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - (if (eq? (constant-value e-eness) (constant native-endianness)) - (build-object-set! type e-bv e-index imm-offset e-value) - (build-swap-object-set! type e-bv e-index imm-offset e-value)))))) - (define-syntax define-bv-anyint-set!-inline - (syntax-rules () - [(_ name type8 type16 type32 type64) - (define-inline 3 name - [(e-bv e-offset e-value e-eness e-size) - (and (fixnum-constant? e-size) - (case (constant-value e-size) - [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) - `(seq - ,e-eness - ,(build-object-set! 'type8 e-bv e-index imm-offset e-value)))] - [(2) (anyint-set!-helper 'type16 1 e-bv e-offset e-value e-eness)] - [(4) (anyint-set!-helper 'type32 3 e-bv e-offset e-value e-eness)] - [(8) (and (>= (constant ptr-bits) 64) - (anyint-set!-helper 'type64 7 e-bv e-offset e-value e-eness))] - [else #f]))])])) - - (define-bv-anyint-set!-inline bytevector-sint-set! - integer-8 integer-16 integer-32 integer-64) - (define-bv-anyint-set!-inline bytevector-uint-set! - unsigned-8 unsigned-16 unsigned-32 unsigned-64))) - - (let () - (define (byte-count e-n) - (or (nanopass-case (L7 Expr) e-n - [(quote ,d) - (and (and (integer? d) (exact? d)) - (let ([n (* d (constant string-char-bytes))]) - (and (target-fixnum? n) - `(immediate ,(fix n)))))] - [else #f]) - (%inline sll ,e-n ,(%constant string-char-offset)))) - (define byte-offset - (lambda (e-off) - (or (nanopass-case (L7 Expr) e-off - [(quote ,d) - (and (and (integer? d) (exact? d)) - (let ([n (+ (* d (constant string-char-bytes)) - (constant string-data-disp))]) - (and (target-fixnum? n) - `(immediate ,(fix n)))))] - [else #f]) - (%inline + - ,(%inline sll ,e-off ,(%constant string-char-offset)) - (immediate ,(fix (constant string-data-disp))))))) - (define-inline 3 string-copy! - [(e-bv1 e-off1 e-bv2 e-off2 e-n) - (%primcall src sexpr $byte-copy! ,e-bv1 ,(byte-offset e-off1) ,e-bv2 ,(byte-offset e-off2) ,(byte-count e-n))])) - - (define-inline 3 string-truncate! - [(e-str e-len) - (if (fixnum-constant? e-len) - (let ([len (constant-value e-len)]) - (if (fx= len 0) - `(quote ,(string)) - (bind #t (e-str) - `(seq - (set! ,(%mref ,e-str ,(constant string-type-disp)) - (immediate ,(fx+ (fx* len (constant string-length-factor)) - (constant type-string)))) - ,e-str)))) - (bind #t (e-str e-len) - `(if ,(%inline eq? ,e-len (immediate 0)) - (quote ,(string)) - (seq - (set! ,(%mref ,e-str ,(constant string-type-disp)) - ,(build-type/length e-len - (constant type-string) - (constant fixnum-offset) - (constant string-length-offset))) - ,e-str))))]) - - (let () - (define build-string-fill - (make-build-fill (constant string-char-bytes) (constant string-data-disp))) - (let () - (define do-make-string - (lambda (e-length e-fill) - ; NB: caller must bind e-fill - (safe-assert (no-need-to-bind? #f e-fill)) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(string)) - (let ([bytes (fx* n (constant string-char-bytes))]) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-string) bytes))]) - `(seq - (set! ,(%mref ,t ,(constant string-type-disp)) - (immediate ,(fx+ (fx* n (constant string-length-factor)) - (constant type-string)))) - ,(build-string-fill t `(immediate ,bytes) e-fill)))))) - (bind #t (e-length) - (let ([t-bytes (make-tmp 'tsize 'uptr)] [t-str (make-tmp 'tstr)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(string)) - (let ([,t-bytes ,(translate e-length - (constant fixnum-offset) - (constant string-char-offset))]) - (let ([,t-str (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,t-bytes - (immediate ,(fx+ (constant header-size-string) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-str ,(constant string-type-disp)) - ,(build-type/length t-bytes - (constant type-string) - (constant string-char-offset) - (constant string-length-offset))) - ,(build-string-fill t-str t-bytes e-fill)))))))))) - (define default-fill `(immediate ,(ptr->imm #\nul))) - (define-inline 3 make-string - [(e-length) (do-make-string e-length default-fill)] - [(e-length e-fill) (bind #t (e-fill) (do-make-string e-length e-fill))]) - (let () - (define (valid-length? e-length) - (constant? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= 0 x (constant maximum-string-length)))) - e-length)) - (define-inline 2 make-string - [(e-length) - (and (valid-length? e-length) - (do-make-string e-length default-fill))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? char? e-fill) - (do-make-string e-length e-fill))]))) - (define-inline 3 string-fill! - [(e-str e-fill) - `(seq - ,(bind #t (e-str e-fill) - (build-string-fill e-str - (translate - (%inline logxor - ,(%mref ,e-str ,(constant string-type-disp)) - ,(%constant type-string)) - (constant string-length-offset) - (constant string-char-offset)) - e-fill)) - ,(%constant svoid))]) - (define-inline 2 string->immutable-string - [(e-str) - (nanopass-case (L7 Expr) e-str - [(quote ,d) - (guard (string? d) (= 0 (string-length d))) - `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-string) 0))] - [else #f])])) - - (let () - (define build-fxvector-fill - (make-build-fill (constant ptr-bytes) (constant fxvector-data-disp))) - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (let () - (define do-make-fxvector - (lambda (e-length e-fill) - ; NB: caller must bind e-fill - (safe-assert (no-need-to-bind? #f e-fill)) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(fxvector)) - (let ([bytes (fx* n (constant ptr-bytes))]) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-fxvector) bytes))]) - `(seq - (set! ,(%mref ,t ,(constant fxvector-type-disp)) - (immediate ,(fx+ (fx* n (constant fxvector-length-factor)) - (constant type-fxvector)))) - ,(build-fxvector-fill t `(immediate ,bytes) e-fill)))))) - (bind #t (e-length) ; fixnum length doubles as byte count - (let ([t-fxv (make-tmp 'tfxv)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(fxvector)) - (let ([,t-fxv (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,e-length - (immediate ,(fx+ (constant header-size-fxvector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-fxv ,(constant fxvector-type-disp)) - ,(build-type/length e-length - (constant type-fxvector) - (constant fixnum-offset) - (constant fxvector-length-offset))) - ,(build-fxvector-fill t-fxv e-length e-fill))))))))) - (define default-fill `(immediate ,(fix 0))) - (define-inline 3 make-fxvector - [(e-length) (do-make-fxvector e-length default-fill)] - [(e-length e-fill) (bind #t (e-fill) (do-make-fxvector e-length e-fill))]) - (let () - (define (valid-length? e-length) - (constant? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= 0 x (constant maximum-fxvector-length)))) - e-length)) - (define-inline 2 make-fxvector - [(e-length) - (and (valid-length? e-length) - (do-make-fxvector e-length default-fill))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? fixnum? e-fill) - (do-make-fxvector e-length e-fill))]))) - (define-inline 3 fxvector-fill! - [(e-fxv e-fill) - `(seq - ,(bind #t (e-fxv e-fill) - (build-fxvector-fill e-fxv - (translate - (%inline logxor - ,(%mref ,e-fxv ,(constant fxvector-type-disp)) - ,(%constant type-fxvector)) - (constant fxvector-length-offset) - (constant fixnum-offset)) - e-fill)) - ,(%constant svoid))])) - - (let () - ;; Used only to fill with 0s: - (define build-flvector-fill - (make-build-fill (constant ptr-bytes) (constant flvector-data-disp))) - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (let () - (define do-make-flvector - (lambda (e-length) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(flvector)) - (let ([bytes (fx* n (constant flonum-bytes))]) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-flvector) bytes))]) - `(seq - (set! ,(%mref ,t ,(constant flvector-type-disp)) - (immediate ,(fx+ (fx* n (constant flvector-length-factor)) - (constant type-flvector)))) - ,(build-flvector-fill t `(immediate ,bytes) `(immediate 0))))))) - (bind #t (e-length) ; fixnum length doubles as byte count - (let ([t-fxv (make-tmp 'tfxv)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(flvector)) - (let ([,t-fxv (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,(build-double-scale e-length) - (immediate ,(fx+ (constant header-size-flvector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-fxv ,(constant flvector-type-disp)) - ,(build-type/length e-length - (constant type-flvector) - (constant fixnum-offset) - (constant flvector-length-offset))) - ,(build-flvector-fill t-fxv (build-double-scale e-length) `(immediate 0)))))))))) - (define-inline 3 make-flvector - [(e-length) (do-make-flvector e-length)] - [(e-length e-init) #f]) - (let () - (define (valid-length? e-length) - (constant? - (lambda (x) - (and (or (fixnum? x) (bignum? x)) - (<= 0 x (constant maximum-flvector-length)))) - e-length)) - (define-inline 2 make-flvector - [(e-length) - (and (valid-length? e-length) - (do-make-flvector e-length))] - [(e-length e-init) #f])))) - - (let () - (define build-vector-fill - (make-build-fill (constant ptr-bytes) (constant vector-data-disp))) - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (let () - (define do-make-vector - (lambda (e-length e-fill) - ; NB: caller must bind e-fill - (safe-assert (no-need-to-bind? #f e-fill)) - (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) - (let ([n (constant-value e-length)]) - (if (fx= n 0) - `(quote ,(vector)) - (let ([bytes (fx* n (constant ptr-bytes))]) - (bind #t ([t (%constant-alloc type-typed-object - (fx+ (constant header-size-vector) bytes))]) - `(seq - (set! ,(%mref ,t ,(constant vector-type-disp)) - (immediate ,(+ (fx* n (constant vector-length-factor)) - (constant type-vector)))) - ,(build-vector-fill t `(immediate ,bytes) e-fill)))))) - (bind #t (e-length) ; fixnum length doubles as byte count - (let ([t-vec (make-tmp 'tvec)]) - `(if ,(%inline eq? ,e-length (immediate 0)) - (quote ,(vector)) - (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,e-length - (immediate ,(fx+ (constant header-size-vector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-vec ,(constant vector-type-disp)) - ,(build-type/length e-length - (constant type-vector) - (constant fixnum-offset) - (constant vector-length-offset))) - ,(build-vector-fill t-vec e-length e-fill))))))))) - (define default-fill `(immediate ,(fix 0))) - (define-inline 3 make-vector - [(e-length) (do-make-vector e-length default-fill)] - [(e-length e-fill) (bind #t (e-fill) (do-make-vector e-length e-fill))]) - (let () - (define (valid-length? e-length) - (constant? - (lambda (x) (and (target-fixnum? x) (>= x 0))) - e-length)) - (define-inline 2 make-vector - [(e-length) - (and (valid-length? e-length) - (do-make-vector e-length default-fill))] - [(e-length e-fill) - (and (valid-length? e-length) - (constant? fixnum? e-fill) - (do-make-vector e-length e-fill))])) - (define-inline 2 vector->immutable-vector - [(e-vec) - (nanopass-case (L7 Expr) e-vec - [(quote ,d) - (guard (vector? d) (fx= 0 (vector-length d))) - `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-vector) 0))] - [else #f])]))) - - (let () - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (let () - (define build-stencil-vector-type - (lambda (e-mask) ; e-mask is used only once - (%inline logor - (immediate ,(constant type-stencil-vector)) - ,(%inline sll ,e-mask (immediate ,(fx- (constant stencil-vector-mask-offset) - (constant fixnum-offset))))))) - (define do-stencil-vector - (lambda (e-mask e-val*) - (list-bind #f (e-val*) - (bind #f (e-mask) - (let ([t-vec (make-tmp 'tvec)]) - `(let ([,t-vec ,(%constant-alloc type-typed-object - (fx+ (constant header-size-stencil-vector) - (fx* (length e-val*) (constant ptr-bytes))))]) - ,(let loop ([e-val* e-val*] [i 0]) - (if (null? e-val*) - `(seq - (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) - ,(build-stencil-vector-type e-mask)) - ,t-vec) - `(seq - (set! ,(%mref ,t-vec ,(fx+ i (constant stencil-vector-data-disp))) ,(car e-val*)) - ,(loop (cdr e-val*) (fx+ i (constant ptr-bytes)))))))))))) - (define do-make-stencil-vector - (lambda (e-length e-mask) - (bind #t (e-length) - (bind #f (e-mask) - (let ([t-vec (make-tmp 'tvec)]) - `(let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,e-length - (immediate ,(fx+ (constant header-size-stencil-vector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - ,(%seq - (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) - ,(build-stencil-vector-type e-mask)) - ;; Content not filled! This function is meant to be called by - ;; `$stencil-vector-update`, which has GC disabled between - ;; allocation and filling in the data - ,t-vec))))))) - (define-inline 3 stencil-vector - [(e-mask . e-val*) - (do-stencil-vector e-mask e-val*)]) - (define-inline 2 $make-stencil-vector - [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) - (define-inline 3 $make-stencil-vector - [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) - (define-inline 3 stencil-vector-update - [(e-vec e-sub-mask e-add-mask . e-val*) - `(call ,(make-info-call src sexpr #f #f #f) #f - ,(lookup-primref 3 '$stencil-vector-update) - ,e-vec ,e-sub-mask ,e-add-mask ,e-val* ...)]) - (define-inline 3 stencil-vector-truncate! - [(e-vec e-mask) - (bind #f (e-vec e-mask) - `(seq - (set! ,(%mref ,e-vec ,(constant stencil-vector-type-disp)) - ,(build-stencil-vector-type e-mask)) - ,(%constant svoid)))]))) - (let () - (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) - (define-inline 3 $make-eqhash-vector - [(e-length) - (let ([t-vec (make-tmp 'tvec)] - [t-idx (make-assigned-tmp 't-idx)] - [Ltop (make-local-label 'Ltop)]) - `(let ([,t-idx ,e-length]) - (if ,(%inline eq? ,t-idx (immediate 0)) - (quote ,(vector)) - (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) - ,(%inline logand - ,(%inline + ,t-idx - (immediate ,(fx+ (constant header-size-vector) - (fx- (constant byte-alignment) 1)))) - (immediate ,(- (constant byte-alignment)))))]) - (seq - (set! ,(%mref ,t-vec ,(constant vector-type-disp)) - ,(build-type/length t-idx - (constant type-vector) - (constant fixnum-offset) - (constant vector-length-offset))) - (label ,Ltop - ,(%seq - (set! ,t-idx ,(%inline - ,t-idx (immediate ,(fix 1)))) - (set! ,(%mref ,t-vec ,t-idx ,(constant vector-data-disp)) ,t-idx) - (if ,(%inline eq? ,t-idx (immediate 0)) - ,t-vec - (goto ,Ltop)))))))))])) - - (let () - (define build-continuation?-test - (lambda (e) ; e must be bound - (build-and - (%type-check mask-closure type-closure ,e) - (%type-check mask-continuation-code type-continuation-code - ,(%mref - ,(%inline - - ,(%mref ,e ,(constant closure-code-disp)) - ,(%constant code-data-disp)) - ,(constant code-type-disp)))))) - (define-inline 2 $continuation? - [(e) (bind #t (e) - (build-continuation?-test e))]) - (define-inline 2 $assert-continuation - [(e) (bind #t (e) - `(if ,(build-and - (build-continuation?-test e) - (%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders))) - ,(%constant svoid) - ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] - [(e1 e2) (bind #t (e1 e2) - `(if ,(build-and - (build-continuation?-test e1) - (build-and - (%inline eq? ,(%mref ,e1 ,(constant continuation-winders-disp)) ,(%tc-ref winders)) - (build-simple-or - (%inline eq? ,e2 ,(%mref ,e1 ,(constant continuation-attachments-disp))) - (build-and - (%type-check mask-pair type-pair ,e2) - (%inline eq? ,(%mref ,e2 ,(constant pair-cdr-disp)) ,(%mref ,e1 ,(constant continuation-attachments-disp))))))) - ,(%constant svoid) - ,(build-libcall #t src sexpr $check-continuation e1 (%constant strue) e2)))]) - (define-inline 3 $assert-continuation - [(e) (bind #t (e) - `(if ,(%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders)) - ,(%constant svoid) - ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] - [(e1 e2) #f])) - - (define-inline 3 $continuation-stack-length - [(e) - (translate (%mref ,e ,(constant continuation-stack-length-disp)) - (constant fixnum-offset) - (constant log2-ptr-bytes))]) - (define-inline 3 $continuation-stack-clength - [(e) - (translate (%mref ,e ,(constant continuation-stack-clength-disp)) - (constant fixnum-offset) - (constant log2-ptr-bytes))]) - (let () - (define (build-ra e) - (%mref ,e ,(constant continuation-return-address-disp))) - (define (build-stack-ra e-k e-i) - (%mref ,(%mref ,e-k ,(constant continuation-stack-disp)) - ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) - 0)) - - (define build-return-code - (lambda (e-ra) - (bind #t ([ra e-ra]) - (bind #t ([t `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ,(%inline + ,ra ,(%constant compact-return-address-toplink-disp)) - ,(%inline + ,ra ,(%constant return-address-toplink-disp)))]) - (%inline - ,t ,(%mref ,t 0)))))) - (define build-return-offset - (lambda (e-ra) - (bind #t ([ra e-ra]) - (build-fix - `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) - ,(%constant compact-header-mask)) - ,(%inline - ,(%mref ,ra ,(constant compact-return-address-toplink-disp)) - ,(%constant compact-return-address-toplink-disp)) - ,(%inline - ,(%mref ,ra ,(constant return-address-toplink-disp)) - ,(%constant return-address-toplink-disp))))))) - (define build-return-livemask - (lambda (e-ra) - (bind #t ([ra e-ra]) - (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) - `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) - ,(%inline sll ,(%inline srl ,mask+size+mode ,(%constant compact-frame-mask-offset)) - ,(%constant fixnum-offset)) - ,(%mref ,ra ,(constant return-address-livemask-disp))))))) - (define build-return-frame-words - (lambda (e-ra) - (bind #t ([ra e-ra]) - (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) - `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) - ,(%inline sll ,(%inline logand ,(%inline srl ,mask+size+mode ,(%constant compact-frame-words-offset)) - ,(%constant compact-frame-words-mask)) - ,(%constant fixnum-offset)) - ,(%mref ,ra ,(constant return-address-frame-size-disp))))))) - - (define-inline 3 $continuation-return-code - [(e) (build-return-code (build-ra e))]) - (define-inline 3 $continuation-return-offset - [(e) (build-return-offset (build-ra e))]) - (define-inline 3 $continuation-return-livemask - [(e) (build-return-livemask (build-ra e))]) - (define-inline 3 $continuation-return-frame-words - [(e) (build-return-frame-words (build-ra e))]) - (define-inline 3 $continuation-stack-ref - [(e-k e-i) - (%mref - ,(%mref ,e-k ,(constant continuation-stack-disp)) - ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) - 0)]) - (define-inline 3 $continuation-stack-return-code - [(e-k e-i) (build-return-code (build-stack-ra e-k e-i))]) - (define-inline 3 $continuation-stack-return-offset - [(e-k e-i) (build-return-offset (build-stack-ra e-k e-i))]) - (define-inline 3 $continuation-stack-return-frame-words - [(e-k e-i) (build-return-frame-words (build-stack-ra e-k e-i))])) - - (define-inline 2 $foreign-char? - [(e) - (bind #t (e) - (build-and - (%type-check mask-char type-char ,e) - (%inline < ,e (immediate ,(ptr->imm (integer->char #x100))))))]) - (define-inline 2 $foreign-wchar? - [(e) - (constant-case wchar-bits - [(16) - (bind #t (e) - (build-and - (%type-check mask-char type-char ,e) - (%inline < ,e (immediate ,(ptr->imm (integer->char #x10000))))))] - [(32) (%type-check mask-char type-char ,e)])]) - (define-inline 2 $integer-8? - [(e) - (unless (fx>= (constant fixnum-bits) 8) ($oops '$integer-8? "unexpected fixnum-bits")) - (bind #t (e) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x80))) - (immediate ,(fix #x180)))))]) - (define-inline 2 $integer-16? - [(e) - (unless (fx>= (constant fixnum-bits) 16) ($oops '$integer-16? "unexpected fixnum-bits")) - (bind #t (e) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x8000))) - (immediate ,(fix #x18000)))))]) - (define-inline 2 $integer-24? - [(e) - (unless (fx>= (constant fixnum-bits) 24) ($oops '$integer-24? "unexpected fixnum-bits")) - (bind #t (e) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x800000))) - (immediate ,(fix #x1800000)))))]) - (define-inline 2 $integer-32? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x80000000))) - (immediate ,(fix #x180000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-80000000)))))))))]) - (define-inline 2 $integer-40? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x8000000000))) - (immediate ,(fix #x18000000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-8000000000)))))))))]) - (define-inline 2 $integer-48? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x800000000000))) - (immediate ,(fix #x1800000000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-800000000000)))))))))]) - (define-inline 2 $integer-56? - [(e) - (bind #t (e) - (if (fx>= (constant fixnum-bits) 32) - (build-and - (%type-check mask-fixnum type-fixnum ,e) - (%inline u< - ,(%inline + ,e (immediate ,(fix #x80000000000000))) - (immediate ,(fix #x180000000000000)))) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-80000000000000)))))))))]) - (define-inline 2 $integer-64? - [(e) - (when (fx>= (constant fixnum-bits) 64) ($oops '$integer-64? "unexpected fixnum-bits")) - (bind #t (e) - (build-simple-or - (%type-check mask-fixnum type-fixnum ,e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) - `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) - ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffffff)) - ,(build-and - (%type-check mask-signed-bignum type-negative-bignum ,t) - (build-libcall #f #f sexpr >= e `(quote #x-8000000000000000))))))))]) - (define-inline 3 char->integer - ; assumes types are set up so that fixnum tag will be right after the shift - [(e-char) (build-char->integer e-char)]) - (define-inline 2 char->integer - ; assumes types are set up so that fixnum tag will be right after the shift - [(e-char) - (bind #t (e-char) - `(if ,(%type-check mask-char type-char ,e-char) - ,(%inline srl ,e-char - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) - ,(build-libcall #t src sexpr char->integer e-char)))]) - (define-inline 3 char- - ; assumes fixnum is zero - [(e1 e2) - (%inline srl - ,(%inline - ,e1 ,e2) - (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset))))]) - (define-inline 3 integer->char - [(e-int) (build-integer->char e-int)]) - (define-inline 3 boolean=? - [(e1 e2) (%inline eq? ,e1 ,e2)] - [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) - (define-inline 3 symbol=? - [(e1 e2) (%inline eq? ,e1 ,e2)] - [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) - (let () - (define (go e flag) - (%inline logtest - ,(%mref ,e ,(constant record-type-flags-disp)) - (immediate ,(fix flag)))) - (define-inline 3 record-type-opaque? - [(e) (go e (constant rtd-opaque))]) - (define-inline 3 record-type-sealed? - [(e) (go e (constant rtd-sealed))]) - (define-inline 3 $record-type-act-sealed? - [(e) (go e (fxior (constant rtd-sealed) (constant rtd-act-sealed)))]) - (define-inline 3 record-type-generative? - [(e) (go e (constant rtd-generative))])) - (let () - (define build-record? - (lambda (e) - (bind #t (e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - (bind #t ([t (%mref ,e ,(constant typed-object-type-disp))]) - (build-and - (%type-check mask-record type-record ,t) - (build-not - (%inline logtest - ,(%mref ,t ,(constant record-type-flags-disp)) - (immediate ,(fix (constant rtd-opaque))))))))))) - (define build-sealed-isa? - (lambda (e e-rtd assume-record?) - (bind #t (e) - (bind #f (e-rtd) - (maybe-build-and - (and (not assume-record?) - (%type-check mask-typed-object type-typed-object ,e)) - (%inline eq? - ,(%mref ,e ,(constant typed-object-type-disp)) - ,e-rtd)))))) - (define build-unsealed-isa? - (lambda (e e-rtd assume-record?) - (let ([known-depth (nanopass-case (L7 Expr) e-rtd - [(quote ,d) (and (record-type-descriptor? d) - (vector-length (rtd-ancestors d)))] - [else #f])]) - ;; `t` is rtd of `e`, and it's used once - (define (compare-at-depth t known-depth) - (cond - [(eqv? known-depth (constant minimum-ancestry-vector-length)) - ;; no need to check ancestry array length - (%inline eq? ,e-rtd ,(%mref ,(%mref ,t ,(constant record-type-ancestry-disp)) - ,(fx+ (constant vector-data-disp) - (fx* (fx- known-depth 1) (constant ptr-bytes)))))] - [known-depth - ;; need to check ancestry array length - (let ([a (make-tmp 'a)]) - `(let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))]) - (if ,(%inline <= - (immediate ,(fxsll known-depth (constant vector-length-offset))) - ,(%mref ,a ,(constant vector-type-disp))) - ,(%inline eq? ,e-rtd ,(%mref ,a ,(fx+ (constant vector-data-disp) - (fx* (fx- known-depth 1) (constant ptr-bytes))))) - ,(%constant sfalse))))] - [else - (bind #t (e-rtd) - (let ([a (make-tmp 'a)] [rtd-a (make-tmp 'rtd-a)] [rtd-len (make-tmp 'rtd-len)]) - `(let ([,rtd-a ,(%mref ,e-rtd ,(constant record-type-ancestry-disp))]) - (let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))]) - (let ([,rtd-len ,(%mref ,rtd-a ,(constant vector-type-disp))]) - (if ,(%inline <= ,rtd-len ,(%mref ,a ,(constant vector-type-disp))) - ,(begin - ;; take advantage of being able to use the type field of a vector - ;; as a pointer offset with just shifting: - (safe-assert (zero? (constant type-vector))) - (%inline eq? ,e-rtd ,(%mref ,a - ,(translate rtd-len (constant vector-length-offset) (constant log2-ptr-bytes)) - ,(fx- (constant vector-data-disp) (constant ptr-bytes))))) - ,(%constant sfalse)))))))])) - (cond - [assume-record? - (compare-at-depth (%mref ,e ,(constant typed-object-type-disp)) known-depth)] - [else - (let ([t (make-tmp 't)]) - (bind #t (e) - (build-and - (%type-check mask-typed-object type-typed-object ,e) - `(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))]) - ,(build-and - (%type-check mask-record type-record ,t) - (compare-at-depth t known-depth))))))])))) - (define-inline 3 record? - [(e) (build-record? e)] - [(e e-rtd) - (if (constant? (lambda (x) - (and (record-type-descriptor? x) - (record-type-sealed? x))) - e-rtd) - (build-sealed-isa? e e-rtd #f) - (build-unsealed-isa? e e-rtd #f))]) - (define-inline 3 record-instance? - [(e e-rtd) - (if (constant? (lambda (x) - (and (record-type-descriptor? x) - (record-type-sealed? x))) - e-rtd) - (build-sealed-isa? e e-rtd #t) - (build-unsealed-isa? e e-rtd #t))]) - (define-inline 2 r6rs:record? - [(e) (build-record? e)]) - (define-inline 2 record? - [(e) (build-record? e)] - [(e e-rtd) - (nanopass-case (L7 Expr) e-rtd - [(quote ,d) - (and (record-type-descriptor? d) - (if (record-type-sealed? d) - (build-sealed-isa? e e-rtd #f) - (build-unsealed-isa? e e-rtd #f)))] - [else #f])]) - (define-inline 2 $sealed-record? - [(e e-rtd) (build-sealed-isa? e e-rtd #f)]) - (define-inline 2 $sealed-record-instance? - [(e e-rtd) (build-sealed-isa? e e-rtd #t)]) - (define-inline 3 $record-type-field-count - [(e) (%inline srl ,(%inline - ,(%mref ,e ,(constant record-type-size-disp)) - (immediate ,(fxsll (fx- (constant record-data-disp) (constant record-type-disp)) - (constant fixnum-offset)))) - ,(%constant log2-ptr-bytes))]) - (define-inline 2 eq-hashtable? - [(e) (let ([rtd (let () (include "hashtable-types.ss") (record-type-descriptor eq-ht))]) - (let ([e-rtd `(quote ,rtd)]) - (if (record-type-sealed? rtd) - (build-sealed-isa? e e-rtd #f) - (build-unsealed-isa? e e-rtd #f))))])) - (define-inline 2 gensym? - [(e) - (bind #t (e) - (build-and - (%type-check mask-symbol type-symbol ,e) - (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) - `(if ,t - ,(build-and (%type-check mask-pair type-pair ,t) - (build-and (%mref ,t ,(constant pair-cdr-disp)) - (%constant strue))) - ,(%constant strue)))))]) - (define-inline 2 uninterned-symbol? - [(e) - (bind #t (e) - (build-and - (%type-check mask-symbol type-symbol ,e) - (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) - (build-and (%type-check mask-pair type-pair ,t) - (build-not (%mref ,t ,(constant pair-cdr-disp)))))))]) - (let () - (define build-make-symbol - (lambda (e-name) - (bind #t ([t (%constant-alloc type-symbol (constant size-symbol))]) - (%seq - (set! ,(%mref ,t ,(constant symbol-name-disp)) ,e-name) - (set! ,(%mref ,t ,(constant symbol-value-disp)) ,(%constant sunbound)) - (set! ,(%mref ,t ,(constant symbol-pvalue-disp)) - (literal - ,(make-info-literal #f 'library - (lookup-libspec nonprocedure-code) - (constant code-data-disp)))) - (set! ,(%mref ,t ,(constant symbol-plist-disp)) ,(%constant snil)) - (set! ,(%mref ,t ,(constant symbol-splist-disp)) ,(%constant snil)) - (set! ,(%mref ,t ,(constant symbol-hash-disp)) ,(%constant sfalse)) - ,t)))) - (define (go e-pname) - (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) - (%seq - (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e-pname) - (set! ,(%mref ,t ,(constant pair-car-disp)) ,(%constant sfalse)) - ,(build-make-symbol t)))) - (define-inline 3 $gensym - [() (build-make-symbol (%constant sfalse))] - [(e-pname) (bind #f (e-pname) (go e-pname))] - [(e-pname e-uname) #f]) - (define-inline 3 gensym - [() (build-make-symbol (%constant sfalse))] - [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] - [(e-pname e-uname) #f]) - (define-inline 2 gensym - [() (build-make-symbol (%constant sfalse))] - [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] - [(e-pname e-uname) #f])) - (define-inline 3 symbol->string - [(e-sym) - (bind #t (e-sym) - (bind #t ([e-name (%mref ,e-sym ,(constant symbol-name-disp))]) - `(if ,e-name - (if ,(%type-check mask-pair type-pair ,e-name) - ,(bind #t ([e-cdr (%mref ,e-name ,(constant pair-cdr-disp))]) - `(if ,e-cdr - ,e-cdr - ,(%mref ,e-name ,(constant pair-car-disp)))) - ,e-name) - ,(%primcall #f sexpr $gensym->pretty-name ,e-sym))))]) - (define-inline 3 $fxaddress - [(e) (%inline logand - ,(let ([n (- (log2 (constant typemod)) (constant fixnum-offset))]) - (if (> n 0) (%inline sra ,e (immediate ,n)) e)) - (immediate ,(- (constant fixnum-factor))))]) - (define-inline 3 $set-timer - [(e) (bind #f (e) - (bind #t ([t (build-fix (ref-reg %trap))]) - `(seq - (set! ,(ref-reg %trap) ,(build-unfix e)) - ,t)))]) - (define-inline 3 $get-timer - [() (build-fix (ref-reg %trap))]) - (define-inline 3 directory-separator? - [(e) (if-feature windows - (bind #t (e) - (build-simple-or - (%inline eq? ,e (immediate ,(ptr->imm #\/))) - (%inline eq? ,e (immediate ,(ptr->imm #\\))))) - (%inline eq? ,e (immediate ,(ptr->imm #\/))))]) - (let () - (define add-cdrs - (lambda (n e) - (if (fx= n 0) - e - (add-cdrs (fx- n 1) (%mref ,e ,(constant pair-cdr-disp)))))) - (define-inline 3 list-ref - [(e-ls e-n) - (nanopass-case (L7 Expr) e-n - [(quote ,d) - (and (and (fixnum? d) (fx< d 4)) - (%mref ,(add-cdrs d e-ls) ,(constant pair-car-disp)))] - [else #f])]) - (define-inline 3 list-tail - [(e-ls e-n) - (nanopass-case (L7 Expr) e-n - [(quote ,d) (and (and (fixnum? d) (fx<= d 4)) (add-cdrs d e-ls))] - [else #f])])) - (let () - (define (go0 src sexpr subtype) - (%primcall src sexpr $make-eq-hashtable - (immediate ,(fix (constant hashtable-default-size))) - (immediate ,(fix subtype)))) - (define (go1 src sexpr e-size subtype) - (nanopass-case (L7 Expr) e-size - [(quote ,d) - ; d must be a fixnum? for $hashtable-size-minlen and a - ; target-machine fixnum for cross compiling - (and (and (fixnum? d) (target-fixnum? d) (fx>= d 0)) - (%primcall src sexpr $make-eq-hashtable - (immediate ,(fix ($hashtable-size->minlen d))) - (immediate ,(fix subtype))))] - [else #f])) - (define-inline 3 make-eq-hashtable - [() (go0 src sexpr (constant eq-hashtable-subtype-normal))] - [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-normal))]) - (define-inline 3 make-weak-eq-hashtable - [() (go0 src sexpr (constant eq-hashtable-subtype-weak))] - [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-weak))]) - (define-inline 3 make-ephemeron-eq-hashtable - [() (go0 src sexpr (constant eq-hashtable-subtype-ephemeron))] - [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-ephemeron))])) - (let () - (define-syntax def-put-x - (syntax-rules () - [(_ name x-length) - (define-inline 3 name - [(e-bop e-x) - (bind #t (e-x) - (build-libcall #f src sexpr name e-bop e-x `(immediate 0) - (handle-prim #f #f 3 'x-length (list e-x))))] - [(e-bop e-x e-start) - (bind #t (e-x e-start) - (build-libcall #f src sexpr name e-bop e-x e-start - (%inline - - ,(handle-prim #f #f 3 'x-length (list e-x)) - ,e-start)))] - [(e-bop e-x e-start e-count) - (build-libcall #f src sexpr name e-bop e-x e-start e-count)])])) - (def-put-x put-bytevector bytevector-length) - (def-put-x put-bytevector-some bytevector-length) - (def-put-x put-string string-length) - (def-put-x put-string-some string-length)) - - (define-inline 3 $read-time-stamp-counter - [() - (constant-case architecture - [(x86) - (%seq - ; returns low-order 32 bits in eax, high-order in edx - (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-time-stamp-counter)) - ,(u32xu32->ptr %edx %eax))] - [(x86_64) - (%seq - ; returns low-order 32 bits in rax, high-order in rdx - (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-time-stamp-counter)) - ,(unsigned->ptr - (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) - 64))] - [(arm32 pb) (unsigned->ptr (%inline read-time-stamp-counter) 32)] - [(arm64) (unsigned->ptr (%inline read-time-stamp-counter) 64)] - [(ppc32) - (let ([t-hi (make-tmp 't-hi)]) - `(let ([,t-hi (inline ,(make-info-kill* (reg-list %real-zero)) - ,%read-time-stamp-counter)]) - ,(u32xu32->ptr t-hi %real-zero)))])]) - - (define-inline 3 $read-performance-monitoring-counter - [(e) - (constant-case architecture - [(x86) - (%seq - (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-performance-monitoring-counter ,(build-unfix e))) - ,(u32xu32->ptr %edx %eax))] - [(x86_64) - (%seq - (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-performance-monitoring-counter ,(build-unfix e))) - ,(unsigned->ptr - (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) - 64))] - [(arm32 ppc32 pb) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)] - [(arm64) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 64)])]) - - (define-inline 3 assert-unreachable - [() (%constant svoid)]) - - )) ; expand-primitives module - (define-pass np-place-overflow-and-trap : L9 (ir) -> L9.5 () (definitions (define repeat? #f) @@ -19235,7 +10711,7 @@ ((pass np-profile-unroll-loops unparse-L7) ir))) (pass np-simplify-if unparse-L7) (pass np-unbox-fp-vars! unparse-L7) - (pass np-expand-primitives unparse-L9) + (pass $np-expand-primitives unparse-L9) (pass np-place-overflow-and-trap unparse-L9.5) (pass np-rebind-on-ruined-path unparse-L9.5) (pass np-finalize-loops unparse-L9.75) diff --git a/racket/src/ChezScheme/s/cpprim.ss b/racket/src/ChezScheme/s/cpprim.ss new file mode 100644 index 0000000000..64afa52e36 --- /dev/null +++ b/racket/src/ChezScheme/s/cpprim.ss @@ -0,0 +1,7959 @@ +;; The `$np-expand-primitives` pass is used only by "cpnanopass.ss". +;; This pass is in its own file just to break up the compiler itself +;; into smaller compilation units. + +(let () +(define-syntax define-once + (syntax-rules () + [(_ id rhs) (define-once id (id) rhs)] + [(_ id (name . _) rhs) (define id ($sgetprop 'name 'once #f))])) + +(include "np-languages.ss") +(import (nanopass) np-languages) + +(include "np-register.ss") +(include "np-info.ss") +(include "np-help.ss") + +;; -------------------------------------------------------------------------------- + +(define (known-flonum-result? e) + (let flonum-result? ([e e] [fuel 10]) + (and + (fx> fuel 0) + (nanopass-case (L7 Expr) e + [,x (and (uvar? x) (eq? (uvar-type x) 'fp))] + [(quote ,d) (flonum? d)] + [(call ,info ,mdcl ,pr ,e* ...) + (or (eq? 'flonum ($sgetprop (primref-name pr) '*result-type* #f)) + (and (eq? '$object-ref (primref-name pr)) + (pair? e*) + (nanopass-case (L7 Expr) (car e*) + [(quote ,d) (eq? d 'double)])))] + [(seq ,e0 ,e1) (flonum-result? e1 (fx- fuel 1))] + [(let ([,x* ,e*] ...) ,body) (flonum-result? body (fx- fuel 1))] + [(if ,e1 ,e2 ,e3) (and (flonum-result? e2 (fxsrl fuel 1)) + (flonum-result? e3 (fxsrl fuel 1)))] + [else #f])))) + +(define rtd-ancestors (csv7:record-field-accessor #!base-rtd 'ancestors)) + +;; After the `np-expand-primitives` pass, some expression produce +;; double (i.e., floating-point) values instead of pointer values. +;; Those expression results always flow to an `inline` primitive +;; that expects double values. The main consequence is that a later +;; pass must only put such returns in a temporary with type 'fp. + +; TODO: recognize a direct call when it is at the end of a sequence, closures, or let form +; TODO: push call into if? (would need to pull arguments into temporaries to ensure order of evaluation +; TODO: how does this interact with mvcall? +(module (np-expand-primitives) + (define-threaded new-l*) + (define-threaded new-le*) + (define ht2 (make-hashtable symbol-hash eq?)) + (define ht3 (make-hashtable symbol-hash eq?)) + (define handle-prim + (lambda (src sexpr level name e*) + (let ([handler (or (and (fx= level 3) (symbol-hashtable-ref ht3 name #f)) + (symbol-hashtable-ref ht2 name #f))]) + (and handler (handler src sexpr e*))))) + (define-syntax Symref + (lambda (x) + (syntax-case x () + [(k ?sym) + (with-implicit (k quasiquote) + #'`(literal ,(make-info-literal #t 'object ?sym (constant symbol-value-disp))))]))) + (define single-valued? + (case-lambda + [(e) (single-valued? e 5)] + [(e fuel) + (and (not (zero? fuel)) + (nanopass-case (L7 Expr) e + [,x #t] + [(immediate ,imm) #t] + [(literal ,info) #t] + [(label-ref ,l ,offset) #t] + [(mref ,e1 ,e2 ,imm ,type) #t] + [(quote ,d) #t] + [,pr #t] + [(call ,info ,mdcl ,pr ,e* ...) + (all-set? (prim-mask single-valued) (primref-flags pr))] + [(foreign-call ,info ,e, e* ...) #t] + [(alloc ,info ,e) #t] + [(set! ,lvalue ,e) #t] + [(profile ,src) #t] + [(pariah) #t] + [(let ([,x* ,e*] ...) ,body) + (single-valued? body (fx- fuel 1))] + [(if ,e0 ,e1 ,e2) + (and (single-valued? e1 (fx- fuel 1)) + (single-valued? e2 (fx- fuel 1)))] + [(seq ,e0 ,e1) + (single-valued? e1 (fx- fuel 1))] + [(unboxed-fp ,e) #t] + [else #f]))])) + (define ensure-single-valued + (case-lambda + [(e unsafe-omit?) + (if (or unsafe-omit? + (single-valued? e)) + e + (with-output-language (L7 Expr) + (let ([t (make-tmp 'v)]) + `(values ,(make-info-call #f #f #f #f #f) ,e))))] + [(e) (ensure-single-valued e (fx= (optimize-level) 3))])) + (define-pass np-expand-primitives : L7 (ir) -> L9 () + (definitions + (define Expr1 + (lambda (e) + (let-values ([(e unboxed-fp?) (Expr e #f)]) + e))) + (define Expr* + (lambda (e*) + (map Expr1 e*))) + (define unboxed-fp->boxed + (lambda (e) + (let ([t (make-tmp 't)]) + (with-output-language (L9 Expr) + `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) + (seq + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e) + ,t)))))) + (define (fp-lvalue? lvalue) + (nanopass-case (L9 Lvalue) lvalue + [,x (and (uvar? x) (eq? (uvar-type x) 'fp))] + [(mref ,e1 ,e2 ,imm ,type) (eq? type 'fp)]))) + (Program : Program (ir) -> Program () + [(labels ([,l* ,le*] ...) ,l) + (fluid-let ([new-l* '()] [new-le* '()]) + (let ([le* (map CaseLambdaExpr le*)]) + `(labels ([,l* ,le*] ... [,new-l* ,new-le*] ...) ,l)))]) + (CaseLambdaExpr : CaseLambdaExpr (ir) -> CaseLambdaExpr ()) + (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause () + [(clause (,x* ...) ,mcp ,interface ,[body #f -> body unboxed-fp?]) + `(clause (,x* ...) ,mcp ,interface ,body)]) + ;; The result of `Expr` can be unboxed (second result is #t) only + ;; if the `can-unbox-fp?` argument is #t, but the result can always + ;; be a boxed expression (even if `can-unbox-fp?` is #t) + (Expr : Expr (ir [can-unbox-fp? #f]) -> Expr (#f) + [(quote ,d) + (values (cond + [(ptr->imm d) => (lambda (i) `(immediate ,i))] + [else `(literal ,(make-info-literal #f 'object d 0))]) + #f)] + [,pr (values (Symref (primref-name pr)) #f)] + [(unboxed-fp ,[e #t -> e unboxed-fp?]) + (if can-unbox-fp? + (values e #t) + (values (unboxed-fp->boxed e) #f))] + [(call ,info0 ,mdcl0 + (call ,info1 ,mdcl1 ,pr (quote ,d)) + ,[e* #f -> e* unboxed-fp?*] ...) + (guard (and (eq? (primref-name pr) '$top-level-value) (symbol? d))) + (values `(call ,info0 ,mdcl0 ,(Symref d) ,e* ...) #f)] + [(call ,info ,mdcl ,pr ,e* ...) + (cond + [(and + (or (not (info-call-shift-attachment? info)) + ;; Note: single-valued also implies that the primitive doesn't + ;; tail-call an arbitary function (which might inspect attachments): + (all-set? (prim-mask single-valued) (primref-flags pr))) + (handle-prim (info-call-src info) (info-call-sexpr info) (primref-level pr) (primref-name pr) e*)) + => (lambda (e) + (let-values ([(e unboxed-fp?) (Expr e can-unbox-fp?)]) + (values + (cond + [(info-call-shift-attachment? info) + (let ([t (make-tmp 't (if unboxed-fp? 'fp 'ptr))]) + `(let ([,t ,e]) + (seq + (attachment-set pop #f) + ,t)))] + [else e]) + unboxed-fp?)))] + [else + (let ([e* (Expr* e*)]) + ; NB: expand calls through symbol top-level values similarly + (let ([info (if (any-set? (prim-mask abort-op) (primref-flags pr)) + (make-info-call (info-call-src info) (info-call-sexpr info) + (info-call-check? info) #t #t + (info-call-shift-attachment? info) + (info-call-shift-consumer-attachment?* info)) + info)]) + (values `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...) + ;; an error can be treated as unboxed if the context wants that: + (and can-unbox-fp? (info-call-error? info)))))])] + [(call ,info ,mdcl ,x ,e* ...) + (guard (uvar-loop? x)) + (let ([e* (map (lambda (x1 e) + (let ([unbox? (eq? (uvar-type x1) 'fp)]) + (let-values ([(e unboxed-fp?) (Expr e unbox?)]) + (cond + [(and unbox? (not unboxed-fp?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp)] + [else e])))) + (uvar-location x) e*)]) + (values `(call ,info ,mdcl ,x ,e* ...) #f))] + [(call ,info ,mdcl ,e ,e* ...) + (let ([e (and e (Expr1 e))] + [e* (Expr* e*)]) + (values `(call ,info ,mdcl ,e ,e* ...) #f))] + [(inline ,info ,prim ,e* ...) + (cond + [(info-unboxed-args? info) + (let ([e* (map (lambda (e unbox-arg?) + (let-values ([(e unboxed-arg?) (Expr e unbox-arg?)]) + (if (and unbox-arg? (not unboxed-arg?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e))) + e* + (info-unboxed-args-unboxed?* info))]) + (values `(inline ,info ,prim ,e* ...) + ;; Especially likely to be replaced by enclosing `unboxed-fp` wrapper: + #f))] + [else + (let ([e* (Expr* e*)]) + (values `(inline ,info ,prim ,e* ...) #f))])] + [(set! ,[lvalue #t -> lvalue fp-unboxed?l] ,e) + (let ([fp? (fp-lvalue? lvalue)]) + (let-values ([(e unboxed?) (Expr e fp?)]) + (let ([e (if (and fp? (not unboxed?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e)]) + (values `(set! ,lvalue ,e) #f))))] + [(values ,info ,[e* #f -> e* unboxed-fp?*] ...) (values `(values ,info ,e* ...) #f)] + [(alloc ,info ,e) (values `(alloc ,info ,(Expr1 e)) #f)] + [(if ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?1] ,[e2 can-unbox-fp? -> e2 unboxed-fp?2]) + (let* ([unboxed-fp? (or unboxed-fp?1 unboxed-fp?2)] + [e1 (if (and unboxed-fp? (not unboxed-fp?1)) + (%mref ,e1 ,%zero ,(constant flonum-data-disp) fp) + e1)] + [e2 (if (and unboxed-fp? (not unboxed-fp?2)) + (%mref ,e2 ,%zero ,(constant flonum-data-disp) fp) + e2)]) + (values `(if ,e0 ,e1 ,e2) unboxed-fp?))] + [(seq ,[e0 #f -> e0 unboxed-fp?0] ,[e1 can-unbox-fp? -> e1 unboxed-fp?]) + (values `(seq ,e0 ,e1) unboxed-fp?)] + [(let ([,x* ,e*] ...) ,body) + (let ([e* (map (lambda (x e) + (if (eq? (uvar-type x) 'fp) + (let-values ([(e unboxed?) (Expr e #t)]) + (if (not unboxed?) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e)) + (Expr1 e))) + x* e*)]) + (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) + (values `(let ([,x* ,e*] ...) ,body) unboxed-fp?)))] + [(loop ,x (,x* ...) ,body) + (uvar-location-set! x x*) + (let-values ([(body unboxed-fp?) (Expr body can-unbox-fp?)]) + (uvar-location-set! x #f) + (values `(loop ,x (,x* ...) ,body) unboxed-fp?))] + [(attachment-set ,aop ,e) (values `(attachment-set ,aop ,(and e (Expr1 e))) #f)] + [(attachment-get ,reified ,e) (values `(attachment-get ,reified ,(and e (Expr1 e))) #f)] + [(attachment-consume ,reified ,e) (values `(attachment-consume ,reified ,(and e (Expr1 e))) #f)] + [(continuation-set ,cop ,e1 ,e2) (values `(continuation-set ,cop ,(Expr1 e1) ,(Expr1 e2)) #f)] + [(label ,l ,[body can-unbox-fp? -> body unboxed-fp?]) (values `(label ,l ,body) unboxed-fp?)] + [(foreign-call ,info ,e ,e* ...) + (let ([e (Expr1 e)] + [e* (if (info-foreign-unboxed? info) + (map (lambda (e type) + (let ([unbox-arg? (fp-type? type)]) + (let-values ([(e unboxed-fp?) (Expr e unbox-arg?)]) + (if (and unbox-arg? (not unboxed-fp?)) + (%mref ,e ,%zero ,(constant flonum-data-disp) fp) + e)))) + e* + (info-foreign-arg-type* info)) + (map Expr1 e*))]) + (let ([new-e `(foreign-call ,info ,e ,e* ...)] + [unboxed? (and (info-foreign-unboxed? info) + (fp-type? (info-foreign-result-type info)))]) + (if (and unboxed? (not can-unbox-fp?)) + (values (unboxed-fp->boxed new-e) #f) + (values new-e unboxed?))))] + [(mvcall ,info ,e1 ,e2) (values `(mvcall ,info ,(Expr1 e1) ,(Expr1 e2)) #f)] + [(mvlet ,e ((,x** ...) ,interface* ,body*) ...) + (values `(mvlet ,(Expr1 e) ((,x** ...) ,interface* ,(map Expr1 body*)) ...) #f)] + [,lvalue (Lvalue lvalue can-unbox-fp?)]) + (Lvalue : Lvalue (ir [unboxed-fp? #f]) -> Lvalue (#f) + [(mref ,e1 ,e2 ,imm ,type) + (let ([e `(mref ,(Expr1 e1) ,(Expr1 e2) ,imm ,type)]) + (if (and (eq? type 'fp) (not unboxed-fp?)) + (values (unboxed-fp->boxed e) #f) + (values e (eq? type 'fp))))] + [,x + (let ([fp? (and (uvar? x) (eq? (uvar-type x) 'fp))]) + (if (and fp? (not unboxed-fp?)) + (values (unboxed-fp->boxed x) #f) + (values x fp?)))])) + (define-who unhandled-arity + (lambda (name args) + (sorry! who "unhandled argument count ~s for ~s" (length args) 'name))) + (with-output-language (L7 Expr) + (define-$type-check (L7 Expr)) + (define-syntax define-inline + (let () + (define ctht2 (make-hashtable symbol-hash eq?)) + (define ctht3 (make-hashtable symbol-hash eq?)) + (define check-and-record + (lambda (level name) + (let ([a (symbol-hashtable-cell (if (fx= level 2) ctht2 ctht3) (syntax->datum name) #f)]) + (when (cdr a) (syntax-error name "duplicate inline")) + (set-cdr! a #t)))) + (lambda (x) + (define compute-interface + (lambda (clause) + (syntax-case clause () + [(x e1 e2 ...) (identifier? #'x) -1] + [((x ...) e1 e2 ...) (length #'(x ...))] + [((x ... . r) e1 e2 ...) (fxlognot (length #'(x ...)))]))) + (define bitmaskify + (lambda (i*) + (fold-left (lambda (mask i) + (logor mask (if (fx< i 0) (ash -1 (fxlognot i)) (ash 1 i)))) + 0 i*))) + (syntax-case x () + [(k level id clause ...) + (identifier? #'id) + (let ([level (datum level)] [name (datum id)]) + (unless (memv level '(2 3)) + (syntax-error x (format "invalid level ~s in inline definition" level))) + (let ([pr ($sgetprop name (if (eqv? level 2) '*prim2* '*prim3*) #f)]) + (include "primref.ss") + (unless pr + (syntax-error x (format "unrecognized primitive name ~s in inline definition" name))) + (let ([arity (primref-arity pr)]) + (when arity + (unless (= (bitmaskify arity) (bitmaskify (map compute-interface #'(clause ...)))) + (syntax-error x (format "arity mismatch for ~s" name)))))) + (check-and-record level #'id) + (with-implicit (k src sexpr moi) + #`(symbol-hashtable-set! #,(if (eqv? level 2) #'ht2 #'ht3) 'id + (rec moi + (lambda (src sexpr args) + (apply (case-lambda clause ... [rest #f]) args))))))])))) + (define no-need-to-bind? + (lambda (multiple-ref? e) + (nanopass-case (L7 Expr) e + [,x (if (uvar? x) (not (uvar-assigned? x)) (eq? x %zero))] + [(immediate ,imm) #t] ; might should produce binding if imm is large + [(quote ,d) (or (not multiple-ref?) (ptr->imm d))] + [,pr (not multiple-ref?)] + [(literal ,info) (and (not multiple-ref?) (not (info-literal-indirect? info)))] + [(profile ,src) #t] + [(pariah) #t] + [else #f]))) + (define binder + (lambda (multiple-ref? type e) + (if (no-need-to-bind? multiple-ref? e) + (values e values) + (let ([t (make-tmp 't type)]) + (values t (lift-fp-unboxed + (lambda (body) + `(let ([,t ,e]) ,body)))))))) + (define list-binder + (lambda (multiple-ref? type e*) + (if (null? e*) + (values '() values) + (let-values ([(e dobind) (binder multiple-ref? type (car e*))] + [(e* dobind*) (list-binder multiple-ref? type (cdr e*))]) + (values (cons e e*) + (lambda (body) + (dobind (dobind* body)))))))) + (define dirty-store-binder + (lambda (multiple-ref? type e) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard (eq? (primref-name pr) '$fixmediate)) + (let-values ([(t dobind) (binder multiple-ref? type e)]) + (values `(call ,info ,mdcl ,pr ,t) dobind))] + [else + (binder multiple-ref? type e)]))) + (define-syntax $bind + (lambda (x) + (syntax-case x () + [(_ binder multiple-ref? type (b ...) e) + (let ([t0* (generate-temporaries #'(b ...))]) + (let f ([b* #'(b ...)] [t* t0*] [x* '()]) + (if (null? b*) + (with-syntax ([(x ...) (reverse x*)] [(t ...) t0*]) + #`(let ([x t] ...) e)) + (syntax-case (car b*) () + [x (identifier? #'x) + #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type x)]) + (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))] + [(x e) (identifier? #'x) + #`(let-values ([(#,(car t*) dobind) (binder multiple-ref? 'type e)]) + (dobind #,(f (cdr b*) (cdr t*) (cons #'x x*))))]))))]))) + (define-syntax bind + (syntax-rules () + [(_ multiple-ref? type (b ...) e) + (identifier? #'type) + ($bind binder multiple-ref? type (b ...) e)] + [(_ multiple-ref? (b ...) e) + ($bind binder multiple-ref? ptr (b ...) e)])) + (define-syntax list-bind + (syntax-rules () + [(_ multiple-ref? type (b ...) e) + (identifier? #'type) + ($bind list-binder multiple-ref? type (b ...) e)] + [(_ multiple-ref? (b ...) e) + ($bind list-binder multiple-ref? ptr (b ...) e)])) + (define-syntax dirty-store-bind + (syntax-rules () + [(_ multiple-ref? (b ...) e) + ($bind dirty-store-binder multiple-ref? ptr (b ...) e)])) + (define lift-fp-unboxed + (lambda (k) + (lambda (e) + ;; Propagate unboxing information: + (nanopass-case (L7 Expr) e + [(unboxed-fp ,e) `(unboxed-fp ,(k e))] + [else + (let ([new-e (k e)]) + (nanopass-case (L7 Expr) e + [(mref ,e0 ,e1 ,imm ,type) + (if (eq? type 'fp) + `(unboxed-fp ,new-e) + new-e)] + [,x (if (and (uvar? x) (eq? (uvar-type x) 'fp)) + `(unboxed-fp ,new-e) + new-e)] + [else new-e]))])))) + (define-syntax build-libcall + (lambda (x) + (syntax-case x () + [(k pariah? src sexpr name e ...) + (let ([libspec ($sgetprop (datum name) '*libspec* #f)]) + (define interface-okay? + (lambda (interface* cnt) + (ormap + (lambda (interface) + (if (fx< interface 0) + (fx>= cnt (lognot interface)) + (fx= cnt interface))) + interface*))) + (unless libspec (syntax-error x "unrecognized library routine")) + (unless (eqv? (length #'(e ...)) (libspec-interface libspec)) + (syntax-error x "invalid number of arguments")) + (let ([is-pariah? (datum pariah?)]) + (unless (boolean? is-pariah?) + (syntax-error x "pariah indicator must be a boolean literal")) + (when (and (libspec-error? libspec) (not is-pariah?)) + (syntax-error x "pariah indicator is inconsistent with libspec-error indicator")) + (with-implicit (k quasiquote) + (with-syntax ([body #`(call ,(make-info-call src sexpr #f pariah? #,(libspec-error? libspec)) #f + (literal ,(make-info-literal #f 'library '#,(datum->syntax #'* libspec) 0)) + ,e ...)]) + (if is-pariah? + #'`(seq (pariah) body) + #'`body)))))]))) + (define-syntax when-known-endianness + (lambda (stx) + (syntax-case stx () + [(_ e ...) + #'(constant-case native-endianness + [(unknown) (void)] + [else e ...])]))) + (define constant? + (case-lambda + [(x) + (nanopass-case (L7 Expr) x + [(quote ,d) #t] + ; TODO: handle immediate? + [else #f])] + [(pred? x) + (nanopass-case (L7 Expr) x + [(quote ,d) (pred? d)] + ; TODO: handle immediate? + [else #f])])) + (define constant-value + (lambda (x) + (nanopass-case (L7 Expr) x + [(quote ,d) d] + ; TODO: handle immediate if constant? does + [else #f]))) + (define maybe-add-label + (lambda (Llib body) + (if Llib + `(label ,Llib ,body) + body))) + (define build-and + (lambda (e1 e2) + `(if ,e1 ,e2 ,(%constant sfalse)))) + (define maybe-build-and + (lambda (e1 e2) + (if e1 + (build-and e1 e2) + e2))) + (define build-simple-or + (lambda (e1 e2) + `(if ,e1 ,(%constant strue) ,e2))) + (define build-fix + (lambda (e) + (%inline sll ,e ,(%constant fixnum-offset)))) + (define build-double-scale + (lambda (e) + (constant-case ptr-bits + [(32) (%inline sll ,e (immediate 1))] + [(64) e] + [else ($oops 'build-double-scale "unknown ptr-bit size ~s" (constant ptr-bits))]))) + (define build-unfix + (lambda (e) + (nanopass-case (L7 Expr) e + [(quote ,d) (guard (target-fixnum? d)) `(immediate ,d)] + [else (%inline sra ,e ,(%constant fixnum-offset))]))) + (define build-not + (lambda (e) + `(if ,e ,(%constant sfalse) ,(%constant strue)))) + (define build-null? + (lambda (e) + (%type-check mask-nil snil ,e))) + (define build-eq? + (lambda (e1 e2) + (%inline eq? ,e1 ,e2))) + (define build-eqv? + (lambda (src sexpr e1 e2) + (bind #t (e1 e2) + (build-simple-or + (build-eq? e1 e2) + (build-and + ;; checking just one argument is good enough for typical + ;; uses, where `eqv?` almost always receives two fixnums + ;; or two characters; checking both arguments appears to + ;; by counter-productive by introducing too many branches + (build-simple-or + (%type-check mask-flonum type-flonum ,e1) + (build-and + (%type-check mask-typed-object type-typed-object ,e1) + (%type-check mask-other-number type-other-number + ,(%mref ,e1 ,(constant bignum-type-disp))))) + (build-libcall #f src sexpr eqv? e1 e2)))))) + (define make-build-eqv? + (lambda (src sexpr) + (lambda (e1 e2) + (build-eqv? src sexpr e1 e2)))) + (define fixnum-constant? + (lambda (e) + (constant? target-fixnum? e))) + (define expr->index + (lambda (e alignment limit) + (nanopass-case (L7 Expr) e + [(quote ,d) + (and (target-fixnum? d) + (>= d 0) + (< d limit) + (fxzero? (logand d (fx- alignment 1))) + d)] + [else #f]))) + (define build-fixnums? + (lambda (e*) + (let ([e* (remp fixnum-constant? e*)]) + (if (null? e*) + `(quote #t) + (%type-check mask-fixnum type-fixnum + ,(fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) + (car e*) (cdr e*))))))) + (define build-flonums? + (lambda (e*) + (let ([e* (remp (lambda (e) (constant? flonum? e)) e*)]) + (if (null? e*) + `(quote #t) + (let f ([e* e*]) + (let ([e (car e*)] [e* (cdr e*)]) + (let ([check (%type-check mask-flonum type-flonum ,e)]) + (if (null? e*) + check + (build-and check (f e*)))))))))) + (define build-fl= + (lambda (e1 e2) ; must be bound + `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))) + (define build-chars? + (lambda (e1 e2) + (define char-constant? + (lambda (e) + (constant? char? e))) + (if (char-constant? e1) + (if (char-constant? e2) + (%constant strue) + (%type-check mask-char type-char ,e2)) + (if (char-constant? e2) + (%type-check mask-char type-char ,e1) + (build-and + (%type-check mask-char type-char ,e1) + (%type-check mask-char type-char ,e2)))))) + (define build-list + (lambda (e*) + (if (null? e*) + (%constant snil) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) + (let loop ([e* e*] [i 0]) + (let ([e (car e*)] [e* (cdr e*)]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) + ,(if (null? e*) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,(%constant snil)) + ,t) + (let ([next-i (fx+ i (constant size-pair))]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) + ,(%inline + ,t (immediate ,next-i))) + ,(loop e* next-i)))))))))))) + (define build-pair? + (lambda (e) + (%type-check mask-pair type-pair ,e))) + (define build-car + (lambda (e) + (%mref ,e ,(constant pair-car-disp)))) + (define build-cdr + (lambda (e) + (%mref ,e ,(constant pair-cdr-disp)))) + (define build-char->integer + (lambda (e) + (%inline srl ,e + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))))) + (define build-integer->char + (lambda (e) + (%inline + + ,(%inline sll ,e + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) + ,(%constant type-char)))) + (define need-store-fence? + (if-feature pthreads + (constant-case architecture + [(arm32 arm64) #t] + [else #f]) + #f)) + (define add-store-fence + ;; A store--store fence should be good enough for safety on a platform that + ;; orders load dependencies (which is anything except Alpha) + (lambda (e) + (if need-store-fence? + `(seq ,(%inline store-store-fence) ,e) + e))) + (define build-dirty-store + (case-lambda + [(base offset e) (build-dirty-store base %zero offset e)] + [(base index offset e) (build-dirty-store base index offset e + (lambda (base index offset e) `(set! ,(%mref ,base ,index ,offset) ,e)) + (lambda (s r) `(seq ,s ,r)))] + [(base index offset e build-assign build-remember-seq) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard (eq? (primref-name pr) '$fixmediate)) + (build-assign base index offset e)] + [else + (if (nanopass-case (L7 Expr) e + [(quote ,d) (ptr->imm d)] + [(call ,info ,mdcl ,pr ,e* ...) + (eq? 'fixnum ($sgetprop (primref-name pr) '*result-type* #f))] + [else #f]) + (build-assign base index offset e) + (let ([a (if (eq? index %zero) + (%lea ,base offset) + (%lea ,base ,index offset))]) + ; NB: should work harder to determine cases where x can't be a fixnum + (if (nanopass-case (L7 Expr) e + [(quote ,d) #t] + [(literal ,info) #t] + [else #f]) + (bind #f ([e e]) + ; eval a second so the address is not live across any calls + (bind #t ([a a]) + (add-store-fence + (build-remember-seq + (build-assign a %zero 0 e) + (%inline remember ,a))))) + (bind #t ([e e]) + ; eval a second so the address is not live across any calls + (bind #t ([a a]) + (if need-store-fence? + ;; Fence needs to be before store, so duplicate + ;; store instruction to lift out fixnum check; this + ;; appears to be worthwhile on the Apple M1 to avoid + ;; tighly interleaved writes and fences + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(build-assign a %zero 0 e) + ,(add-store-fence + (build-remember-seq + (build-assign a %zero 0 e) + (%inline remember ,a)))) + ;; Generate one copy of store instruction + (build-remember-seq + (build-assign a %zero 0 e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant svoid) + ,(%inline remember ,a)))))))))])])) + (define make-build-cas + (lambda (old-v) + (lambda (base index offset v) + `(seq + ,(%inline cas ,base ,index (immediate ,offset) ,old-v ,v) + (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))))) + (define build-cas-seq + (lambda (cas remember) + `(if ,cas + (seq ,remember ,(%constant strue)) + ,(%constant sfalse)))) + (define build-$record + (lambda (tag args) + (bind #f (tag) + (list-bind #f (args) + (let ([n (fx+ (length args) 1)]) + (bind #t ([t (%constant-alloc type-typed-object (fx* n (constant ptr-bytes)))]) + `(seq + (set! ,(%mref ,t ,(constant record-type-disp)) ,tag) + ,(let f ([args args] [offset (constant record-data-disp)]) + (if (null? args) + t + `(seq + (set! ,(%mref ,t ,offset) ,(car args)) + ,(f (cdr args) (fx+ offset (constant ptr-bytes))))))))))))) + (define build-$real->flonum + (lambda (src sexpr x who) + (if (known-flonum-result? x) + x + (bind #t (x) + (bind #f (who) + `(if ,(%type-check mask-flonum type-flonum ,x) + ,x + ,(build-libcall #t src sexpr real->flonum x who))))))) + (define build-$inexactnum-real-part + (lambda (e) + (%lea ,e (fx+ (constant inexactnum-real-disp) + (fx- (constant type-flonum) (constant typemod)))))) + (define build-$inexactnum-imag-part + (lambda (e) + (%lea ,e (fx+ (constant inexactnum-imag-disp) + (fx- (constant type-flonum) (constant typemod)))))) + (define make-build-fill + (lambda (elt-bytes data-disp) + (define ptr-bytes (constant ptr-bytes)) + (define super-size + (lambda (e-fill) + (define-who super-size-imm + (lambda (imm) + `(immediate + ,(constant-case ptr-bytes + [(4) + (case elt-bytes + [(1) (let ([imm (logand imm #xff)])< + (let ([imm (logor (ash imm 8) imm)]) + (logor (ash imm 16) imm)))] + [(2) (let ([imm (logand imm #xffff)]) + (logor (ash imm 16) imm))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] + [(8) + (case elt-bytes + [(1) (let ([imm (logand imm #xff)]) + (let ([imm (logor (ash imm 8) imm)]) + (let ([imm (logor (ash imm 16) imm)]) + (logor (ash imm 32) imm))))] + [(2) (let ([imm (logand imm #xffff)]) + (let ([imm (logor (ash imm 16) imm)]) + (logor (ash imm 32) imm)))] + [(4) (let ([imm (logand imm #xffffffff)]) + (logor (ash imm 32) imm))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])])))) + (define-who super-size-expr + (lambda (e-fill) + (define (double e-fill k) + (%inline logor + ,(%inline sll ,e-fill (immediate ,k)) + ,e-fill)) + (define (mask e-fill k) + (%inline logand ,e-fill (immediate ,k))) + (constant-case ptr-bytes + [(4) + (case elt-bytes + [(1) (bind #t ([e-fill (mask e-fill #xff)]) + (bind #t ([e-fill (double e-fill 8)]) + (double e-fill 16)))] + [(2) (bind #t ([e-fill (mask e-fill #xffff)]) + (double e-fill 16))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])] + [(8) + (case elt-bytes + [(1) (bind #t ([e-fill (mask e-fill #xff)]) + (bind #t ([e-fill (double e-fill 8)]) + (bind #t ([e-fill (double e-fill 16)]) + (double e-fill 32))))] + [(2) (bind #t ([e-fill (mask e-fill #xffff)]) + (bind #t ([e-fill (double e-fill 16)]) + (double e-fill 32)))] + [(4) (bind #t ([e-fill (mask e-fill #xffffffff)]) + (double e-fill 32))] + [else (sorry! who "unexpected elt-bytes ~s" elt-bytes)])]))) + (if (fx= elt-bytes ptr-bytes) + e-fill + (nanopass-case (L7 Expr) e-fill + [(quote ,d) + (cond + [(ptr->imm d) => super-size-imm] + [else (super-size-expr e-fill)])] + [(immediate ,imm) (super-size-imm imm)] + [else (super-size-expr e-fill)])))) + (lambda (e-vec e-bytes e-fill) + ; NB: caller must bind e-vec and e-fill + (safe-assert (no-need-to-bind? #t e-vec)) + (safe-assert (no-need-to-bind? #f e-fill)) + (nanopass-case (L7 Expr) e-bytes + [(immediate ,imm) + (guard (fixnum? imm) (fx<= 0 imm (fx* 4 ptr-bytes))) + (if (fx= imm 0) + e-vec + (bind #t ([e-fill (super-size e-fill)]) + (let f ([n (if (fx>= elt-bytes ptr-bytes) + imm + (fxlogand (fx+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))]) + (let ([n (fx- n ptr-bytes)]) + `(seq + (set! ,(%mref ,e-vec ,(fx+ data-disp n)) ,e-fill) + ,(if (fx= n 0) e-vec (f n)))))))] + [else + (let ([Ltop (make-local-label 'Ltop)] [t (make-assigned-tmp 't 'uptr)]) + (bind #t ([e-fill (super-size e-fill)]) + `(let ([,t ,(if (fx>= elt-bytes ptr-bytes) + e-bytes + (nanopass-case (L7 Expr) e-bytes + [(immediate ,imm) + `(immediate ,(logand (+ imm (fx- ptr-bytes 1)) (fx- ptr-bytes)))] + [else + (%inline logand + ,(%inline + + ,e-bytes + (immediate ,(fx- ptr-bytes 1))) + (immediate ,(fx- ptr-bytes)))]))]) + (label ,Ltop + (if ,(%inline eq? ,t (immediate 0)) + ,e-vec + ,(%seq + (set! ,t ,(%inline - ,t (immediate ,ptr-bytes))) + (set! ,(%mref ,e-vec ,t ,data-disp) ,e-fill) + (goto ,Ltop)))))))])))) + + ;; NOTE: integer->ptr and unsigned->ptr DO NOT handle 64-bit integers on a 32-bit machine. + ;; this is okay for $object-ref and $object-set!, which do not support moving 64-bit values + ;; as single entities on a 32-bit machine, but care should be taken if these are used with + ;; other primitives. + (define-who integer->ptr + (lambda (x width) + (if (fx>= (constant fixnum-bits) width) + (build-fix x) + (%seq + (set! ,%ac0 ,x) + (set! ,%xp ,(build-fix %ac0)) + (set! ,%xp ,(build-unfix %xp)) + (if ,(%inline eq? ,%ac0 ,%xp) + ,(build-fix %ac0) + (seq + (set! ,%ac0 + (inline + ,(case width + [(32) (intrinsic-info-asmlib dofretint32 #f)] + [(64) (intrinsic-info-asmlib dofretint64 #f)] + [else ($oops who "can't handle width ~s" width)]) + ,%asmlibcall)) + ,%ac0)))))) + (define-who unsigned->ptr + (lambda (x width) + (if (fx>= (constant fixnum-bits) width) + (build-fix x) + `(seq + (set! ,%ac0 ,x) + (if ,(%inline u< ,(%constant most-positive-fixnum) ,%ac0) + (seq + (set! ,%ac0 + (inline + ,(case width + [(32) (intrinsic-info-asmlib dofretuns32 #f)] + [(64) (intrinsic-info-asmlib dofretuns64 #f)] + [else ($oops who "can't handle width ~s" width)]) + ,%asmlibcall)) + ,%ac0) + ,(build-fix %ac0)))))) + (define-who i32xu32->ptr + (lambda (hi lo) + (safe-assert (eqv? (constant ptr-bits) 32)) + (let ([Lbig (make-local-label 'Lbig)]) + (bind #t (lo hi) + `(if ,(%inline eq? ,hi ,(%inline sra ,lo (immediate 31))) + ,(bind #t ([fxlo (build-fix lo)]) + `(if ,(%inline eq? ,(build-unfix fxlo) ,lo) + ,fxlo + (goto ,Lbig))) + (label ,Lbig + ,(%seq + (set! ,%ac0 ,lo) + (set! ,(ref-reg %ac1) ,hi) + (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretint64 #f) ,%asmlibcall)) + ,%ac0))))))) + (define-who u32xu32->ptr + (lambda (hi lo) + (safe-assert (eqv? (constant ptr-bits) 32)) + (let ([Lbig (make-local-label 'Lbig)]) + (bind #t (lo hi) + `(if ,(%inline eq? ,hi (immediate 0)) + (if ,(%inline u< ,(%constant most-positive-fixnum) ,lo) + (goto ,Lbig) + ,(build-fix lo)) + (label ,Lbig + ,(%seq + (set! ,%ac0 ,lo) + (set! ,(ref-reg %ac1) ,hi) + (set! ,%ac0 (inline ,(intrinsic-info-asmlib dofretuns64 #f) ,%asmlibcall)) + ,%ac0))))))) + + (define-who ptr->integer + (lambda (value width) + (if (fx> (constant fixnum-bits) width) + (build-unfix value) + `(seq + (set! ,%ac0 ,value) + (if ,(%type-check mask-fixnum type-fixnum ,%ac0) + ,(build-unfix %ac0) + (seq + (set! ,%ac0 + (inline + ,(cond + [(fx<= width 32) (intrinsic-info-asmlib dofargint32 #f)] + [(fx<= width 64) (intrinsic-info-asmlib dofargint64 #f)] + [else ($oops who "can't handle width ~s" width)]) + ,%asmlibcall)) + ,%ac0)))))) + (define ptr-type (constant-case ptr-bits + [(32) 'unsigned-32] + [(64) 'unsigned-64] + [else ($oops 'ptr-type "unknown ptr-bit size ~s" (constant ptr-bits))])) + (define-who type->width + (lambda (x) + (case x + [(integer-8 unsigned-8 char) 8] + [(integer-16 unsigned-16) 16] + [(integer-24 unsigned-24) 24] + [(integer-32 unsigned-32 single-float) 32] + [(integer-40 unsigned-40) 40] + [(integer-48 unsigned-48) 48] + [(integer-56 unsigned-56) 56] + [(integer-64 unsigned-64 double-float) 64] + [(scheme-object fixnum) (constant ptr-bits)] + [(wchar) (constant wchar-bits)] + [else ($oops who "unknown type ~s" x)]))) + (define offset-expr->index+offset + (lambda (offset) + (if (fixnum-constant? offset) + (values %zero (constant-value offset)) + (values (build-unfix offset) 0)))) + (define-who build-int-load + ;; assumes aligned (if required) offset + (lambda (swapped? type base index offset build-int) + (case type + [(integer-8 unsigned-8) + (build-int `(inline ,(make-info-load type #f) ,%load ,base ,index (immediate ,offset)))] + [(integer-16 integer-32 unsigned-16 unsigned-32) + (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))] + [(integer-64 unsigned-64) + ;; NB: doesn't handle unknown endiannesss for 32-bit machines + (constant-case ptr-bits + [(32) + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 4) offset) + (values offset (+ offset 4)))]) + (bind #t (base index) + (build-int + `(inline ,(make-info-load 'integer-32 swapped?) ,%load ,base ,index (immediate ,hi)) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))))] + [(64) + (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))])] + [(integer-24 unsigned-24) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 2)))]) + (define hi-type (if (eq? type 'integer-24) 'integer-8 'unsigned-8)) + (bind #t (base index) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 16)) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,lo))))))])] + [(integer-40 unsigned-40) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 4)))]) + (define hi-type (if (eq? type 'integer-40) 'integer-8 'unsigned-8)) + (bind #t (base index) + (constant-case ptr-bits + [(32) + (build-int + `(inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] + [(64) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 32)) + (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] + [(integer-48 unsigned-48) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 2) offset) + (values offset (+ offset 4)))]) + (define hi-type (if (eq? type 'integer-48) 'integer-16 'unsigned-16)) + (bind #t (base index) + (constant-case ptr-bits + [(32) + (build-int + `(inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] + [(64) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type swapped?) ,%load ,base ,index (immediate ,hi)) + (immediate 32)) + (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] + [(integer-56 unsigned-56) + (constant-case native-endianness + [(unknown) #f] + [else + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 3) (+ offset 1) offset) + (values offset (+ offset 4) (+ offset 6)))]) + (define hi-type (if (eq? type 'integer-56) 'integer-8 'unsigned-8)) + (bind #t (base index) + (constant-case ptr-bits + [(32) + (build-int + (%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 16)) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) + `(inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo)))] + [(64) + (build-int + (%inline logor + ,(%inline sll + ,(%inline logor + ,(%inline sll + (inline ,(make-info-load hi-type #f) ,%load ,base ,index (immediate ,hi)) + (immediate 16)) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,mi))) + (immediate 32)) + (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] + [else (sorry! who "unsupported type ~s" type)]))) + (define-who build-object-ref + ;; assumes aligned (if required) offset + (case-lambda + [(swapped? type base offset-expr) + (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) + (build-object-ref swapped? type base index offset))] + [(swapped? type base index offset) + (case type + [(scheme-object) `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset))] + [(double-float) + (if swapped? + (constant-case ptr-bits + [(32) + (bind #t (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + (%seq + (set! ,(%mref ,t ,(constant flonum-data-disp)) + (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index + (immediate ,(+ offset 4)))) + (set! ,(%mref ,t ,(+ (constant flonum-data-disp) 4)) + (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index + (immediate ,offset))) + ,t)))] + [(64) + (bind #f (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + `(seq + (set! ,(%mref ,t ,(constant flonum-data-disp)) + (inline ,(make-info-load 'unsigned-64 #t) ,%load ,base ,index + (immediate ,offset))) + ,t)))]) + (bind #f (base index) + (%mref ,base ,index ,offset fp)))] + [(single-float) + (if swapped? + (bind #f (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + (%seq + (inline ,(make-info-load 'unsigned-32 #f) ,%store ,t ,%zero ,(%constant flonum-data-disp) + (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index + (immediate ,offset))) + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) + (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) + ,%load-single->double + ;; slight abuse to call this "unboxed", but `load-single->double` + ;; wants an FP-flavored address + ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp)))) + ,t))) + (bind #f (base index) + (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) + (%seq + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) + (unboxed-fp (inline ,(make-info-unboxed-args '(#t)) + ,%load-single->double + ;; slight abuse to call this "unboxed", but `load-single->double` + ;; wants an FP-flavored address + ,(%mref ,base ,index ,offset fp)))) + ,t))))] + [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64) + (build-int-load swapped? type base index offset + (if (and (eqv? (constant ptr-bits) 32) (memq type '(integer-40 integer-48 integer-56 integer-64))) + i32xu32->ptr + (lambda (x) (integer->ptr x (type->width type)))))] + [(unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) + (build-int-load swapped? type base index offset + (if (and (eqv? (constant ptr-bits) 32) (memq type '(unsigned-40 unsigned-48 unsigned-56 unsigned-64))) + u32xu32->ptr + (lambda (x) (unsigned->ptr x (type->width type)))))] + [(fixnum) (build-fix `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset)))] + [else (sorry! who "unsupported type ~s" type)])])) + (define-who build-int-store + ;; assumes aligned (if required) offset + (lambda (swapped? type base index offset value) + (case type + [(integer-8 unsigned-8) + `(inline ,(make-info-load type #f) ,%store ,base ,index (immediate ,offset) ,value)] + [(integer-16 integer-32 integer-64 unsigned-16 unsigned-32 unsigned-64) + `(inline ,(make-info-load type swapped?) ,%store ,base ,index (immediate ,offset) ,value)] + [(integer-24 unsigned-24) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 2)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 16))))))])] + [(integer-40 unsigned-40) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 1) offset) + (values offset (+ offset 4)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 32))))))])] + [(integer-48 unsigned-48) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 2) offset) + (values offset (+ offset 4)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 32))))))])] + [(integer-56 unsigned-56) + (constant-case native-endianness + [(unknown) #f] + [else + (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) + (values (+ offset 3) (+ offset 1) offset) + (values offset (+ offset 4) (+ offset 6)))]) + (bind #t (base index value) + (%seq + (inline ,(make-info-load 'unsigned-32 swapped?) ,%store ,base ,index (immediate ,lo) ,value) + (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,mi) + ,(%inline srl ,value (immediate 32))) + (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) + ,(%inline srl ,value (immediate 48))))))])] + [else (sorry! who "unsupported type ~s" type)]))) + (define-who build-object-set! + ;; assumes aligned (if required) offset + (case-lambda + [(type base offset-expr value) + (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) + (build-object-set! type base index offset value))] + [(type base index offset value) + (case type + [(scheme-object) (build-dirty-store base index offset value)] + [(double-float) + (bind #f (base index) + `(set! ,(%mref ,base ,index ,offset fp) ,value))] + [(single-float) + (bind #f (base index) + `(inline ,(make-info-unboxed-args '(#t #t)) ,%store-double->single + ;; slight abuse to call this "unboxed", but `store-double->single` + ;; wants an FP-flavored address + ,(%mref ,base ,index ,offset fp) + ,(%mref ,value ,%zero ,(constant flonum-data-disp) fp)))] + ; 40-bit+ only on 64-bit machines + [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 + unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) + (build-int-store #f type base index offset (ptr->integer value (type->width type)))] + [(fixnum) + `(inline ,(make-info-load ptr-type #f) ,%store + ,base ,index (immediate ,offset) ,(build-unfix value))] + [else (sorry! who "unrecognized type ~s" type)])])) + (define-who build-swap-object-set! + (case-lambda + [(type base offset-expr value) + (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) + (build-swap-object-set! type base index offset value))] + [(type base index offset value) + (case type + ; only on 64-bit machines + [(double-float) + `(inline ,(make-info-load 'unsigned-64 #t) ,%store + ,base ,index (immediate ,offset) + ,(%mref ,value ,(constant flonum-data-disp)))] + ; 40-bit+ only on 64-bit machines + [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 + unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) + (build-int-store #t type base index offset (ptr->integer value (type->width type)))] + [(fixnum) + `(inline ,(make-info-load ptr-type #t) ,%store ,base ,index (immediate ,offset) + ,(build-unfix value))] + [else (sorry! who "unrecognized type ~s" type)])])) + (define extract-unsigned-bitfield + (lambda (raw? start end arg) + (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] + [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))] + [body (%inline srl + ,(if (fx= left 0) + arg + (%inline sll ,arg (immediate ,left))) + (immediate ,right))]) + (if (fx= start 0) + body + (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))) + (define extract-signed-bitfield + (lambda (raw? start end arg) + (let* ([left (fx- (if raw? (constant ptr-bits) (constant fixnum-bits)) end)] + [right (if raw? (fx- (fx+ left start) (constant fixnum-offset)) (fx+ left start))]) + (let ([body (if (fx= left 0) arg (%inline sll ,arg (immediate ,left)))]) + (let ([body (if (fx= right 0) body (%inline sra ,body (immediate ,right)))]) + (if (fx= start 0) + body + (%inline logand ,body (immediate ,(- (constant fixnum-factor)))))))))) + (define insert-bitfield + (lambda (raw? start end bf-width arg val) + (if raw? + (cond + [(fx= start 0) + (%inline logor + ,(%inline sll + ,(%inline srl ,arg (immediate ,end)) + (immediate ,end)) + ,(%inline srl + ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) + (immediate ,(fx- (constant ptr-bits) end))))] + [(fx= end bf-width) + (%inline logor + ,(%inline srl + ,(%inline sll ,arg + (immediate ,(fx- (constant ptr-bits) start))) + (immediate ,(fx- (constant ptr-bits) start))) + ,(cond + [(fx< start (constant fixnum-offset)) + (%inline srl ,val + (immediate ,(fx- (constant fixnum-offset) start)))] + [(fx> start (constant fixnum-offset)) + (%inline sll ,val + (immediate ,(fx- start (constant fixnum-offset))))] + [else val]))] + [else + (%inline logor + ,(%inline logand ,arg + (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) start)))) + ,(%inline srl + ,(if (fx= (fx- end start) (constant fixnum-bits)) + val + (%inline sll ,val + (immediate ,(fx- (constant fixnum-bits) (fx- end start))))) + (immediate ,(fx- (constant ptr-bits) end))))]) + (cond + [(fx= start 0) + (%inline logor + ,(%inline sll + ,(%inline srl ,arg (immediate ,(fx+ end (constant fixnum-offset)))) + (immediate ,(fx+ end (constant fixnum-offset)))) + ,(%inline srl + ,(%inline sll ,val (immediate ,(fx- (constant fixnum-bits) end))) + (immediate ,(fx- (constant fixnum-bits) end))))] + #;[(fx= end (constant fixnum-bits)) ---] ; end < fixnum-bits + [else + (%inline logor + ,(%inline logand ,arg + (immediate ,(lognot (ash (- (expt 2 (fx- end start)) 1) + (fx+ start (constant fixnum-offset)))))) + ,(%inline srl + ,(%inline sll ,val + (immediate ,(fx- (constant fixnum-bits) (fx- end start)))) + (immediate ,(fx- (constant fixnum-bits) end))))])))) + (define translate + (lambda (e current-shift target-shift) + (let ([delta (fx- current-shift target-shift)]) + (if (fx= delta 0) + e + (if (fx< delta 0) + (%inline sll ,e (immediate ,(fx- delta))) + (%inline srl ,e (immediate ,delta))))))) + (define extract-length + (lambda (t/l length-offset) + (%inline logand + ,(translate t/l length-offset (constant fixnum-offset)) + (immediate ,(- (constant fixnum-factor)))))) + (define build-type/length + (lambda (e type current-shift target-shift) + (let ([e (translate e current-shift target-shift)]) + (if (eqv? type 0) + e + (%inline logor ,e (immediate ,type)))))) + (define-syntax build-ref-check + (syntax-rules () + [(_ type-disp maximum-length length-offset type mask immutable-flag) + (lambda (e-v e-i maybe-e-new) + ; NB: caller must bind e-v, e-i, and maybe-e-new + (safe-assert (no-need-to-bind? #t e-v)) + (safe-assert (no-need-to-bind? #t e-i)) + (safe-assert (or (not maybe-e-new) (no-need-to-bind? #t maybe-e-new))) + (build-and + (%type-check mask-typed-object type-typed-object ,e-v) + (bind #t ([t (%mref ,e-v ,(constant type-disp))]) + (cond + [(expr->index e-i 1 (constant maximum-length)) => + (lambda (index) + (let ([e (%inline u< + (immediate ,(logor (ash index (constant length-offset)) (constant type) (constant immutable-flag))) + ,t)]) + (if (and (eqv? (constant type) (constant type-fixnum)) + (eqv? (constant mask) (constant mask-fixnum))) + (build-and e (build-fixnums? (if maybe-e-new (list t maybe-e-new) (list t)))) + (build-and + (%type-check mask type ,t) + (if maybe-e-new (build-and e (build-fixnums? (list maybe-e-new))) e)))))] + [else + (let ([e (%inline u< ,e-i ,(extract-length t (constant length-offset)))]) + (if (and (eqv? (constant type) (constant type-fixnum)) + (eqv? (constant mask) (constant mask-fixnum))) + (build-and e (build-fixnums? (if maybe-e-new (list e-i t maybe-e-new) (list e-i t)))) + (build-and + (%type-check mask type ,t) + (build-and + (build-fixnums? (if maybe-e-new (list e-i maybe-e-new) (list e-i))) + e))))]))))])) + (define-syntax build-set-immutable! + (syntax-rules () + [(_ type-disp immutable-flag) + (lambda (e-v) + (bind #t (e-v) + `(set! ,(%mref ,e-v ,(constant type-disp)) + ,(%inline logor + ,(%mref ,e-v ,(constant type-disp)) + (immediate ,(constant immutable-flag))))))])) + (define inline-args-limit (constant inline-args-limit)) + (define reduce-equality + (lambda (src sexpr moi e1 e2 e*) + (and (fx<= (length e*) (fx- inline-args-limit 2)) + (bind #t (e1) + (bind #f (e2) + (list-bind #f (e*) + (let compare ([src src] [e2 e2] [e* e*]) + (if (null? e*) + (moi src sexpr (list e1 e2)) + `(if ,(moi src sexpr (list e1 e2)) + ,(compare #f (car e*) (cdr e*)) + (quote #f)))))))))) + (define reduce-inequality + (lambda (src sexpr moi e1 e2 e*) + (and (fx<= (length e*) (fx- inline-args-limit 2)) + (let f ([e2 e2] [e* e*] [re* '()]) + (if (null? e*) + (bind #f ([e2 e2]) + (let compare ([src src] [e* (cons e1 (reverse (cons e2 re*)))]) + (let ([more-args (cddr e*)]) + (if (null? more-args) + (moi src sexpr e*) + `(if ,(moi src sexpr (list (car e*) (cadr e*))) + ,(compare #f (cdr e*)) + (quote #f)))))) + (bind #t ([e2 e2]) (f (car e*) (cdr e*) (cons e2 re*)))))))) + (define reduce ; left associative as required for, e.g., fx- + (lambda (src sexpr moi e e*) + (and (fx<= (length e*) (fx- inline-args-limit 1)) + (bind #f (e) + (list-bind #f ([e* e*]) + (let reduce ([src src] [e e] [e* e*]) + (if (null? e*) + e + (reduce #f (moi src sexpr (list e (car e*))) (cdr e*))))))))) + (define reduce-fp-compare ; suitable for arguments known or assumed to produce flonums + (lambda (reduce) + (lambda (src sexpr moi e1 e2 e*) + (and (fx<= (length e*) (fx- inline-args-limit 2)) + (bind #t fp (e1) + (bind #f fp (e2) + (list-bind #f fp (e*) + (reduce src sexpr moi e1 e2 e*)))))))) + (define reduce-fp ; specialized reducer supports unboxing for nesting + (lambda (src sexpr level name e e*) + (and (fx<= (length e*) (fx- inline-args-limit 1)) + (let ([pr (lookup-primref level name)]) + (let reduce ([e e] [src src] [sexpr sexpr] [e* e*]) + (if (null? e*) + e + (reduce `(call ,(make-info-call src sexpr #f #f #f) #f ,pr ,e ,(car e*)) + #f #f (cdr e*)))))))) + (module (relop-length RELOP< RELOP<= RELOP= RELOP>= RELOP>) + (define RELOP< -2) + (define RELOP<= -1) + (define RELOP= 0) + (define RELOP>= 1) + (define RELOP> 2) + (define (mirror op) (fx- op)) + (define go + (lambda (op e n) + (let f ([n n] [e e]) + (if (fx= n 0) + (cond + [(or (eqv? op RELOP=) (eqv? op RELOP<=)) (build-null? e)] + [(eqv? op RELOP<) `(seq ,e (quote #f))] + [(eqv? op RELOP>) (build-not (build-null? e))] + [(eqv? op RELOP>=) `(seq ,e (quote #t))] + [else (sorry! 'relop-length "unexpected op ~s" op)]) + (cond + [(or (eqv? op RELOP=) (eqv? op RELOP>)) + (bind #t (e) + (build-and + (build-not (build-null? e)) + (f (fx- n 1) (build-cdr e))))] + [(eqv? op RELOP<) + (if (fx= n 1) + (build-null? e) + (bind #t (e) + (build-simple-or + (build-null? e) + (f (fx- n 1) (build-cdr e)))))] + [(eqv? op RELOP<=) + (bind #t (e) + (build-simple-or + (build-null? e) + (f (fx- n 1) (build-cdr e))))] + [(eqv? op RELOP>=) + (if (fx= n 1) + (build-not (build-null? e)) + (bind #t (e) + (build-and + (build-not (build-null? e)) + (f (fx- n 1) (build-cdr e)))))] + [else (sorry! 'relop-length "unexpected op ~s" op)]))))) + (define relop-length1 + (lambda (op e n) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard (and (eq? (primref-name pr) 'length) (all-set? (prim-mask unsafe) (primref-flags pr)))) + (go op e n)] + [else #f]))) + (define relop-length2 + (lambda (op e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) (and (fixnum? d) (fx<= 0 d 4) (relop-length1 op e1 d))] + [else #f]))) + (define relop-length + (case-lambda + [(op e) (relop-length1 op e 0)] + [(op e1 e2) (or (relop-length2 op e1 e2) (relop-length2 (mirror op) e2 e1))]))) + (define make-ftype-pointer-equal? + (lambda (e1 e2) + (bind #f (e1 e2) + (%inline eq? + ,(%mref ,e1 ,(constant record-data-disp)) + ,(%mref ,e2 ,(constant record-data-disp)))))) + (define make-ftype-pointer-null? + (lambda (e) + (%inline eq? + ,(%mref ,e ,(constant record-data-disp)) + (immediate 0)))) + (define eqvop-null-fptr + (lambda (e1 e2) + (nanopass-case (L7 Expr) e1 + [(call ,info ,mdcl ,pr ,e1) + (and + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr)) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (and (eqv? d 0) (make-ftype-pointer-null? e1))] + [(call ,info ,mdcl ,pr ,e2) + (and (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr)) + (make-ftype-pointer-equal? e1 e2))] + [else #f]))] + [(quote ,d) + (and (eqv? d 0) + (nanopass-case (L7 Expr) e2 + [(call ,info ,mdcl ,pr ,e2) + (and (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr)) + (make-ftype-pointer-null? e2))] + [else #f]))] + [else #f]))) + (define-inline 2 values + [(e) (ensure-single-valued e)] + [e* `(values ,(make-info-call src sexpr #f #f #f) ,e* ...)]) + (define-inline 2 $value + [(e) (ensure-single-valued e #f)]) + (define-inline 2 eq? + [(e1 e2) + (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) + (%inline eq? ,e1 ,e2))]) + (define-inline 2 keep-live + [(e) (%seq ,(%inline keep-live ,e) ,(%constant svoid))]) + (let () + (define (zgo src sexpr e e1 e2 r6rs?) + (build-simple-or + (%inline eq? ,e (immediate 0)) + `(if ,(build-fixnums? (list e)) + ,(%constant sfalse) + ,(if r6rs? + (build-libcall #t src sexpr fx=? e1 e2) + (build-libcall #t src sexpr fx= e1 e2))))) + (define (go src sexpr e1 e2 r6rs?) + (or (relop-length RELOP= e1 e2) + (cond + [(constant? (lambda (x) (eqv? x 0)) e1) + (bind #t (e2) (zgo src sexpr e2 e1 e2 r6rs?))] + [(constant? (lambda (x) (eqv? x 0)) e2) + (bind #t (e1) (zgo src sexpr e1 e1 e2 r6rs?))] + [else (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline eq? ,e1 ,e2) + ,(if r6rs? + (build-libcall #t src sexpr fx=? e1 e2) + (build-libcall #t src sexpr fx= e1 e2))))]))) + (define-inline 2 fx= + [(e1 e2) (go src sexpr e1 e2 #f)] + [(e1 . e*) #f]) + (define-inline 2 fx=? + [(e1 e2) (go src sexpr e1 e2 #t)] + [(e1 e2 . e*) #f])) + (let () ; level 2 fx<, fx= fx>=? RELOP>= >=) + (fx-pred fx> fx>? RELOP> >)) + (let () ; level 3 fx=, fx=?, etc. + (define-syntax fx-pred + (syntax-rules () + [(_ op r6rs:op length-op inline-op) + (let () + (define (go e1 e2) + (or (relop-length length-op e1 e2) + (%inline inline-op ,e1 ,e2))) + (define reducer + (if (eq? 'inline-op 'eq?) + reduce-equality + reduce-inequality)) + (define-inline 3 op + [(e) `(seq ,(ensure-single-valued e) ,(%constant strue))] + [(e1 e2) (go e1 e2)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) + (define-inline 3 r6rs:op + [(e1 e2) (go e1 e2)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]))])) + (fx-pred fx< fx= fx>=? RELOP>= >=) + (fx-pred fx> fx>? RELOP> >)) + (let () ; level 3 fxlogand, ... + (define-syntax fxlogop + (syntax-rules () + [(_ op inline-op base) + (define-inline 3 op + [() `(immediate ,(fix base))] + [(e) (ensure-single-valued e)] + [(e1 e2) (%inline inline-op ,e1 ,e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)])])) + (fxlogop fxlogand logand -1) + (fxlogop fxand logand -1) + (fxlogop fxlogor logor 0) + (fxlogop fxlogior logor 0) + (fxlogop fxior logor 0) + (fxlogop fxlogxor logxor 0) + (fxlogop fxxor logxor 0)) + (let () + (define log-partition + (lambda (p base e*) + (let loop ([e* e*] [n base] [nc* '()]) + (if (null? e*) + (if (and (fixnum? n) (fx= n base) (not (null? nc*))) + (values (car nc*) (cdr nc*) nc*) + (values `(immediate ,(fix n)) nc* nc*)) + (let ([e (car e*)]) + (if (fixnum-constant? e) + (let ([m (constant-value e)]) + (loop (cdr e*) (if n (p n m) m) nc*)) + (loop (cdr e*) n (cons e nc*)))))))) + (let () ; level 2 fxlogor, fxlogior, fxor + (define-syntax fxlogorop + (syntax-rules () + [(_ op) + (let () + (define (go src sexpr e*) + (and (fx<= (length e*) inline-args-limit) + (list-bind #t (e*) + (let-values ([(e e* nc*) (log-partition logor 0 e*)]) + (bind #t ([t (fold-left (lambda (e1 e2) (%inline logor ,e1 ,e2)) e e*)]) + `(if ,(%type-check mask-fixnum type-fixnum ,t) + ,t + ,(case (length nc*) + [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] + [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] + ; TODO: need fxargerr library routine w/who arg & rest interface + [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))]))))))) ; NB: should be error call---but is it? + (define-inline 2 op + [() `(immediate ,(fix 0))] + [e* (go src sexpr e*)]))])) + (fxlogorop fxlogor) + (fxlogorop fxlogior) + (fxlogorop fxior)) + (let () ; level 2 fxlogand, ... + (define-syntax fxlogop + (syntax-rules () + [(_ op inline-op base) + (define-inline 2 op + [() `(immediate ,(fix base))] + [e* (and (fx<= (length e*) (fx- inline-args-limit 1)) + (list-bind #t (e*) + ;; NB: using inline-op here because it works when target's + ;; NB: fixnum range is larger than the host's fixnum range + ;; NB: during cross compile + (let-values ([(e e* nc*) (log-partition inline-op base e*)]) + `(if ,(build-fixnums? nc*) + ,(fold-left (lambda (e1 e2) (%inline inline-op ,e1 ,e2)) e e*) + ; TODO: need fxargerr library routine w/who arg & rest interface + ,(case (length nc*) + [(1) (build-libcall #t src sexpr op (car nc*) `(immediate ,(fix 0)))] + [(2) (build-libcall #t src sexpr op (car nc*) (cadr nc*))] + ; TODO: need fxargerr library routine w/who arg & rest interface + [else `(call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'op) ,nc* (... ...))])))))])])) ; NB: should be error call---but is it? + (fxlogop fxlogand logand -1) + (fxlogop fxand logand -1) + (fxlogop fxlogxor logxor 0) + (fxlogop fxxor logxor 0))) + (define-inline 3 fxlogtest + [(e1 e2) (%inline logtest ,e1 ,e2)]) + (define-inline 2 fxlogtest + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline logtest ,e1 ,e2) + ,(build-libcall #t src sexpr fxlogtest e1 e2)))]) + (let () + (define xorbits (lognot (constant mask-fixnum))) + (define-syntax fxlognotop + (syntax-rules () + [(_ name) + (begin + (define-inline 3 name + [(e) (%inline logxor ,e (immediate ,xorbits))]) + (define-inline 2 name + [(e) (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%inline logxor ,e (immediate ,xorbits)) + ,(build-libcall #t src sexpr name e)))]))])) + (fxlognotop fxlognot) + (fxlognotop fxnot)) + (define-inline 3 $fxu< + [(e1 e2) (or (relop-length RELOP< e1 e2) + (%inline u< ,e1 ,e2))]) + (define-inline 3 fx+ + [() `(immediate 0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (%inline + ,e1 ,e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + (define-inline 3 r6rs:fx+ ; limited to two arguments + [(e1 e2) (%inline + ,e1 ,e2)]) + (define-inline 3 fx+/wraparound + [(e1 e2) (%inline + ,e1 ,e2)]) + (define-inline 3 fx1+ + [(e) (%inline + ,e (immediate ,(fix 1)))]) + (define-inline 2 $fx+? + [(e1 e2) + (let ([Lfalse (make-local-label 'Lfalse)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Lfalse ,(%constant sfalse)) + ,t)) + (goto ,Lfalse))))]) + (let () + (define (go src sexpr e1 e2) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t (%inline +/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2)) + ,t)) + (goto ,Llib))))) + (define-inline 2 fx+ + [() `(immediate 0)] + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,e + ,(build-libcall #t #f sexpr fx+ e `(immediate ,(fix 0)))))] + [(e1 e2) (go src sexpr e1 e2)] + ; TODO: 3-operand case requires 3-operand library routine + #;[(e1 e2 e3) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2 e3) + `(if ,(build-fixnums? (list e1 e2 e3)) + ,(bind #t ([t (%inline +/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx+ e1 e2 e3)) + ,(bind #t ([t (%inline +/ovfl ,t ,e3)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (goto ,Llib) + ,t)))) + (goto ,Llib))))] + [(e1 . e*) #f]) + (define-inline 2 r6rs:fx+ ; limited to two arguments + [(e1 e2) (go src sexpr e1 e2)]) + (define-inline 2 fx+/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline + ,e1 ,e2) + ,(build-libcall #t src sexpr fx+/wraparound e1 e2)))])) + + (define-inline 3 fx- + [(e) (%inline - (immediate 0) ,e)] + [(e1 e2) (%inline - ,e1 ,e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + (define-inline 3 r6rs:fx- ; limited to one or two arguments + [(e) (%inline - (immediate 0) ,e)] + [(e1 e2) (%inline - ,e1 ,e2)]) + (define-inline 3 fx-/wraparound + [(e1 e2) (%inline - ,e1 ,e2)]) + (define-inline 3 fx1- + [(e) (%inline - ,e (immediate ,(fix 1)))]) + (define-inline 2 $fx-? + [(e1 e2) + (let ([Lfalse (make-local-label 'Lfalse)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t (%inline -/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Lfalse ,(%constant sfalse)) + ,t)) + (goto ,Lfalse))))]) + (let () + (define (go src sexpr e1 e2) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2)) + ,t)) + (goto ,Llib))))) + (define-inline 2 fx- + [(e) (go src sexpr `(immediate ,(fix 0)) e)] + [(e1 e2) (go src sexpr e1 e2)] + ; TODO: 3-operand case requires 3-operand library routine + #;[(e1 e2 e3) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2 e3) + `(if ,(build-fixnums? (list e1 e2 e3)) + ,(bind #t ([t (%inline -/ovfl ,e1 ,e2)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx- e1 e2 e3)) + ,(bind #t ([t (%inline -/ovfl ,t ,e3)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (goto ,Llib) + ,t)))) + (goto ,Llib))))] + [(e1 . e*) #f]) + (define-inline 2 r6rs:fx- ; limited to one or two arguments + [(e) (go src sexpr `(immediate ,(fix 0)) e)] + [(e1 e2) (go src sexpr e1 e2)]) + (define-inline 2 fx-/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline - ,e1 ,e2) + ,(build-libcall #t src sexpr fx-/wraparound e1 e2)))])) + (define-inline 2 fx1- + [(e) (let ([Llib (make-local-label 'Llib)]) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(bind #t ([t (%inline -/ovfl ,e (immediate ,(fix 1)))]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx1- e)) + ,t)) + (goto ,Llib))))]) + (define-inline 2 fx1+ + [(e) (let ([Llib (make-local-label 'Llib)]) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(bind #f ([t (%inline +/ovfl ,e (immediate ,(fix 1)))]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx1+ e)) + ,t)) + (goto ,Llib))))]) + + (let () + (define fixnum-powers-of-two + (let f ([m 2] [e 1]) + (if (<= m (constant most-positive-fixnum)) + (cons (cons m e) (f (* m 2) (fx+ e 1))) + '()))) + (define-inline 3 fxdiv + [(e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (let ([a (assv d fixnum-powers-of-two)]) + (and a + (%inline logand + ,(%inline sra ,e1 (immediate ,(cdr a))) + (immediate ,(- (constant fixnum-factor))))))] + [else #f])]) + (define-inline 3 fxmod + [(e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (let ([a (assv d fixnum-powers-of-two)]) + (and a (%inline logand ,e1 (immediate ,(fix (- d 1))))))] + [else #f])]) + (let () + (define (build-fx* e1 e2 ovfl?) + (define (fx*-constant e n) + (if ovfl? + (%inline */ovfl ,e (immediate ,n)) + (cond + [(eqv? n 1) e] + [(eqv? n -1) (%inline - (immediate 0) ,e)] + [(eqv? n 2) (%inline sll ,e (immediate 1))] + [(eqv? n 3) + (bind #t (e) + (%inline + + ,(%inline + ,e ,e) + ,e))] + [(eqv? n 10) + (bind #t (e) + (%inline + + ,(%inline + + ,(%inline sll ,e (immediate 3)) + ,e) + ,e))] + [(assv n fixnum-powers-of-two) => + (lambda (a) (%inline sll ,e (immediate ,(cdr a))))] + [else (%inline * ,e (immediate ,n))]))) + (nanopass-case (L7 Expr) e2 + [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e1 d)] + [else + (nanopass-case (L7 Expr) e1 + [(quote ,d) (guard (target-fixnum? d)) (fx*-constant e2 d)] + [else + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(if ovfl? + (%inline */ovfl ,e1 ,t) + (%inline * ,e1 ,t))))])])) + (define-inline 3 fx* + [() `(immediate ,(fix 1))] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-fx* e1 e2 #f)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + (define-inline 3 r6rs:fx* ; limited to two arguments + [(e1 e2) (build-fx* e1 e2 #f)]) + (define-inline 3 fx*/wraparound + [(e1 e2) (build-fx* e1 e2 #f)]) + (let () + (define (go src sexpr e1 e2) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #t ([t (build-fx* e1 e2 #t)]) + `(if (inline ,(make-info-condition-code 'multiply-overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2)) + ,t)) + (goto ,Llib))))) + (define-inline 2 fx* + [() `(immediate ,(fix 1))] + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,e + ,(build-libcall #t src sexpr fx* e `(immediate ,(fix 0)))))] + [(e1 e2) (go src sexpr e1 e2)] + ; TODO: 3-operand case requires 3-operand library routine + #;[(e1 e2 e3) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e1 e2 e3) + `(if ,(build-fixnums? (list e1 e2 e3)) + ,(bind #t ([t (build-fx* e1 e2 #t)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Llib ,(build-libcall #t src sexpr fx* e1 e2 e3)) + ,(bind #t ([t (build-fx* t e3 #t)]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (goto ,Llib) + ,t)))) + (goto ,Llib))))] + [(e1 . e*) #f]) + (define-inline 2 r6rs:fx* ; limited to two arguments + [(e1 e2) (go src sexpr e1 e2)]) + (define-inline 2 fx*/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(build-fx* e1 e2 #f) + ,(build-libcall #t src sexpr fx*/wraparound e1 e2)))])) + (let () + (define build-fx/p2 + (lambda (e1 p2) + (bind #t (e1) + (build-fix + (%inline sra + ,(%inline + ,e1 + ,(%inline srl + ,(if (fx= p2 1) + e1 + (%inline sra ,e1 (immediate ,(fx- p2 1)))) + (immediate ,(fx- (constant fixnum-bits) p2)))) + (immediate ,(fx+ p2 (constant fixnum-offset)))))))) + + (define build-fx/ + (lambda (src sexpr e1 e2) + (or (nanopass-case (L7 Expr) e2 + [(quote ,d) + (let ([a (assv d fixnum-powers-of-two)]) + (and a (build-fx/p2 e1 (cdr a))))] + [else #f]) + (if (constant integer-divide-instruction) + (build-fix (%inline / ,e1 ,e2)) + `(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 '$fx/) + ,e1 ,e2))))) + + (define-inline 3 fx/ + [(e) (build-fx/ src sexpr `(quote 1) e)] + [(e1 e2) (build-fx/ src sexpr e1 e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxquotient + [(e) (build-fx/ src sexpr `(quote 1) e)] + [(e1 e2) (build-fx/ src sexpr e1 e2)] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxremainder + [(e1 e2) + (bind #t (e1 e2) + (%inline - ,e1 + ,(build-fx* + (build-fx/ src sexpr e1 e2) + e2 #f)))])) + (let () + (define-syntax build-fx + (lambda (x) + (syntax-case x () + [(_ op a1 a2) + #`(%inline op + #,(if (number? (syntax->datum #'a1)) + #`(immediate a1) + #`,a1) + #,(if (number? (syntax->datum #'a2)) + #`(immediate a2) + #`,a2))]))) + (define (build-popcount16 e) + (constant-case popcount-instruction + [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 16-bit + [else + (let ([x (make-tmp 'x 'uptr)] + [x2 (make-tmp 'x2 'uptr)] + [x3 (make-tmp 'x3 'uptr)] + [x4 (make-tmp 'x4 'uptr)]) + `(let ([,x ,(build-unfix e)]) + (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555))]) + (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333) (build-fx logand (build-fx srl x2 2) #x3333))]) + (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f)]) + ,(build-fix (build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x1f)))))))])) + (define (build-popcount32 e) + (constant-case popcount-instruction + [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed, since not specialized to 32-bit + [else + (let ([x (make-tmp 'x 'uptr)] + [x2 (make-tmp 'x2 'uptr)] + [x3 (make-tmp 'x3 'uptr)] + [x4 (make-tmp 'x4 'uptr)]) + `(let ([,x ,(build-unfix e)]) + (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x55555555))]) + (let ([,x3 ,(build-fx + (build-fx logand x2 #x33333333) (build-fx logand (build-fx srl x2 2) #x33333333))]) + (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f)]) + ,(build-fix (build-fx logand (build-fx srl (build-fx * x4 #x01010101) 24) #x3f)))))))])) + (define (build-popcount e) + (constant-case popcount-instruction + [(#t) (build-fix (%inline popcount ,e))] ; no unfix needed + [else + (constant-case ptr-bits + [(32) (build-popcount32 e)] + [(64) + (let ([x (make-tmp 'x 'uptr)] + [x2 (make-tmp 'x2 'uptr)] + [x3 (make-tmp 'x3 'uptr)] + [x4 (make-tmp 'x4 'uptr)] + [x5 (make-tmp 'x5 'uptr)]) + `(let ([,x ,e]) ; no unfix needed + (let ([,x2 ,(build-fx - x (build-fx logand (build-fx srl x 1) #x5555555555555555))]) + (let ([,x3 ,(build-fx + (build-fx logand x2 #x3333333333333333) (build-fx logand (build-fx srl x2 2) #x3333333333333333))]) + (let ([,x4 ,(build-fx logand (build-fx + x3 (build-fx srl x3 4)) #x0f0f0f0f0f0f0f0f)]) + (let ([,x5 ,(build-fx logand (build-fx + x4 (build-fx srl x4 8)) #x00ff00ff00ff00ff)]) + ,(build-fix (build-fx logand (build-fx srl (build-fx * x5 #x0101010101010101) 56) #x7f))))))))])])) + (define-inline 3 fxpopcount + [(e) + (bind #f (e) + (build-popcount e))]) + (define-inline 2 fxpopcount + [(e) + (bind #t (e) + `(if ,(build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline >= ,e (immediate ,0))) + ,(build-popcount e) + ,(build-libcall #t #f sexpr fxpopcount e)))]) + (define-inline 3 fxpopcount32 + [(e) + (bind #f (e) + (build-popcount32 e))]) + (define-inline 2 fxpopcount32 + [(e) + (bind #t (e) + `(if ,(constant-case ptr-bits + [(32) + (build-and (%type-check mask-fixnum type-fixnum ,e) + (%inline >= ,e (immediate ,0)))] + [(64) + (build-and (%type-check mask-fixnum type-fixnum ,e) + (%inline u< ,e (immediate ,(fix #x100000000))))]) + ,(build-popcount32 e) + ,(build-libcall #t #f sexpr fxpopcount32 e)))]) + (define-inline 3 fxpopcount16 + [(e) + (bind #f (e) + (build-popcount16 e))]) + (define-inline 2 fxpopcount16 + [(e) + (bind #f (e) + `(if ,(build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< ,e (immediate ,(fix #x10000)))) + ,(build-popcount16 e) + ,(build-libcall #t #f sexpr fxpopcount16 e)))])))) + (let () + (define do-fxsll + (lambda (e1 e2) + (nanopass-case (L7 Expr) e2 + [(quote ,d) + (%inline sll ,e1 (immediate ,d))] + [else + ; TODO: bind-uptr might be handy here and also a make-unfix + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(%inline sll ,e1 ,t)))]))) + (define-inline 3 fxsll + [(e1 e2) (do-fxsll e1 e2)]) + (define-inline 3 fxarithmetic-shift-left + [(e1 e2) (do-fxsll e1 e2)]) + (define-inline 3 fxsll/wraparound + [(e1 e2) (do-fxsll e1 e2)])) + (define-inline 3 fxsrl + [(e1 e2) + (%inline logand + ,(nanopass-case (L7 Expr) e2 + [(quote ,d) + (%inline srl ,e1 (immediate ,d))] + [else + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(%inline srl ,e1 ,t)))]) + (immediate ,(fx- (constant fixnum-factor))))]) + (let () + (define do-fxsra + (lambda (e1 e2) + (%inline logand + ,(nanopass-case (L7 Expr) e2 + [(quote ,d) + (%inline sra ,e1 (immediate ,d))] + [else + (let ([t (make-tmp 't 'uptr)]) + `(let ([,t ,(build-unfix e2)]) + ,(%inline sra ,e1 ,t)))]) + (immediate ,(fx- (constant fixnum-factor)))))) + (define-inline 3 fxsra + [(e1 e2) (do-fxsra e1 e2)]) + (define-inline 3 fxarithmetic-shift-right + [(e1 e2) (do-fxsra e1 e2)])) + (let () + (define-syntax %safe-shift + (syntax-rules () + [(_ src sexpr op libcall e1 e2 ?size) + (let ([size ?size]) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- size 1)))) e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1)) + ,(%inline logand + ,(%inline op ,e1 (immediate ,(constant-value e2))) + (immediate ,(- (constant fixnum-factor)))) + ,(build-libcall #t src sexpr libcall e1 e2))) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix size)))) + ,(%inline logand + ,(%inline op ,e1 ,(build-unfix e2)) + (immediate ,(- (constant fixnum-factor)))) + ,(build-libcall #t src sexpr libcall e1 e2)))))])) + (define-inline 2 fxsrl + [(e1 e2) (%safe-shift src sexpr srl fxsrl e1 e2 (+ (constant fixnum-bits) 1))]) + (define-inline 2 fxsra + [(e1 e2) (%safe-shift src sexpr sra fxsra e1 e2 (+ (constant fixnum-bits) 1))]) + (define-inline 2 fxarithmetic-shift-right + [(e1 e2) (%safe-shift src sexpr sra fxarithmetic-shift-right e1 e2 (constant fixnum-bits))])) + (define-inline 3 fxarithmetic-shift + [(e1 e2) + (or (nanopass-case (L7 Expr) e2 + [(quote ,d) + (and (fixnum? d) + (if ($fxu< d (constant fixnum-bits)) + (%inline sll ,e1 (immediate ,d)) + (and (fx< (fx- (constant fixnum-bits)) d 0) + (%inline logand + ,(%inline sra ,e1 (immediate ,(fx- d))) + (immediate ,(- (constant fixnum-factor)))))))] + [else #f]) + (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) + (define-inline 2 fxarithmetic-shift + [(e1 e2) + (or (nanopass-case (L7 Expr) e2 + [(quote ,d) + (guard (fixnum? d) (fx< (fx- (constant fixnum-bits)) d 0)) + (bind #t (e1) + `(if ,(build-fixnums? (list e1)) + ,(%inline logand + ,(%inline sra ,e1 (immediate ,(fx- d))) + (immediate ,(- (constant fixnum-factor)))) + ,(build-libcall #t src sexpr fxarithmetic-shift e1 e2)))] + [else #f]) + (build-libcall #f src sexpr fxarithmetic-shift e1 e2))]) + (let () + (define dofxlogbit0 + (lambda (e1 e2) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (%inline logand ,e1 + (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) + (%inline logand ,e1 + ,(%inline lognot + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2))))))) + (define dofxlogbit1 + (lambda (e1 e2) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (%inline logor ,e1 + (immediate ,(fix (ash 1 (constant-value e2))))) + (%inline logor ,e1 + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2)))))) + (define-inline 3 fxlogbit0 + [(e1 e2) (dofxlogbit0 e2 e1)]) + (define-inline 3 fxlogbit1 + [(e1 e2) (dofxlogbit1 e2 e1)]) + (define-inline 3 fxcopy-bit + [(e1 e2 e3) + ;; NB: even in the case where e3 is not known to be 0 or 1, seems like we could do better here. + (and (fixnum-constant? e3) + (case (constant-value e3) + [(0) (dofxlogbit0 e1 e2)] + [(1) (dofxlogbit1 e1 e2)] + [else #f]))])) + (let () + (define dofxlogbit0 + (lambda (e1 e2 libcall) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (bind #t (e1) + `(if ,(build-fixnums? (list e1)) + ,(%inline logand ,e1 + (immediate ,(fix (lognot (ash 1 (constant-value e2)))))) + ,(libcall e1 e2))) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logand ,e1 + ,(%inline lognot + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2)))) + ,(libcall e1 e2)))))) + (define dofxlogbit1 + (lambda (e1 e2 libcall) + (if (constant? (lambda (x) (and (fixnum? x) ($fxu< x (fx- (constant fixnum-bits) 1)))) e2) + (bind #t (e1) + `(if ,(build-fixnums? (list e1)) + ,(%inline logor ,e1 + (immediate ,(fix (ash 1 (constant-value e2))))) + ,(libcall e1 e2))) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logor ,e1 + ,(%inline sll (immediate ,(fix 1)) + ,(build-unfix e2))) + ,(libcall e1 e2)))))) + (define-inline 2 fxlogbit0 + [(e1 e2) (dofxlogbit0 e2 e1 + (lambda (e2 e1) + (build-libcall #t src sexpr fxlogbit0 e1 e2)))]) + (define-inline 2 fxlogbit1 + [(e1 e2) (dofxlogbit1 e2 e1 + (lambda (e2 e1) + (build-libcall #t src sexpr fxlogbit1 e1 e2)))]) + (define-inline 2 fxcopy-bit + [(e1 e2 e3) + (and (fixnum-constant? e3) + (case (constant-value e3) + [(0) (dofxlogbit0 e1 e2 + (lambda (e1 e2) + (build-libcall #t src sexpr fxcopy-bit e1 e2)))] + [(1) (dofxlogbit1 e1 e2 + (lambda (e1 e2) + (build-libcall #t src sexpr fxcopy-bit e1 e2)))] + [else #f]))])) + (define-inline 3 fxzero? + [(e) (or (relop-length RELOP= e) (%inline eq? ,e (immediate 0)))]) + (define-inline 3 fxpositive? + [(e) (or (relop-length RELOP> e) (%inline > ,e (immediate 0)))]) + (define-inline 3 fxnonnegative? + [(e) (or (relop-length RELOP>= e) (%inline >= ,e (immediate 0)))]) + (define-inline 3 fxnegative? + [(e) (or (relop-length RELOP< e) (%inline < ,e (immediate 0)))]) + (define-inline 3 fxnonpositive? + [(e) (or (relop-length RELOP<= e) (%inline <= ,e (immediate 0)))]) + (define-inline 3 fxeven? + [(e) (%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 0)))]) + (define-inline 3 fxodd? + [(e) (%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 1)))]) + + (define-inline 2 fxzero? + [(e) (or (relop-length RELOP= e) + (bind #t (e) + (build-simple-or + (%inline eq? ,e (immediate 0)) + `(if ,(build-fixnums? (list e)) + ,(%constant sfalse) + ,(build-libcall #t src sexpr fxzero? e)))))]) + (define-inline 2 fxpositive? + [(e) (or (relop-length RELOP> e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline > ,e (immediate 0)) + ,(build-libcall #t src sexpr fxpositive? e))))]) + (define-inline 2 fxnonnegative? + [(e) (or (relop-length RELOP>= e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline >= ,e (immediate 0)) + ,(build-libcall #t src sexpr fxnonnegative? e))))]) + (define-inline 2 fxnegative? + [(e) (or (relop-length RELOP< e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline < ,e (immediate 0)) + ,(build-libcall #t src sexpr fxnegative? e))))]) + (define-inline 2 fxnonpositive? + [(e) (or (relop-length RELOP<= e) + (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline <= ,e (immediate 0)) + ,(build-libcall #t src sexpr fxnonpositive? e))))]) + (define-inline 2 fxeven? + [(e) (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 0))) + ,(build-libcall #t src sexpr fxeven? e)))]) + (define-inline 2 fxodd? + [(e) (bind #t (e) + `(if ,(build-fixnums? (list e)) + ,(%inline eq? + ,(%inline logand ,e (immediate ,(fix 1))) + (immediate ,(fix 1))) + ,(build-libcall #t src sexpr fxodd? e)))]) + (let () + (define dofxlogbit? + (lambda (e1 e2) + (cond + [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) + (%inline logtest ,e2 (immediate ,(fix (ash 1 (constant-value e1)))))] + [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) + (%inline < ,e2 (immediate ,(fix 0)))] + [(fixnum-constant? e2) + (bind #t (e1) + `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) + ,(if (< (constant-value e2) 0) (%constant strue) (%constant sfalse)) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1)))))] + [else + (bind #t (e1 e2) + `(if ,(%inline < (immediate ,(fix (fx- (constant fixnum-bits) 2))) ,e1) + ,(%inline < ,e2 (immediate ,(fix 0))) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1)))))]))) + + (define-inline 3 fxbit-set? + [(e1 e2) (dofxlogbit? e2 e1)]) + + (define-inline 3 fxlogbit? + [(e1 e2) (dofxlogbit? e1 e2)])) + + (let () + (define dofxlogbit? + (lambda (e1 e2 libcall) + (cond + [(constant? (lambda (x) (and (fixnum? x) (fx<= 0 x (fx- (constant fixnum-bits) 2)))) e1) + (bind #t (e2) + `(if ,(build-fixnums? (list e2)) + ,(%inline logtest ,e2 + (immediate ,(fix (ash 1 (constant-value e1))))) + ,(libcall e1 e2)))] + [(constant? (lambda (x) (and (target-fixnum? x) (> x (fx- (constant fixnum-bits) 2)))) e1) + (bind #t (e2) + `(if ,(build-fixnums? (list e2)) + ,(%inline < ,e2 (immediate ,(fix 0))) + ,(libcall e1 e2)))] + [else + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1))) + ,(libcall e1 e2)))]))) + + (define-inline 2 fxbit-set? + [(e1 e2) (dofxlogbit? e2 e1 + (lambda (e2 e1) + (build-libcall #t src sexpr fxbit-set? e1 e2)))]) + (define-inline 2 fxlogbit? + [(e1 e2) (dofxlogbit? e1 e2 + (lambda (e1 e2) + (build-libcall #t src sexpr fxlogbit? e1 e2)))])) + + ; can avoid if in fxabs with: + ; t = sra(x, k) ; where k is ptr-bits - 1 + ; ; t is now -1 if x's sign bit set, otherwise 0 + ; x = xor(x, t) ; logical not if x negative, otherwise leave x alone + ; x = x - t ; add 1 to complete two's complement negation if + ; ; x was negative, otherwise leave x alone + ; tests on i3le indicate that the if is actually faster, even in a loop + ; where input alternates between positive and negative to defeat branch + ; prediction. + (define-inline 3 fxabs + [(e) (bind #t (e) + `(if ,(%inline < ,e (immediate ,(fix 0))) + ,(%inline - (immediate ,(fix 0)) ,e) + ,e))]) + + ;(define-inline 3 min ; needs library min + ; ; must take care to be inexactness-preserving + ; [(e0) e0] + ; [(e0 e1) + ; (bind #t (e0 e1) + ; `(if ,(build-fixnums? (list e0 e1)) + ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) + ; ,(build-libcall #t src sexpr min e0 e1)))] + ; [(e0 . e*) (reduce src sexpr moi e1 e*)]) + ; + ;(define-inline 3 max ; needs library max + ; ; must take care to be inexactness-preserving + ; [(e0) e0] + ; [(e0 e1) + ; (bind #t (e0 e1) + ; `(if ,(build-fixnums? (list e0 e1)) + ; (if ,(%inline < ,e0 ,e1) ,e0 ,e1) + ; ,(build-libcall #t src sexpr max e0 e1)))] + ; [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxmin + [(e) (ensure-single-valued e)] + [(e1 e2) (bind #t (e1 e2) + `(if ,(%inline < ,e1 ,e2) + ,e1 + ,e2))] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxmax + [(e) (ensure-single-valued e)] + [(e1 e2) (bind #t (e1 e2) + `(if ,(%inline < ,e2 ,e1) + ,e1 + ,e2))] + [(e1 . e*) (reduce src sexpr moi e1 e*)]) + + (define-inline 3 fxif + [(e1 e2 e3) + (bind #t (e1) + (%inline logor + ,(%inline logand ,e2 ,e1) + ,(%inline logand ,e3 + ,(%inline lognot ,e1))))]) + + (define-inline 3 fxbit-field + [(e1 e2 e3) + (and (constant? fixnum? e2) (constant? fixnum? e3) + (let ([start (constant-value e2)] [end (constant-value e3)]) + (if (fx= end start) + (%seq ,e1 (immediate ,(fix 0))) + (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) + (extract-unsigned-bitfield #f start end e1)))))]) + + (define-inline 3 fxcopy-bit-field + [(e1 e2 e3 e4) + (and (constant? fixnum? e2) (constant? fixnum? e3) + (let ([start (constant-value e2)] [end (constant-value e3)]) + (if (fx= end start) + e1 + (and (and (fx>= start 0) (fx> end start) (fx< end (constant fixnum-bits))) + (insert-bitfield #f start end (constant fixnum-bits) e1 e4)))))]) + + ;; could be done with one mutable variable instead of two, but this seems to generate + ;; the same code as the existing compiler + (define-inline 3 fxlength + [(e) + (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) + `(let ([,t ,(build-unfix e)]) + (seq + (if ,(%inline < ,t (immediate 0)) + (set! ,t ,(%inline lognot ,t)) + ,(%constant svoid)) + (let ([,result (immediate ,(fix 0))]) + ,((lambda (body) + (constant-case fixnum-bits + [(30) body] + [(61) + `(seq + (if ,(%inline < ,t (immediate #x100000000)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 32))) + (set! ,result + ,(%inline + ,result (immediate ,(fix 32)))))) + ,body)])) + (%seq + (if ,(%inline < ,t (immediate #x10000)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 16))) + (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) + (if ,(%inline < ,t (immediate #x100)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 8))) + (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) + ,(%inline + ,result + (inline ,(make-info-load 'unsigned-8 #f) ,%load + ,(%tc-ref fxlength-bv) ,t + ,(%constant bytevector-data-disp)))))))))]) + + (define-inline 3 fxfirst-bit-set + [(e) + (let ([t (make-assigned-tmp 't 'uptr)] [result (make-assigned-tmp 'result)]) + (bind #t (e) + `(if ,(%inline eq? ,e (immediate ,(fix 0))) + (immediate ,(fix -1)) + (let ([,t ,(build-unfix e)] [,result (immediate ,(fix 0))]) + ,((lambda (body) + (constant-case fixnum-bits + [(30) body] + [(61) + `(seq + (if ,(%inline logtest ,t (immediate #xffffffff)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 32))) + (set! ,result ,(%inline + ,result (immediate ,(fix 32)))))) + ,body)])) + (%seq + (if ,(%inline logtest ,t (immediate #xffff)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 16))) + (set! ,result ,(%inline + ,result (immediate ,(fix 16)))))) + (if ,(%inline logtest ,t (immediate #xff)) + ,(%constant svoid) + (seq + (set! ,t ,(%inline srl ,t (immediate 8))) + (set! ,result ,(%inline + ,result (immediate ,(fix 8)))))) + ,(%inline + ,result + (inline ,(make-info-load 'unsigned-8 #f) ,%load + ,(%tc-ref fxfirst-bit-set-bv) + ,(%inline logand ,t (immediate #xff)) + ,(%constant bytevector-data-disp)))))))))]) + + (let () + (define-syntax type-pred + (syntax-rules () + [(_ name? mask type) + (define-inline 2 name? + [(e) (%type-check mask type ,e)])])) + (define-syntax typed-object-pred + (syntax-rules () + [(_ name? mask type) + (define-inline 2 name? + [(e) + (bind #t (e) + (%typed-object-check mask type ,e))])])) + (type-pred boolean? mask-boolean type-boolean) + (type-pred bwp-object? mask-bwp sbwp) + (type-pred char? mask-char type-char) + (type-pred eof-object? mask-eof seof) + (type-pred fixnum? mask-fixnum type-fixnum) + (type-pred flonum? mask-flonum type-flonum) + (type-pred null? mask-nil snil) + (type-pred pair? mask-pair type-pair) + (type-pred procedure? mask-closure type-closure) + (type-pred symbol? mask-symbol type-symbol) + (type-pred $unbound-object? mask-unbound sunbound) + (typed-object-pred bignum? mask-bignum type-bignum) + (typed-object-pred box? mask-box type-box) + (typed-object-pred mutable-box? mask-mutable-box type-mutable-box) + (typed-object-pred immutable-box? mask-mutable-box type-immutable-box) + (typed-object-pred bytevector? mask-bytevector type-bytevector) + (typed-object-pred mutable-bytevector? mask-mutable-bytevector type-mutable-bytevector) + (typed-object-pred immutable-bytevector? mask-mutable-bytevector type-immutable-bytevector) + (typed-object-pred $code? mask-code type-code) + (typed-object-pred $exactnum? mask-exactnum type-exactnum) + (typed-object-pred fxvector? mask-fxvector type-fxvector) + (typed-object-pred flvector? mask-flvector type-flvector) + (typed-object-pred $inexactnum? mask-inexactnum type-inexactnum) + (typed-object-pred $rtd-counts? mask-rtd-counts type-rtd-counts) + (typed-object-pred phantom-bytevector? mask-phantom type-phantom) + (typed-object-pred input-port? mask-input-port type-input-port) + (typed-object-pred output-port? mask-output-port type-output-port) + (typed-object-pred port? mask-port type-port) + (typed-object-pred ratnum? mask-ratnum type-ratnum) + (typed-object-pred $record? mask-record type-record) + (typed-object-pred string? mask-string type-string) + (typed-object-pred mutable-string? mask-mutable-string type-mutable-string) + (typed-object-pred immutable-string? mask-mutable-string type-immutable-string) + (typed-object-pred $system-code? mask-system-code type-system-code) + (typed-object-pred $tlc? mask-tlc type-tlc) + (typed-object-pred vector? mask-vector type-vector) + (typed-object-pred mutable-vector? mask-mutable-vector type-mutable-vector) + (typed-object-pred immutable-vector? mask-mutable-vector type-immutable-vector) + (typed-object-pred stencil-vector? mask-stencil-vector type-stencil-vector) + (typed-object-pred thread? mask-thread type-thread)) + (define-inline 3 $bigpositive? + [(e) (%type-check mask-signed-bignum type-positive-bignum + ,(%mref ,e ,(constant bignum-type-disp)))]) + (define-inline 3 csv7:record-field-accessible? + [(e1 e2) (%seq ,e1 ,e2 ,(%constant strue))]) + + (define-inline 2 cflonum? + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,(%constant strue) + ,(%typed-object-check mask-inexactnum type-inexactnum ,e)))]) + (define-inline 2 $immediate? + [(e) (bind #t (e) (%type-check mask-immediate type-immediate ,e))]) + (define-inline 3 $fixmediate + [(e) e]) + + (define-inline 3 $inexactnum-real-part + [(e) (build-$inexactnum-real-part e)]) + (define-inline 3 $inexactnum-imag-part + [(e) (build-$inexactnum-imag-part e)]) + + (define-inline 3 cfl-real-part + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,e + ,(build-$inexactnum-real-part e)))]) + + (define-inline 3 cfl-imag-part + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + (quote 0.0) + ,(build-$inexactnum-imag-part e)))]) + + (define-inline 3 $closure-ref + [(e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant closure-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant closure-data-disp))])]) + (define-inline 3 $closure-set! + [(e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant closure-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant closure-data-disp) e-new)])]) + (define-inline 3 $closure-code + [(e) (%inline - + ,(%mref ,e ,(constant closure-code-disp)) + ,(%constant code-data-disp))]) + (define-inline 3 $code-free-count + [(e) (build-fix (%mref ,e ,(constant code-closure-length-disp)))]) + (define-inline 3 $code-mutable-closure? + [(e) (%typed-object-check mask-code-mutable-closure type-code-mutable-closure ,e)]) + (define-inline 3 $code-arity-in-closure? + [(e) (%typed-object-check mask-code-arity-in-closure type-code-arity-in-closure ,e)]) + (define-inline 3 $code-single-valued? + [(e) (%typed-object-check mask-code-single-valued type-code-single-valued ,e)]) + (define-inline 2 $unbound-object + [() `(quote ,($unbound-object))]) + (define-inline 2 void + [() `(quote ,(void))]) + (define-inline 2 eof-object + [() `(quote #!eof)]) + (define-inline 2 cons + [(e1 e2) + (bind #f (e1 e2) + (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) + (%seq + (set! ,(%mref ,t ,(constant pair-car-disp)) ,e1) + (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e2) + ,t)))]) + (define-inline 2 box + [(e) + (bind #f (e) + (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) + (%seq + (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-box)) + (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) + ,t)))]) + (define-inline 2 box-immutable + [(e) + (bind #f (e) + (bind #t ([t (%constant-alloc type-typed-object (constant size-box))]) + (%seq + (set! ,(%mref ,t ,(constant box-type-disp)) ,(%constant type-immutable-box)) + (set! ,(%mref ,t ,(constant box-ref-disp)) ,e) + ,t)))]) + (define-inline 3 $make-tlc + [(e-ht e-keyval e-next) + (bind #f (e-ht e-keyval e-next) + (bind #t ([t (%constant-alloc type-typed-object (constant size-tlc))]) + (%seq + (set! ,(%mref ,t ,(constant tlc-type-disp)) ,(%constant type-tlc)) + (set! ,(%mref ,t ,(constant tlc-ht-disp)) ,e-ht) + (set! ,(%mref ,t ,(constant tlc-keyval-disp)) ,e-keyval) + (set! ,(%mref ,t ,(constant tlc-next-disp)) ,e-next) + ,t)))]) + (define-inline 2 list + [e* (build-list e*)]) + (let () + (define (go e e*) + (bind #f (e) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-pair (fx* (constant size-pair) (length e*)))]) + (let loop ([e e] [e* e*] [i 0]) + (let ([e2 (car e*)] [e* (cdr e*)]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-car-disp))) ,e) + ,(if (null? e*) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) ,e2) + ,t) + (let ([next-i (fx+ i (constant size-pair))]) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant pair-cdr-disp))) + ,(%inline + ,t (immediate ,next-i))) + ,(loop e2 e* next-i))))))))))) + (define-inline 2 list* + [(e) (ensure-single-valued e)] + [(e . e*) (go e e*)]) + (define-inline 2 cons* + [(e) (ensure-single-valued e)] + [(e . e*) (go e e*)])) + (define-inline 2 vector + [() `(quote #())] + [e* + (let ([n (length e*)]) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-vector) (fx* n (constant ptr-bytes))))]) + (let loop ([e* e*] [i 0]) + (if (null? e*) + `(seq + (set! ,(%mref ,t ,(constant vector-type-disp)) + (immediate ,(+ (fx* n (constant vector-length-factor)) + (constant type-vector)))) + ,t) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant vector-data-disp))) ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))]) + (let () + (define (go e*) + (let ([n (length e*)]) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-fxvector) (fx* n (constant ptr-bytes))))]) + (let loop ([e* e*] [i 0]) + (if (null? e*) + `(seq + (set! ,(%mref ,t ,(constant fxvector-type-disp)) + (immediate ,(+ (fx* n (constant fxvector-length-factor)) + (constant type-fxvector)))) + ,t) + `(seq + (set! ,(%mref ,t ,(fx+ i (constant fxvector-data-disp))) ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant ptr-bytes)))))))))) + (define-inline 2 fxvector + [() `(quote #vfx())] + [e* (and (andmap (lambda (x) (constant? target-fixnum? x)) e*) (go e*))]) + (define-inline 3 fxvector + [() `(quote #vfx())] + [e* (go e*)])) + (let () + (define (go e*) + (let ([n (length e*)]) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-flvector) (fx* n (constant flonum-bytes))))]) + (let loop ([e* e*] [i 0]) + (if (null? e*) + `(seq + (set! ,(%mref ,t ,(constant flvector-type-disp)) + (immediate ,(+ (fx* n (constant flvector-length-factor)) + (constant type-flvector)))) + ,t) + `(seq + (set! ,(%mref ,t ,%zero ,(fx+ i (constant flvector-data-disp)) fp) ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant flonum-bytes)))))))))) + (define-inline 2 flvector + [() `(quote #vfl())] + [e* (and (andmap (lambda (x) (constant? flonum? x)) e*) (go e*))]) + (define-inline 3 flvector + [() `(quote #vfl())] + [e* (go e*)])) + (let () + (define (go e*) + (let ([n (length e*)]) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-string) (fx* n (constant string-char-bytes))))]) + (let loop ([e* e*] [i 0]) + (if (null? e*) + `(seq + (set! ,(%mref ,t ,(constant string-type-disp)) + (immediate ,(+ (fx* n (constant string-length-factor)) + (constant type-string)))) + ,t) + `(seq + (inline ,(make-info-load (string-char-type) #f) ,%store ,t ,%zero + (immediate ,(fx+ i (constant string-data-disp))) + ,(car e*)) + ,(loop (cdr e*) (fx+ i (constant string-char-bytes)))))))))) + (define-inline 2 string + [() `(quote "")] + [e* (and (andmap (lambda (x) (constant? char? x)) e*) (go e*))]) + (define-inline 3 string + [() `(quote "")] + [e* (go e*)])) + (let () ; level 2 car, cdr, caar, etc. + (define-syntax def-c..r* + (lambda (x) + (define (go ad*) + (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) + #`(define-inline 2 #,id + [(e) (let ([Lerr (make-local-label 'Lerr)]) + #,(let f ([ad* ad*]) + (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] + [ad* (cdr ad*)]) + (if (null? ad*) + #`(bind #t (e) + `(if ,(build-pair? e) + ,(#,builder e) + (label ,Lerr ,(build-libcall #t src sexpr #,id e)))) + #`(bind #t ([t #,(f ad*)]) + `(if ,(build-pair? t) + ,(#,builder t) + (goto ,Lerr)))))))]))) + (let f ([n 4] [ad* '()]) + (let ([f (lambda (ad*) + (let ([defn (go ad*)]) + (if (fx= n 1) + defn + #`(begin #,defn #,(f (fx- n 1) ad*)))))]) + #`(begin + #,(f (cons #\a ad*)) + #,(f (cons #\d ad*))))))) + def-c..r*) + (let () ; level 3 car, cdr, caar, etc. + (define-syntax def-c..r* + (lambda (x) + (define (go ad*) + (let ([id (datum->syntax #'* (string->symbol (format "c~{~a~}r" ad*)))]) + #`(define-inline 3 #,id + [(e) #,(let f ([ad* ad*]) + (let ([builder (if (char=? (car ad*) #\a) #'build-car #'build-cdr)] + [ad* (cdr ad*)]) + (if (null? ad*) + #`(#,builder e) + #`(#,builder #,(f ad*)))))]))) + (let f ([n 4] [ad* '()]) + (let ([f (lambda (ad*) + (let ([defn (go ad*)]) + (if (fx= n 1) + defn + #`(begin #,defn #,(f (fx- n 1) ad*)))))]) + #`(begin + #,(f (cons #\a ad*)) + #,(f (cons #\d ad*))))))) + def-c..r*) + (let () ; level 3 simple accessors, e.g., unbox, vector-length + (define-syntax inline-accessor + (syntax-rules () + [(_ prim disp) + (define-inline 3 prim + [(e) (%mref ,e ,(constant disp))])])) + (inline-accessor unbox box-ref-disp) + (inline-accessor $symbol-name symbol-name-disp) + (inline-accessor $symbol-property-list symbol-plist-disp) + (inline-accessor $system-property-list symbol-splist-disp) + (inline-accessor $symbol-hash symbol-hash-disp) + (inline-accessor $ratio-numerator ratnum-numerator-disp) + (inline-accessor $ratio-denominator ratnum-denominator-disp) + (inline-accessor $exactnum-real-part exactnum-real-disp) + (inline-accessor $exactnum-imag-part exactnum-imag-disp) + (inline-accessor binary-port-input-buffer port-ibuffer-disp) + (inline-accessor textual-port-input-buffer port-ibuffer-disp) + (inline-accessor binary-port-output-buffer port-obuffer-disp) + (inline-accessor textual-port-output-buffer port-obuffer-disp) + (inline-accessor $code-name code-name-disp) + (inline-accessor $code-arity-mask code-arity-mask-disp) + (inline-accessor $code-info code-info-disp) + (inline-accessor $code-pinfo* code-pinfo*-disp) + (inline-accessor $continuation-link continuation-link-disp) + (inline-accessor $continuation-winders continuation-winders-disp) + (inline-accessor $continuation-attachments continuation-attachments-disp) + (inline-accessor csv7:record-type-descriptor record-type-disp) + (inline-accessor $record-type-descriptor record-type-disp) + (inline-accessor record-rtd record-type-disp) + (inline-accessor record-type-uid record-type-uid-disp) + (inline-accessor $port-handler port-handler-disp) + (inline-accessor $port-info port-info-disp) + (inline-accessor port-name port-name-disp) + (inline-accessor $thread-tc thread-tc-disp) + ) + (constant-case architecture + [(pb) + ;; Don't try to inline seginfo access, because the C pointer size used + ;; in the table may not match the 64-bit `ptr` size + (void)] + [else + (let () + (define (build-seginfo maybe? e) + (let ([ptr (make-assigned-tmp 'ptr)] + [seginfo (make-assigned-tmp 'seginfo)]) + (define (build-level-3 seginfo k) + (constant-case segment-table-levels + [(3) + (let ([s3 (make-assigned-tmp 's3)]) + `(let ([,s3 ,(%mref ,seginfo + ,(%inline sll ,(%inline srl ,ptr (immediate ,(+ (constant segment-t1-bits) + (constant segment-t2-bits)))) + (immediate ,(constant log2-ptr-bytes))) + ,0)]) + ,(if maybe? + `(if ,(%inline eq? ,s3 (immediate 0)) + (immediate 0) + ,(k s3)) + (k s3))))] + [else (k seginfo)])) + (define (build-level-2 s3 k) + (constant-case segment-table-levels + [(2 3) + (let ([s2 (make-assigned-tmp 's2)]) + `(let ([,s2 ,(%mref ,s3 ,(%inline logand + ,(%inline srl ,ptr (immediate ,(fx- (constant segment-t1-bits) + (constant log2-ptr-bytes)))) + (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1) + (constant log2-ptr-bytes)))) + 0)]) + ,(if maybe? + `(if ,(%inline eq? ,s2 (immediate 0)) + (immediate 0) + ,(k s2)) + (k s2))))] + [else (k s3)])) + `(let ([,ptr ,(%inline srl ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) + (immediate ,(constant segment-offset-bits)))]) + (let ([,seginfo (literal ,(make-info-literal #f 'entry (lookup-c-entry segment-info) 0))]) + ,(build-level-3 seginfo + (lambda (s3) + (build-level-2 s3 + (lambda (s2) + (%mref ,s2 ,(%inline sll ,(%inline logand ,ptr + (immediate ,(fx- (fxsll 1 (constant segment-t1-bits)) 1))) + (immediate ,(constant log2-ptr-bytes))) + 0))))))))) + (define (build-space-test e space) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + (if ,(%type-check mask-immediate type-immediate ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #T e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,(let ([s `(inline ,(make-info-load 'unsigned-8 #f) ,%load ,si ,%zero (immediate 0))]) + (%inline eq? (immediate ,space) ,s)))))))) + + (define-inline 2 $maybe-seginfo + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + (if ,(%type-check mask-immediate type-immediate ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #t e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,si))))))]) + (define-inline 2 $seginfo + [(e) + (bind #t (e) (build-seginfo #f e))]) + (define-inline 2 $seginfo-generation + [(e) + (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))]) + (define-inline 2 $seginfo-space + [(e) + (bind #f (e) + (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-space-disp)))]) + (define-inline 2 $list-bits-ref + [(e) + (bind #t (e) + (let ([si (make-assigned-tmp 'si)] + [list-bits (make-assigned-tmp 'list-bits)] + [offset (make-assigned-tmp 'offset)] + [byte (make-assigned-tmp 'byte)]) + `(let ([,si ,(build-seginfo #f e)]) + (let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))]) + (if ,(%inline eq? ,list-bits (immediate 0)) + (immediate 0) + (let ([,offset ,(%inline srl ,(%inline logand ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) + (immediate ,(fx- (constant bytes-per-segment) 1))) + (immediate ,(constant log2-ptr-bytes)))]) + (let ([,byte (inline ,(make-info-load 'unsigned-8 #f) ,%load ,list-bits ,%zero ,(%inline srl ,offset (immediate 3)))]) + ,(build-fix (%inline logand ,(%inline srl ,byte ,(%inline logand ,offset (immediate 7))) + (immediate ,(constant list-bits-mask)))))))))))]) + (define-inline 2 $generation + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #t e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,(build-object-ref #f 'unsigned-8 si %zero 1))))))]) + (define-inline 2 weak-pair? + [(e) (bind #t (e) (build-space-test e (constant space-weakpair)))]) + (define-inline 2 ephemeron-pair? + [(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))]))]) + + (define-inline 2 unbox + [(e) + (bind #t (e) + `(if ,(%typed-object-check mask-box type-box ,e) + ,(%mref ,e ,(constant box-ref-disp)) + ,(build-libcall #t src sexpr unbox e)))]) + (let () + (define-syntax def-len + (syntax-rules () + [(_ prim type-disp length-offset) + (define-inline 3 prim + [(e) (extract-length (%mref ,e ,(constant type-disp)) (constant length-offset))])])) + (def-len vector-length vector-type-disp vector-length-offset) + (def-len fxvector-length fxvector-type-disp fxvector-length-offset) + (def-len flvector-length flvector-type-disp flvector-length-offset) + (def-len string-length string-type-disp string-length-offset) + (def-len bytevector-length bytevector-type-disp bytevector-length-offset) + (def-len $bignum-length bignum-type-disp bignum-length-offset) + (def-len stencil-vector-mask stencil-vector-type-disp stencil-vector-mask-offset)) + (let () + (define-syntax def-len + (syntax-rules () + [(_ prim mask type type-disp length-offset) + (define-inline 2 prim + [(e) (let ([Lerr (make-local-label 'Lerr)]) + (bind #t (e) + `(if ,(%type-check mask-typed-object type-typed-object ,e) + ,(bind #t ([t/l (%mref ,e ,(constant type-disp))]) + `(if ,(%type-check mask type ,t/l) + ,(extract-length t/l (constant length-offset)) + (goto ,Lerr))) + (label ,Lerr ,(build-libcall #t #f sexpr prim e)))))])])) + (def-len vector-length mask-vector type-vector vector-type-disp vector-length-offset) + (def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset) + (def-len flvector-length mask-flvector type-flvector flvector-type-disp flvector-length-offset) + (def-len string-length mask-string type-string string-type-disp string-length-offset) + (def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset) + (def-len stencil-vector-mask mask-stencil-vector type-stencil-vector stencil-vector-type-disp stencil-vector-mask-offset)) + ; TODO: consider adding integer-valued?, rational?, rational-valued?, + ; real?, and real-valued? + (define-inline 2 integer? + [(e) (bind #t (e) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-simple-or + (%typed-object-check mask-bignum type-bignum ,e) + (build-and + (%type-check mask-flonum type-flonum ,e) + `(call ,(make-info-call src sexpr #f #f #f) #f ,(lookup-primref 3 'flinteger?) ,e)))))]) + (let () + (define build-number? + (lambda (e) + (bind #t (e) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-simple-or + (%type-check mask-flonum type-flonum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (%type-check mask-other-number type-other-number + ,(%mref ,e ,(constant bignum-type-disp))))))))) + (define-inline 2 number? + [(e) (build-number? e)]) + (define-inline 2 complex? + [(e) (build-number? e)])) + (define-inline 3 set-car! + [(e1 e2) (build-dirty-store e1 (constant pair-car-disp) e2)]) + (define-inline 3 set-cdr! + [(e1 e2) (build-dirty-store e1 (constant pair-cdr-disp) e2)]) + (define-inline 3 set-box! + [(e1 e2) (build-dirty-store e1 (constant box-ref-disp) e2)]) + (define-inline 3 box-cas! + [(e1 e2 e3) + (bind #t (e2) + (build-dirty-store e1 %zero (constant box-ref-disp) e3 (make-build-cas e2) build-cas-seq))]) + (define-inline 3 $set-symbol-name! + [(e1 e2) (build-dirty-store e1 (constant symbol-name-disp) e2)]) + (define-inline 3 $set-symbol-property-list! + [(e1 e2) (build-dirty-store e1 (constant symbol-plist-disp) e2)]) + (define-inline 3 $set-system-property-list! + [(e1 e2) (build-dirty-store e1 (constant symbol-splist-disp) e2)]) + (define-inline 3 $set-port-info! + [(e1 e2) (build-dirty-store e1 (constant port-info-disp) e2)]) + (define-inline 3 set-port-name! + [(e1 e2) (build-dirty-store e1 (constant port-name-disp) e2)]) + (define-inline 2 set-box! + [(e-box e-new) + (bind #t (e-box) + (dirty-store-bind #t (e-new) + `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) + ,(build-dirty-store e-box (constant box-ref-disp) e-new) + ,(build-libcall #t src sexpr set-box! e-box e-new))))]) + (define-inline 2 box-cas! + [(e-box e-old e-new) + (bind #t (e-box e-old) + (dirty-store-bind #t (e-new) + `(if ,(%typed-object-check mask-mutable-box type-mutable-box ,e-box) + ,(build-dirty-store e-box %zero (constant box-ref-disp) e-new (make-build-cas e-old) build-cas-seq) + ,(build-libcall #t src sexpr box-cas! e-box e-old e-new))))]) + (define-inline 2 set-car! + [(e-pair e-new) + (bind #t (e-pair) + (dirty-store-bind #t (e-new) + `(if ,(%type-check mask-pair type-pair ,e-pair) + ,(build-dirty-store e-pair (constant pair-car-disp) e-new) + ,(build-libcall #t src sexpr set-car! e-pair e-new))))]) + (define-inline 2 set-cdr! + [(e-pair e-new) + (bind #t (e-pair) + (dirty-store-bind #t (e-new) + `(if ,(%type-check mask-pair type-pair ,e-pair) + ,(build-dirty-store e-pair (constant pair-cdr-disp) e-new) + ,(build-libcall #t src sexpr set-cdr! e-pair e-new))))]) + (define-inline 3 $set-symbol-hash! + ; no need for dirty store---e2 should be a fixnum + [(e1 e2) `(set! ,(%mref ,e1 ,(constant symbol-hash-disp)) ,e2)]) + (define-inline 2 memory-order-acquire + [() (if-feature pthreads + (constant-case architecture + [(arm32 arm64) (%seq ,(%inline acquire-fence) (quote ,(void)))] + [else `(quote ,(void))]) + `(quote ,(void)))]) + (define-inline 2 memory-order-release + [() (if-feature pthreads + (constant-case architecture + [(arm32 arm64) (%seq ,(%inline release-fence) (quote ,(void)))] + [else `(quote ,(void))]) + `(quote ,(void)))]) + (let () + (define-syntax define-tlc-parameter + (syntax-rules () + [(_ name disp) + (define-inline 3 name + [(e-x) (%mref ,e-x ,(constant disp))])] + [(_ name name! disp) + (begin + (define-tlc-parameter name disp) + (define-inline 3 name! + [(e-x e-new) (build-dirty-store e-x (constant disp) e-new)]))])) + (define-tlc-parameter $tlc-keyval tlc-keyval-disp) + (define-tlc-parameter $tlc-ht tlc-ht-disp) + (define-tlc-parameter $tlc-next $set-tlc-next! tlc-next-disp)) + (define-inline 2 $top-level-value + [(e) (nanopass-case (L7 Expr) e + [(quote ,d) + (guard (symbol? d)) + (if (any-set? (prim-mask (or primitive system)) ($sgetprop d '*flags* 0)) + (Symref d) + (bind #t (e) + (bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) + `(if ,(%type-check mask-unbound sunbound ,t) + ,(build-libcall #t #f sexpr $top-level-value e) + ,t))))] + [else + (bind #t (e) + (let ([Lfail (make-local-label 'tlv-fail)]) + `(if ,(%type-check mask-symbol type-symbol ,e) + ,(bind #t ([t (%mref ,e ,(constant symbol-value-disp))]) + `(if ,(%type-check mask-unbound sunbound ,t) + (goto ,Lfail) + ,t)) + (label ,Lfail ,(build-libcall #t #f sexpr $top-level-value e)))))])]) + (define-inline 3 $top-level-value + [(e) (nanopass-case (L7 Expr) e + [(quote ,d) (guard (symbol? d)) (Symref d)] + [else (%mref ,e ,(constant symbol-value-disp))])]) + (let () + (define (go e-sym e-value) + (bind #t (e-sym) + `(seq + ,(build-dirty-store e-sym (constant symbol-value-disp) e-value) + (set! ,(%mref ,e-sym ,(constant symbol-pvalue-disp)) + (literal + ,(make-info-literal #f 'library + (lookup-libspec nonprocedure-code) + (constant code-data-disp))))))) + (define-inline 3 $set-top-level-value! + [(e-sym e-value) (go e-sym e-value)]) + (define-inline 2 $set-top-level-value! + [(e-sym e-value) (and (constant? symbol? e-sym) (go e-sym e-value))])) + (define-inline 3 $top-level-bound? + [(e-sym) + (build-not + (%type-check mask-unbound sunbound + ,(nanopass-case (L7 Expr) e-sym + [(quote ,d) (guard (symbol? d)) (Symref d)] + [else (%mref ,e-sym ,(constant symbol-value-disp))])))]) + (let () + (define parse-format + (lambda (who src cntl-arg args) + (nanopass-case (L7 Expr) cntl-arg + [(quote ,d) + (guard (c [(and (assertion-violation? c) + (format-condition? c) + (message-condition? c) + (irritants-condition? c)) + ($source-warning 'compile + src #t + "~? in call to ~s" + (condition-message c) + (condition-irritants c) + who) + #f]) + (#%$parse-format-string who d (length args)))] + [else #f]))) + (define fmt->expr + ($make-fmt->expr + (lambda (d) `(quote ,d)) + (lambda (e1 e2) `(seq ,e1 ,e2)) + (lambda (src sexpr prim arg*) + `(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 prim) + ,arg* ...)))) + (define build-format + (lambda (who src sexpr op-arg cntl-arg arg*) + (let ([x (parse-format who src cntl-arg arg*)]) + (and x + (cond + [(and (fx= (length x) 1) + (string? (car x)) + (nanopass-case (L7 Expr) op-arg + [(quote ,d) (eq? d #f)] + [else #f])) + (%primcall src sexpr string-copy (quote ,(car x)))] + [(and (nanopass-case (L7 Expr) op-arg + [(quote ,d) (not (eq? d #f))] + [else #t]) + (let-values ([(op-arg dobind) (binder #t 'ptr op-arg)] + [(arg* dobind*) (list-binder #t 'ptr arg*)]) + (let ([e (fmt->expr src sexpr x op-arg arg*)]) + (and e (dobind (dobind* e))))))] + [else + (%primcall src sexpr $dofmt (quote ,who) ,op-arg ,cntl-arg + (quote ,x) + ,(build-list arg*))]))))) + (define-inline 2 errorf + [(e-who e-str . e*) + (parse-format 'errorf src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'errorf) ,e-who ,e-str ,e* ...))]) + (define-inline 2 assertion-violationf + [(e-who e-str . e*) + (parse-format 'assertion-violationf src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref 'assertion-violationf) ,e-who ,e-str ,e* ...))]) + (define-inline 2 $oops + [(e-who e-str . e*) + (parse-format '$oops src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$oops) ,e-who ,e-str ,e* ...))]) + (define-inline 2 $impoops + [(e-who e-str . e*) + (parse-format '$impoops src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$impoops) ,e-who ,e-str ,e* ...))]) + (define-inline 2 warningf + [(e-who e-str . e*) + (parse-format 'warningf src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref 'warningf) ,e-who ,e-str ,e* ...))]) + (define-inline 2 $source-violation + [(e-who e-src e-start? e-str . e*) + (parse-format '$source-violation src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #t) #f ,(Symref '$source-violation) + ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) + (define-inline 2 $source-warning + [(e-who e-src e-start? e-str . e*) + (parse-format '$source-warning src e-str e*) + `(seq (pariah) (call ,(make-info-call src sexpr #f #t #f) #f ,(Symref '$source-warning) + ,e-who ,e-src ,e-start? ,e-str ,e* ...))]) + (define-inline 2 fprintf + [(e-op e-str . e*) + (parse-format 'fprintf src e-str e*) + #f]) + (define-inline 3 fprintf + [(e-op e-str . e*) (build-format 'fprintf src sexpr e-op e-str e*)]) + (define-inline 2 printf + [(e-str . e*) + (build-format 'printf src sexpr (%tc-ref current-output) e-str e*)]) + (define-inline 2 format + [(e . e*) + (nanopass-case (L7 Expr) e + [(quote ,d) + (if (string? d) + (build-format 'format src sexpr `(quote #f) e e*) + (and (not (null? e*)) + (cond + [(eq? d #f) (build-format 'format src sexpr e (car e*) (cdr e*))] + [(eq? d #t) (build-format 'format src sexpr + (%tc-ref current-output) + (car e*) (cdr e*))] + [else #f])))] + [else #f])])) + (let () + (define hand-coded-closure? + (lambda (name) + (not (memq name '(nuate nonprocedure-code error-invoke invoke + $wrapper-apply wrapper-apply arity-wrapper-apply + popcount-slow cpu-features))))) + (define-inline 2 $hand-coded + [(name) + (nanopass-case (L7 Expr) name + [(quote ,d) + (guard (symbol? d)) + (let ([l (make-local-label 'hcl)]) + (set! new-l* (cons l new-l*)) + (set! new-le* (cons (with-output-language (L9 CaseLambdaExpr) `(hand-coded ,d)) new-le*)) + (if (hand-coded-closure? d) + `(literal ,(make-info-literal #f 'closure l 0)) + `(label-ref ,l 0)))] + [(seq (profile ,src) ,[e]) `(seq (profile ,src) ,e)] + [else ($oops '$hand-coded "~s is not a quoted symbol" name)])])) + (define-inline 2 $tc + [() %tc]) + (define-inline 3 $tc-field + [(e-fld e-tc) + (nanopass-case (L7 Expr) e-fld + [(quote ,d) + (let () + (define-syntax a + (lambda (x) + #`(case d + #,@(fold-left + (lambda (ls field) + (apply + (lambda (name type disp len) + (if (eq? type 'ptr) + (cons + (with-syntax ([name (datum->syntax #'* name)]) + #'[(name) (%tc-ref ,e-tc name)]) + ls) + ls)) + field)) + '() (getprop 'tc '*fields* '())) + [else #f]))) + a)] + [else #f])] + [(e-fld e-tc e-val) + (nanopass-case (L7 Expr) e-fld + [(quote ,d) + (let () + (define-syntax a + (lambda (x) + #`(case d + #,@(fold-left + (lambda (ls field) + (apply + (lambda (name type disp len) + (if (eq? type 'ptr) + (cons + (with-syntax ([name (datum->syntax #'* name)]) + #'[(name) `(set! ,(%tc-ref ,e-tc name) ,e-val)]) + ls) + ls)) + field)) + '() (getprop 'tc '*fields* '())) + [else #f]))) + a)] + [else #f])]) + (let () + (define-syntax define-tc-parameter + (syntax-rules () + [(_ name tc-name) + (begin + (define-inline 2 name + [() (%tc-ref tc-name)] + [(x) #f]) + (define-inline 3 name + [() (%tc-ref tc-name)] + [(x) `(set! ,(%tc-ref tc-name) ,x)]))])) + + (define-tc-parameter current-input-port current-input) + (define-tc-parameter current-output-port current-output) + (define-tc-parameter current-error-port current-error) + (define-tc-parameter generate-inspector-information generate-inspector-information) + (define-tc-parameter generate-procedure-source-information generate-procedure-source-information) + (define-tc-parameter generate-profile-forms generate-profile-forms) + (define-tc-parameter $compile-profile compile-profile) + (define-tc-parameter optimize-level optimize-level) + (define-tc-parameter subset-mode subset-mode) + (define-tc-parameter $suppress-primitive-inlining suppress-primitive-inlining) + (define-tc-parameter $block-counter block-counter) + (define-tc-parameter $sfd sfd) + (define-tc-parameter $current-mso current-mso) + (define-tc-parameter $target-machine target-machine) + (define-tc-parameter $current-stack-link stack-link) + (define-tc-parameter $current-winders winders) + (define-tc-parameter $current-attachments attachments) + (define-tc-parameter default-record-equal-procedure default-record-equal-procedure) + (define-tc-parameter default-record-hash-procedure default-record-hash-procedure) + ) + + (let () + (define (make-wrapper-closure-alloc e-proc e-arity-mask e-data libspec) + (bind #t ([c (%constant-alloc type-closure (fx* (if e-data 4 3) (constant ptr-bytes)))]) + (%seq + (set! ,(%mref ,c ,(constant closure-code-disp)) + (literal ,(make-info-literal #f 'library libspec (constant code-data-disp)))) + (set! ,(%mref ,c ,(constant closure-data-disp)) ,e-proc) + (set! ,(%mref ,c ,(fx+ (constant ptr-bytes) (constant closure-data-disp))) ,e-arity-mask) + ,(if e-data + (%seq + (set! ,(%mref ,c ,(fx+ (fx* (constant ptr-bytes) 2) (constant closure-data-disp))) ,e-data) + ,c) + c)))) + (define-inline 3 $make-wrapper-procedure + [(e-proc e-arity-mask) + (bind #f (e-proc e-arity-mask) + (make-wrapper-closure-alloc e-proc e-arity-mask #f (lookup-libspec $wrapper-apply)))]) + (define-inline 3 make-wrapper-procedure + [(e-proc e-arity-mask e-data) + (bind #f (e-proc e-arity-mask e-data) + (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec wrapper-apply)))]) + (define-inline 3 make-arity-wrapper-procedure + [(e-proc e-arity-mask e-data) + (bind #f (e-proc e-arity-mask e-data) + (make-wrapper-closure-alloc e-proc e-arity-mask e-data (lookup-libspec arity-wrapper-apply)))])) + + (define-inline 3 $install-guardian + [(e-obj e-rep e-tconc ordered?) + (bind #f (e-obj e-rep e-tconc ordered?) + (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) + (%seq + (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) + (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) ,e-rep) + (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) + (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) + (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,ordered?) + (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) + (set! ,(%tc-ref guardian-entries) ,t))))]) + + (define-inline 3 $install-ftype-guardian + [(e-obj e-tconc) + (bind #f (e-obj e-tconc) + (bind #t ([t (%constant-alloc typemod (constant size-guardian-entry))]) + (%seq + (set! ,(%mref ,t ,(constant guardian-entry-obj-disp)) ,e-obj) + (set! ,(%mref ,t ,(constant guardian-entry-rep-disp)) (immediate ,(constant ftype-guardian-rep))) + (set! ,(%mref ,t ,(constant guardian-entry-tconc-disp)) ,e-tconc) + (set! ,(%mref ,t ,(constant guardian-entry-next-disp)) ,(%tc-ref guardian-entries)) + (set! ,(%mref ,t ,(constant guardian-entry-ordered?-disp)) ,(%constant sfalse)) + (set! ,(%mref ,t ,(constant guardian-entry-pending-disp)) ,(%constant snil)) + (set! ,(%tc-ref guardian-entries) ,t))))]) + + (define-inline 2 guardian? + [(e) + (bind #t (e) + (build-and + (%type-check mask-closure type-closure ,e) + (%type-check mask-guardian-code type-guardian-code + ,(%mref + ,(%inline - + ,(%mref ,e ,(constant closure-code-disp)) + ,(%constant code-data-disp)) + ,(constant code-type-disp)))))]) + + (define-inline 3 $make-phantom-bytevector + [() + (bind #f () + (bind #t ([t (%constant-alloc type-typed-object (constant size-phantom))]) + (%seq + (set! ,(%mref ,t ,(constant phantom-type-disp)) + ,(%constant type-phantom)) + (set! ,(%mref ,t ,(constant phantom-length-disp)) + (immediate 0)) + ,t)))]) + + (define-inline 3 phantom-bytevector-length + [(e-ph) + (bind #f (e-ph) + (unsigned->ptr (%mref ,e-ph ,(constant phantom-length-disp)) + (constant ptr-bits)))]) + + (define-inline 2 virtual-register-count + [() `(quote ,(constant virtual-register-count))]) + (let () + (define constant-ref + (lambda (e-idx) + (nanopass-case (L7 Expr) e-idx + [(quote ,d) + (guard (and (fixnum? d) ($fxu< d (constant virtual-register-count)))) + (%mref ,%tc ,(fx+ (constant tc-virtual-registers-disp) (fx* d (constant ptr-bytes))))] + [else #f]))) + (define constant-set + (lambda (e-idx e-val) + (let ([ref (constant-ref e-idx)]) + (and ref `(set! ,ref ,e-val))))) + (define index-check + (lambda (e-idx libcall e) + `(if (if ,(%type-check mask-fixnum type-fixnum ,e-idx) + ,(%inline u< ,e-idx (immediate ,(fix (constant virtual-register-count)))) + ,(%constant sfalse)) + ,e + ,libcall))) + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (define-inline 3 virtual-register + [(e-idx) + (or (constant-ref e-idx) + (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))]) + (define-inline 2 virtual-register + [(e-idx) + (or (constant-ref e-idx) + (bind #t (e-idx) + (index-check e-idx + (build-libcall #t src sexpr virtual-register e-idx) + (%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)))))]) + (define-inline 3 set-virtual-register! + [(e-idx e-val) + (or (constant-set e-idx e-val) + `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val))]) + (define-inline 2 set-virtual-register! + [(e-idx e-val) + (or (constant-set e-idx e-val) + (bind #t (e-idx) + (bind #f (e-val) + (index-check e-idx + (build-libcall #t src sexpr set-virtual-register! e-idx) + `(set! ,(%mref ,%tc ,e-idx ,(constant tc-virtual-registers-disp)) ,e-val)))))])) + + (define-inline 2 $thread-list + [() `(literal ,(make-info-literal #t 'entry (lookup-c-entry thread-list) 0))]) + (when-feature pthreads + (define-inline 2 $raw-tc-mutex + [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-tc-mutex) 0))]) + (define-inline 2 $raw-terminated-cond + [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-terminated-cond) 0))]) + (define-inline 2 $raw-collect-cond + [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-cond) 0))]) + (define-inline 2 $raw-collect-thread0-cond + [() `(literal ,(make-info-literal #f 'entry (lookup-c-entry raw-collect-thread0-cond) 0))])) + (define-inline 2 not + [(e) `(if ,e ,(%constant sfalse) ,(%constant strue))]) + (define-inline 2 most-negative-fixnum + [() `(quote ,(constant most-negative-fixnum))]) + (define-inline 2 most-positive-fixnum + [() `(quote ,(constant most-positive-fixnum))]) + (define-inline 2 least-fixnum + [() `(quote ,(constant most-negative-fixnum))]) + (define-inline 2 greatest-fixnum + [() `(quote ,(constant most-positive-fixnum))]) + (define-inline 2 fixnum-width + [() `(quote ,(constant fixnum-bits))]) + (constant-case native-endianness + [(unknown) (void)] + [else + (define-inline 2 native-endianness + [() `(quote ,(constant native-endianness))])]) + (define-inline 2 directory-separator + [() `(quote ,(if-feature windows #\\ #\/))]) + (let () ; level 2 char=?, r6rs:char=?, etc. + (define-syntax char-pred + (syntax-rules () + [(_ op r6rs:op inline-op) + (let () + (define (go2 src sexpr e1 e2) + (bind #t (e1 e2) + `(if ,(build-chars? e1 e2) + ,(%inline inline-op ,e1 ,e2) + ,(build-libcall #t src sexpr op e1 e2)))) + (define (go3 src sexpr e1 e2 e3) + (and (constant? char? e1) + (constant? char? e3) + (bind #t (e2) + `(if ,(%type-check mask-char type-char ,e2) + ,(build-and + (%inline inline-op ,e1 ,e2) + (%inline inline-op ,e2 ,e3)) + ; could also pass e2 and e3: + ,(build-libcall #t src sexpr op e1 e2))))) + (define-inline 2 op + [(e1 e2) (go2 src sexpr e1 e2)] + [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] + [(e1 . e*) #f]) + (define-inline 2 r6rs:op + [(e1 e2) (go2 src sexpr e1 e2)] + [(e1 e2 e3) (go3 src sexpr e1 e2 e3)] + [(e1 e2 . e*) #f]))])) + (char-pred char=? r6rs:char>=? >=) + (char-pred char>? r6rs:char>? >)) + (let () ; level 3 char=?, r6rs:char=?, etc. + (define-syntax char-pred + (syntax-rules () + [(_ op r6rs:op inline-op) + (let () + (define (go2 e1 e2) + (%inline inline-op ,e1 ,e2)) + (define (go3 e1 e2 e3) + (bind #t (e2) + (bind #f (e3) + (build-and + (go2 e1 e2) + (go2 e2 e3))))) + (define-inline 3 op + [(e) `(seq ,e ,(%constant strue))] + [(e1 e2) (go2 e1 e2)] + [(e1 e2 e3) (go3 e1 e2 e3)] + [(e1 . e*) #f]) + (define-inline 3 r6rs:op + [(e1 e2) (go2 e1 e2)] + [(e1 e2 e3) (go3 e1 e2 e3)] + [(e1 e2 . e*) #f]))])) + (char-pred char=? r6rs:char>=? >=) + (char-pred char>? r6rs:char>? >)) + (define-inline 3 map + [(e-proc e-ls) + (or (nanopass-case (L7 Expr) e-proc + [,pr + (and (all-set? (prim-mask unsafe) (primref-flags pr)) + (let ([name (primref-name pr)]) + (or (and (eq? name 'car) (build-libcall #f src sexpr map-car e-ls)) + (and (eq? name 'cdr) (build-libcall #f src sexpr map-cdr e-ls)))))] + [else #f]) + (build-libcall #f src sexpr map1 e-proc e-ls))] + [(e-proc e-ls1 e-ls2) + (or (nanopass-case (L7 Expr) e-proc + [,pr + (and (eq? (primref-name pr) 'cons) + (build-libcall #f src sexpr map-cons e-ls1 e-ls2))] + [else #f]) + (build-libcall #f src sexpr map2 e-proc e-ls1 e-ls2))] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 andmap + [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 for-all + [(e-proc e-ls) (build-libcall #f src sexpr andmap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 ormap + [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 exists + [(e-proc e-ls) (build-libcall #f src sexpr ormap1 e-proc e-ls)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 fold-left + [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-left1 e-proc e-base e-ls)] + [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-left2 e-proc e-base e-ls1 e-ls2)] + [(e-proc e-base e-ls . e-ls*) #f]) + (define-inline 3 fold-right + [(e-proc e-base e-ls) (build-libcall #f src sexpr fold-right1 e-proc e-base e-ls)] + [(e-proc e-base e-ls1 e-ls2) (build-libcall #f src sexpr fold-right2 e-proc e-base e-ls1 e-ls2)] + [(e-proc e-base e-ls . e-ls*) #f]) + (define-inline 3 for-each + [(e-proc e-ls) (build-libcall #f src sexpr for-each1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr for-each2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 vector-map + [(e-proc e-ls) (build-libcall #f src sexpr vector-map1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-map2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 vector-for-each + [(e-proc e-ls) (build-libcall #f src sexpr vector-for-each1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr vector-for-each2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 string-for-each + [(e-proc e-ls) (build-libcall #f src sexpr string-for-each1 e-proc e-ls)] + [(e-proc e-ls1 e-ls2) (build-libcall #f src sexpr string-for-each2 e-proc e-ls1 e-ls2)] + [(e-proc e-ls . e-ls*) #f]) + (define-inline 3 reverse + [(e) (build-libcall #f src sexpr reverse e)]) + (let () + (define inline-getprop + (lambda (plist-offset e-sym e-key e-dflt) + (let ([t-ls (make-assigned-tmp 't-ls)] [t-cdr (make-tmp 't-cdr)] [Ltop (make-local-label 'Ltop)]) + (bind #t (e-key e-dflt) + ; indirect symbol after evaluating e-key and e-dflt + `(let ([,t-ls ,(%mref ,e-sym ,plist-offset)]) + (label ,Ltop + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,e-dflt + (let ([,t-cdr ,(%mref ,t-ls ,(constant pair-cdr-disp))]) + (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) + ,(%mref ,t-cdr ,(constant pair-car-disp)) + (seq + (set! ,t-ls ,(%mref ,t-cdr ,(constant pair-cdr-disp))) + (goto ,Ltop))))))))))) + (define-inline 3 getprop + [(e-sym e-key) (inline-getprop (constant symbol-plist-disp) e-sym e-key (%constant sfalse))] + [(e-sym e-key e-dflt) (inline-getprop (constant symbol-plist-disp) e-sym e-key e-dflt)]) + (define-inline 3 $sgetprop + [(e-sym e-key e-dflt) (inline-getprop (constant symbol-splist-disp) e-sym e-key e-dflt)])) + (define-inline 3 assq + [(e-key e-ls) + (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) + (bind #t (e-key) + `(let ([,t-ls ,e-ls]) + (label ,Ltop + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,(%constant sfalse) + ,(bind #t ([t-a (%mref ,t-ls ,(constant pair-car-disp))]) + `(if ,(%inline eq? ,(%mref ,t-a ,(constant pair-car-disp)) ,e-key) + ,t-a + (seq + (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) + (goto ,Ltop)))))))))]) + (define-inline 3 length + [(e-ls) + (let ([t-ls (make-assigned-tmp 't-ls)] + [t-n (make-assigned-tmp 't-n)] + [Ltop (make-local-label 'Ltop)]) + (bind #t (e-ls) + `(if ,(%inline eq? ,e-ls ,(%constant snil)) + (immediate ,(fix 0)) + (let ([,t-ls ,e-ls] [,t-n (immediate ,(fix 0))]) + (label ,Ltop + ,(%seq + (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) + (set! ,t-n ,(%inline + ,t-n (immediate ,(fix 1)))) + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,t-n + (goto ,Ltop))))))))]) + (define-inline 3 append + ; TODO: hand-coded library routine that allocates the new pairs in a block + [() (%constant snil)] + [(e-ls) e-ls] + [(e-ls1 e-ls2) (build-libcall #f src sexpr append e-ls1 e-ls2)] + [(e-ls1 e-ls2 e-ls3) + (build-libcall #f src sexpr append e-ls1 + (build-libcall #f #f sexpr append e-ls2 e-ls3))] + [(e-ls . e-ls*) #f]) + (define-inline 3 apply + [(e0 e1) (build-libcall #f src sexpr apply0 e0 e1)] + [(e0 e1 e2) (build-libcall #f src sexpr apply1 e0 e1 e2)] + [(e0 e1 e2 e3) (build-libcall #f src sexpr apply2 e0 e1 e2 e3)] + [(e0 e1 e2 e3 e4) (build-libcall #f src sexpr apply3 e0 e1 e2 e3 e4)] + [(e0 e1 . e*) #f]) + (define-inline 2 fxsll + [(e0 e1) (build-libcall #f src sexpr fxsll e0 e1)]) + (define-inline 2 fxarithmetic-shift-left + [(e0 e1) (build-libcall #f src sexpr fxarithmetic-shift-left e0 e1)]) + (define-inline 2 fxsll/wraparound + [(e1 e2) + (bind #t (e1 e2) + `(if ,(nanopass-case (L7 Expr) e2 + [(quote ,d) + (guard (target-fixnum? d) + ($fxu< d (fx+ 1 (constant fixnum-bits)))) + (build-fixnums? (list e1 e2))] + [else + (build-and (build-fixnums? (list e1 e2)) + (%inline u< ,e2 (immediate ,(fix (fx+ 1 (constant fixnum-bits))))))]) + ,(%inline sll ,e1 ,(build-unfix e2)) + ,(build-libcall #t src sexpr fxsll/wraparound e1 e2)))]) + (define-inline 3 display-string + [(e-s) (build-libcall #f src sexpr display-string e-s (%tc-ref current-output))] + [(e-s e-op) (build-libcall #f src sexpr display-string e-s e-op)]) + (define-inline 3 call-with-current-continuation + [(e) (build-libcall #f src sexpr callcc e)]) + (define-inline 3 call/cc + [(e) (build-libcall #f src sexpr callcc e)]) + (define-inline 3 call/1cc + [(e) (build-libcall #f src sexpr call1cc e)]) + (define-inline 2 $event + [() (build-libcall #f src sexpr event)]) + (define-inline 3 eq-hashtable-ref + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-ref e1 e2 e3)]) + (define-inline 3 eq-hashtable-ref-cell + [(e1 e2) (build-libcall #f src sexpr eq-hashtable-ref-cell e1 e2)]) + (define-inline 3 eq-hashtable-contains? + [(e1 e2) (build-libcall #f src sexpr eq-hashtable-contains? e1 e2)]) + (define-inline 3 eq-hashtable-set! + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-set! e1 e2 e3)]) + (define-inline 3 eq-hashtable-update! + [(e1 e2 e3 e4) (build-libcall #f src sexpr eq-hashtable-update! e1 e2 e3 e4)]) + (define-inline 3 eq-hashtable-cell + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-cell e1 e2 e3)]) + (define-inline 3 eq-hashtable-try-atomic-cell + [(e1 e2 e3) (build-libcall #f src sexpr eq-hashtable-try-atomic-cell e1 e2 e3)]) + (define-inline 3 eq-hashtable-delete! + [(e1 e2) (build-libcall #f src sexpr eq-hashtable-delete! e1 e2)]) + (define-inline 3 symbol-hashtable-ref + [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-ref e1 e2 e3)]) + (define-inline 3 symbol-hashtable-ref-cell + [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-ref-cell e1 e2)]) + (define-inline 3 symbol-hashtable-contains? + [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-contains? e1 e2)]) + (define-inline 3 symbol-hashtable-set! + [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-set! e1 e2 e3)]) + (define-inline 3 symbol-hashtable-update! + [(e1 e2 e3 e4) (build-libcall #f src sexpr symbol-hashtable-update! e1 e2 e3 e4)]) + (define-inline 3 symbol-hashtable-cell + [(e1 e2 e3) (build-libcall #f src sexpr symbol-hashtable-cell e1 e2 e3)]) + (define-inline 3 symbol-hashtable-delete! + [(e1 e2) (build-libcall #f src sexpr symbol-hashtable-delete! e1 e2)]) + (define-inline 2 bytevector-s8-set! + [(e1 e2 e3) (build-libcall #f src sexpr bytevector-s8-set! e1 e2 e3)]) + (define-inline 2 bytevector-u8-set! + [(e1 e2 e3) (build-libcall #f src sexpr bytevector-u8-set! e1 e2 e3)]) + (define-inline 3 bytevector=? + [(e1 e2) (build-libcall #f src sexpr bytevector=? e1 e2)]) + (let () + (define eqvop-flonum + (lambda (e1 e2) + (nanopass-case (L7 Expr) e1 + [(quote ,d) (and (flonum? d) + (bind #t (e2) + (build-and + (%type-check mask-flonum type-flonum ,e2) + (if ($nan? d) + ;; NaN: invert `fl=` on self + (bind #t (e2) + (build-not (build-fl= e2 e2))) + ;; Non-NaN: compare bits + (constant-case ptr-bits + [(32) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (let ([d0 (if (eq? (constant native-endianness) (native-endianness)) 0 4)]) + (let ([word1 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) d0))] + [word2 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) (fx- 4 d0)))]) + (build-and + (%inline eq? + ,(%mref ,e2 ,(constant flonum-data-disp)) + (immediate ,word1)) + (%inline eq? + ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4)) + (immediate ,word2)))))] + [(64) + (let ([word ($object-ref 'integer-64 d (constant flonum-data-disp))]) + (%inline eq? + ,(%mref ,e2 ,(constant flonum-data-disp)) + (immediate ,word)))] + [else ($oops 'compiler-internal + "eqv doesn't handle ptr-bits = ~s" + (constant ptr-bits))])))))] + [else #f]))) + (define eqok-help? + (lambda (obj) + (or (symbol? obj) + (char? obj) + (target-fixnum? obj) + (null? obj) + (boolean? obj) + (eqv? obj "") + (eqv? obj '#()) + (eqv? obj '#vu8()) + (eqv? obj '#0=#0#) + (eq? obj (void)) + (eof-object? obj) + (bwp-object? obj) + ($unbound-object? obj) + (eqv? obj '#vfx())))) + (define eqvok-help? number?) + (define eqvnever-help? (lambda (obj) (not (number? obj)))) + (define e*ok? + (lambda (e*ok-help?) + (lambda (e) + (nanopass-case (L7 Expr) e + [(quote ,d) (e*ok-help? d)] + [else #f])))) + (define eqok? (e*ok? eqok-help?)) + (define eqvok? (e*ok? eqvok-help?)) + (define eqvnever? (e*ok? eqvnever-help?)) + (define-inline 2 eqv? + [(e1 e2) (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) + (eqvop-flonum e1 e2) + (eqvop-flonum e2 e1) + (if (or (eqok? e1) (eqok? e2) + (eqvnever? e1) (eqvnever? e2)) + (build-eq? e1 e2) + (build-eqv? src sexpr e1 e2)))]) + (let () + (define xform-equal? + (lambda (src sexpr e1 e2) + (nanopass-case (L7 Expr) e1 + [(quote ,d1) + (let xform ([d1 d1] [e2 e2] [n 3] [k (lambda (e n) e)]) + (if (eqok-help? d1) + (k (build-eq? `(quote ,d1) e2) n) + (if (eqvok-help? d1) + (k (build-eqv? src sexpr `(quote ,d1) e2) n) + (and (fx> n 0) + (pair? d1) + (let-values ([(e2 dobind) (binder #t 'ptr e2)]) + (xform (car d1) (build-car e2) (fx- n 1) + (lambda (a n) + (xform (cdr d1) (build-cdr e2) n + (lambda (d n) + (k (dobind + (build-and + (build-pair? e2) + (build-and a d))) + n))))))))))] + [else #f]))) + (define-inline 2 equal? + [(e1 e2) (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) + (xform-equal? src sexpr e1 e2) + (xform-equal? src sexpr e2 e1))])) + (let () + (define mem*ok? + (lambda (e*ok-help?) + (lambda (x) + (nanopass-case (L7 Expr) x + [(quote ,d) + (and (list? d) + (let f ([d d]) + (or (null? d) + (and (e*ok-help? (car d)) + (f (cdr d))))))] + [else #f])))) + (define memqok? (mem*ok? eqok-help?)) + (define memvok? (mem*ok? eqvok-help?)) + (define mem*->e*?s + (lambda (build-e*? limit) + (lambda (e-key e-ls) + (nanopass-case (L7 Expr) e-ls + [(quote ,d) + (and (let f ([d d] [n 0]) + (or (null? d) + (and (pair? d) + (fx< n limit) + (f (cdr d) (fx1+ n))))) + (bind #t (e-key) + (let f ([ls d]) + (if (null? ls) + `(quote #f) + `(if ,(build-e*? e-key `(quote ,(car ls))) + (quote ,ls) + ,(f (cdr ls)))))))] + [else #f])))) + (define memq->eq?s (mem*->e*?s build-eq? 8)) + (define (memv->eqv?s src sexpr) (mem*->e*?s (make-build-eqv? src sexpr) 4)) + (define do-memq + (lambda (src sexpr e-key e-ls) + (or (memq->eq?s e-key e-ls) + (let ([t-ls (make-assigned-tmp 't-ls)] [Ltop (make-local-label 'Ltop)]) + (bind #t (e-key) + `(let ([,t-ls ,e-ls]) + (label ,Ltop + (if ,(%inline eq? ,t-ls ,(%constant snil)) + ,(%constant sfalse) + (if ,(%inline eq? ,(%mref ,t-ls ,(constant pair-car-disp)) ,e-key) + ,t-ls + (seq + (set! ,t-ls ,(%mref ,t-ls ,(constant pair-cdr-disp))) + (goto ,Ltop))))))))))) + (define do-memv + (lambda (src sexpr e-key e-ls) + (or ((memv->eqv?s src sexpr) e-key e-ls) + (build-libcall #f src sexpr memv e-key e-ls)))) + (define-inline 3 memq + [(e-key e-ls) (do-memq src sexpr e-key e-ls)]) + (define-inline 3 memv + [(e-key e-ls) + (if (or (eqok? e-key) (memqok? e-ls)) + (do-memq src sexpr e-key e-ls) + (do-memv src sexpr e-key e-ls))]) + (define-inline 3 member + [(e-key e-ls) + (if (or (eqok? e-key) (memqok? e-ls)) + (do-memq src sexpr e-key e-ls) + (and (or (eqvok? e-key) (memvok? e-ls)) + (do-memv src sexpr e-key e-ls)))]) + (define-inline 2 memq + [(e-key e-ls) (memq->eq?s e-key e-ls)]) + (define-inline 2 memv + [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) + ((memv->eqv?s src sexpr) e-key e-ls))]) + (define-inline 2 member + [(e-key e-ls) (or (and (memqok? e-ls) (memq->eq?s e-key e-ls)) + (and (memvok? e-ls) ((memv->eqv?s src sexpr) e-key e-ls)))]))) + ; NB: for all of the I/O routines, consider putting optimize-level 2 code out-of-line + ; w/o going all the way to the port handler, i.e., always defer to library routine but + ; have library routine do the checks and run the optimize-level 3 version...this could + ; save a lot of code + ; NB: verify that the inline checks don't always fail, i.e., don't always send us to the + ; library routine + (let () + (define (go src sexpr e-p check? update? do-libcall) + (let ([Llib (and check? (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if Llib + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-binary-input-port type-binary-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-update + (lambda (t0 e-icount body) + (if update? + `(seq + (set! ,e-icount ,(%inline + ,t0 (immediate 1))) + ,body) + body))) + (bind #t (e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-p)) + ,(maybe-add-update t0 e-icount + ; TODO: this doesn't completely fall away when used in effect context + (build-fix + `(inline ,(make-info-load 'unsigned-8 #f) ,%load + ,t0 + ,(%mref ,e-p ,(constant port-ilast-disp)) + (immediate 0))))))))))) + (define (unsafe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-u8 e-p)) + (define (safe-lookahead-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-u8 e-p)) + (define (unsafe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-u8 e-p)) + (define (safe-get-u8-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-u8 e-p)) + (define-inline 3 lookahead-u8 + [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-u8-libcall)]) + (define-inline 2 lookahead-u8 + [(e-p) (go src sexpr e-p #t #f safe-lookahead-u8-libcall)]) + (define-inline 3 get-u8 + [(e-p) (go src sexpr e-p #f #t unsafe-get-u8-libcall)]) + (define-inline 2 get-u8 + [(e-p) (go src sexpr e-p #t #t safe-get-u8-libcall)])) + (let () + (define (go src sexpr e-p check? update? do-libcall) + (let ([Llib (and check? (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if Llib + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-textual-input-port type-textual-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-update + (lambda (t0 e-icount body) + (if update? + `(seq + (set! ,e-icount ,(%inline + ,t0 ,(%constant string-char-bytes))) + ,body) + body))) + (bind #t (e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-p)) + ,(maybe-add-update t0 e-icount + ; TODO: this doesn't completely fall away when used in effect context + `(inline ,(make-info-load (string-char-type) #f) ,%load + ,t0 + ,(%mref ,e-p ,(constant port-ilast-disp)) + (immediate 0)))))))))) + (define (unsafe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-lookahead-char e-p)) + (define (safe-lookahead-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-lookahead-char e-p)) + (define (unsafe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-peek-char e-p)) + (define (safe-peek-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-peek-char e-p)) + (define (unsafe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-get-char e-p)) + (define (safe-get-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-get-char e-p)) + (define (unsafe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr unsafe-read-char e-p)) + (define (safe-read-char-libcall src sexpr e-p) (build-libcall #t src sexpr safe-read-char e-p)) + (define-inline 3 lookahead-char + [(e-p) (go src sexpr e-p #f #f unsafe-lookahead-char-libcall)]) + (define-inline 2 lookahead-char + [(e-p) (go src sexpr e-p #t #f safe-lookahead-char-libcall)]) + (define-inline 3 peek-char + [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] + [(e-p) (go src sexpr e-p #f #f unsafe-peek-char-libcall)]) + (define-inline 2 peek-char + [() (go src sexpr (%tc-ref current-input) #f #f unsafe-peek-char-libcall)] + [(e-p) (go src sexpr e-p #t #f safe-peek-char-libcall)]) + (define-inline 3 get-char + [(e-p) (go src sexpr e-p #f #t unsafe-get-char-libcall)]) + (define-inline 2 get-char + [(e-p) (go src sexpr e-p #t #t safe-get-char-libcall)]) + (define-inline 3 read-char + [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] + [(e-p) (go src sexpr e-p #f #t unsafe-read-char-libcall)]) + (define-inline 2 read-char + [() (go src sexpr (%tc-ref current-input) #f #t unsafe-read-char-libcall)] + [(e-p) (go src sexpr e-p #t #t safe-read-char-libcall)])) + (let () + (define (go src sexpr e-p e-c check-port? check-char? do-libcall) + (let ([const-char? (constant? char? e-c)]) + (let ([Llib (and (or check-char? check-port? (not const-char?)) (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-textual-input-port type-textual-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-eof-check + (lambda (e-c body) + (if const-char? + body + `(if ,(%inline eq? ,e-c ,(%constant seof)) + (goto ,Llib) + ,body)))) + (define maybe-add-char-check + (lambda (e-c body) + (if check-char? + `(if ,(%type-check mask-char type-char ,e-c) + ,body + (goto ,Llib)) + body))) + (bind #t (e-c e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (maybe-add-eof-check e-c + (maybe-add-char-check e-c + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 + ,(%inline - + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + ,(%constant string-data-disp)) + ,(%mref ,e-p ,(constant port-ilast-disp)))) + ,(maybe-add-label Llib (do-libcall src sexpr e-p e-c)) + (set! ,e-icount ,(%inline - ,t0 ,(%constant string-char-bytes))))))))))))) + (define (unsafe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unget-char e-p e-c)) + (define (safe-unget-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unget-char e-p e-c)) + (define (unsafe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr unsafe-unread-char e-c e-p)) + (define (safe-unread-char-libcall src sexpr e-p e-c) (build-libcall #t src sexpr safe-unread-char e-c e-p)) + (define-inline 3 unget-char + [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-unget-char-libcall)]) + (define-inline 2 unget-char + [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unget-char-libcall)]) + (define-inline 3 unread-char + [(e-c) (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall)] + [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-unread-char-libcall)]) + (define-inline 2 unread-char + [(e-c) (if (constant? char? e-c) + (go src sexpr (%tc-ref current-input) e-c #f #f unsafe-unread-char-libcall) + (go src sexpr (%tc-ref current-input) e-c #f #t safe-unread-char-libcall))] + [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-unread-char-libcall)])) + (let () + (define octet? + (lambda (x) + (and (fixnum? x) (fx<= 0 x 255)))) + (define maybe-add-octet-check + (lambda (check-octet? Llib e-o body) + (if check-octet? + `(if ,(%type-check mask-octet type-octet ,e-o) + ,body + (goto ,Llib)) + body))) + (let () + (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) + (let ([const-octet? (constant? octet? e-o)]) + (let ([Llib (and (or check-octet? check-port? (not const-octet?)) (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-binary-input-port type-binary-input-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define maybe-add-eof-check + (lambda (e-o body) + (if const-octet? + body + `(if ,(%inline eq? ,e-o ,(%constant seof)) + (goto ,Llib) + ,body)))) + (bind #t (e-o e-p) + (let ([e-icount (%mref ,e-p ,(constant port-icount-disp))]) + (maybe-add-port-check e-p + (maybe-add-eof-check e-o + (maybe-add-octet-check check-octet? Llib e-o + (bind #t ([t0 e-icount]) + `(if ,(%inline eq? ,t0 + ,(%inline - + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + ,(%constant bytevector-data-disp)) + ,(%mref ,e-p ,(constant port-ilast-disp)))) + ,(maybe-add-label Llib (do-libcall src sexpr e-p e-o)) + (set! ,e-icount ,(%inline - ,t0 (immediate 1))))))))))))) + (define (unsafe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr unsafe-unget-u8 e-p e-o)) + (define (safe-unget-u8-libcall src sexpr e-p e-o) (build-libcall #t src sexpr safe-unget-u8 e-p e-o)) + (define-inline 3 unget-u8 + [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-unget-u8-libcall)]) + (define-inline 2 unget-u8 + [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-unget-u8-libcall)])) + (let () + (define (go src sexpr e-p e-o check-port? check-octet? do-libcall) + (let ([Llib (and (or check-octet? check-port?) (make-local-label 'Llib))]) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-binary-output-port type-binary-output-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define add-update + (lambda (t0 e-ocount body) + `(seq + (set! ,e-ocount ,(%inline + ,t0 (immediate 1))) + ,body))) + (bind check-octet? (e-o) + (bind #t (e-p) + (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) + (maybe-add-octet-check check-octet? Llib e-o + (maybe-add-port-check e-p + (bind #t ([t0 e-ocount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-o e-p)) + ,(add-update t0 e-ocount + `(inline ,(make-info-load 'unsigned-8 #f) ,%store + ,t0 + ,(%mref ,e-p ,(constant port-olast-disp)) + (immediate 0) + ,(build-unfix e-o)))))))))))) + (define (unsafe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr unsafe-put-u8 e-p e-o)) + (define (safe-put-u8-libcall src sexpr e-o e-p) (build-libcall #t src sexpr safe-put-u8 e-p e-o)) + (define-inline 3 put-u8 + [(e-p e-o) (go src sexpr e-p e-o #f #f unsafe-put-u8-libcall)]) + (define-inline 2 put-u8 + [(e-p e-o) (go src sexpr e-p e-o #t (not (constant? octet? e-o)) safe-put-u8-libcall)]))) + (let () + (define (go src sexpr e-p e-c check-port? check-char? do-libcall) + (let ([Llib (and (or check-char? check-port?) (make-local-label 'Llib))]) + (define maybe-add-char-check + (lambda (e-c body) + (if check-char? + `(if ,(%type-check mask-char type-char ,e-c) + ,body + (goto ,Llib)) + body))) + (define maybe-add-port-check + (lambda (e-p body) + (if check-port? + `(if (if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(%type-check mask-textual-output-port type-textual-output-port + ,(%mref ,e-p ,(constant typed-object-type-disp))) + ,(%constant sfalse)) + ,body + (goto ,Llib)) + body))) + (define add-update + (lambda (t0 e-ocount body) + `(seq + (set! ,e-ocount ,(%inline + ,t0 ,(%constant string-char-bytes))) + ,body))) + (bind check-char? (e-c) + (bind #t (e-p) + (let ([e-ocount (%mref ,e-p ,(constant port-ocount-disp))]) + (maybe-add-char-check e-c + (maybe-add-port-check e-p + (bind #t ([t0 e-ocount]) + `(if ,(%inline eq? ,t0 (immediate 0)) + ,(maybe-add-label Llib (do-libcall src sexpr e-c e-p)) + ,(add-update t0 e-ocount + `(inline ,(make-info-load (string-char-type) #f) ,%store + ,t0 + ,(%mref ,e-p ,(constant port-olast-disp)) + (immediate 0) + ,e-c))))))))))) + (define (unsafe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-put-char e-p e-c)) + (define (safe-put-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-put-char e-p e-c)) + (define (unsafe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-write-char e-c e-p)) + (define (safe-write-char-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-write-char e-c e-p)) + (define (unsafe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr unsafe-newline e-p)) + (define (safe-newline-libcall src sexpr e-c e-p) (build-libcall #t src sexpr safe-newline e-p)) + (define-inline 3 put-char + [(e-p e-c) (go src sexpr e-p e-c #f #f unsafe-put-char-libcall)]) + (define-inline 2 put-char + [(e-p e-c) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-put-char-libcall)]) + (define-inline 3 write-char + [(e-c) (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall)] + [(e-c e-p) (go src sexpr e-p e-c #f #f unsafe-write-char-libcall)]) + (define-inline 2 write-char + [(e-c) (if (constant? char? e-c) + (go src sexpr (%tc-ref current-output) e-c #f #f unsafe-write-char-libcall) + (go src sexpr (%tc-ref current-output) e-c #f #t safe-write-char-libcall))] + [(e-c e-p) (go src sexpr e-p e-c #t (not (constant? char? e-c)) safe-write-char-libcall)]) + (define-inline 3 newline + [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] + [(e-p) (go src sexpr e-p `(quote #\newline) #f #f unsafe-newline-libcall)]) + (define-inline 2 newline + [() (go src sexpr (%tc-ref current-output) `(quote #\newline) #f #f unsafe-newline-libcall)] + [(e-p) (go src sexpr e-p `(quote #\newline) #t #f safe-newline-libcall)])) + (let () + (define build-fxop? + (lambda (op overflow-flag e1 e2 adjust k) + (let ([Lfail (make-local-label 'Lfail)]) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(bind #f ([t `(inline ,null-info ,op ,e1 ,(adjust e2))]) + `(if (inline ,(make-info-condition-code overflow-flag #f #t) ,%condition-code) + (label ,Lfail ,(k e1 e2)) + ,t)) + (goto ,Lfail)))))) + (define-inline 2 + + [() `(immediate ,(fix 0))] + [(e) (build-fxop? %+/ovfl 'overflow e `(quote 0) values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] + [(e1 e2) (build-fxop? %+/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr + e1 e2)))] + ; TODO: handle 3-operand case ala fx+, w/3-operand library + + [(e1 . e*) #f]) + (define-inline 2 * + [() `(immediate ,(fix 1))] + [(e) (build-fxop? %*/ovfl 'multiply-overflow e `(quote 1) build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] + ; TODO: swap e1 & e2 if e1 is constant + [(e1 e2) (build-fxop? %*/ovfl 'multiply-overflow e1 e2 build-unfix (lambda (e1 e2) (build-libcall #t src sexpr * e1 e2)))] + ; TODO: handle 3-operand case ala fx+, w/3-operand library * + [(e1 . e*) #f]) + (define-inline 2 - + [(e) (build-fxop? %-/ovfl 'overflow `(quote 0) e values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] + [(e1 e2) (build-fxop? %-/ovfl 'overflow e1 e2 values (lambda (e1 e2) (build-libcall #t src sexpr - e1 e2)))] + ; TODO: handle 3-operand case ala fx+, w/3-operand library - + [(e1 e2 . e*) #f])) + (let () + (define build-fxop? + (lambda (op e k) + (let ([Lfail (make-local-label 'Lfail)]) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(bind #f ([t `(inline ,null-info ,op ,e (immediate ,(fix 1)))]) + `(if (inline ,(make-info-condition-code 'overflow #f #t) ,%condition-code) + (label ,Lfail ,(k e)) + ,t)) + (goto ,Lfail)))))) + + (define-syntax define-inline-1op + (syntax-rules () + [(_ op name) + (define-inline 2 name + [(e) (build-fxop? op e (lambda (e) (build-libcall #t src sexpr name e)))])])) + + (define-inline-1op %-/ovfl 1-) + (define-inline-1op %-/ovfl -1+) + (define-inline-1op %-/ovfl sub1) + (define-inline-1op %+/ovfl 1+) + (define-inline-1op %+/ovfl add1)) + + (define-inline 2 / + [(e) (build-libcall #f src sexpr / `(immediate ,(fix 1)) e)] + [(e1 e2) (build-libcall #f src sexpr / e1 e2)] + [(e1 . e*) #f]) + + (let () + (define (zgo src sexpr e e1 e2) + (build-simple-or + (%inline eq? ,e (immediate 0)) + `(if ,(build-fixnums? (list e)) + ,(%constant sfalse) + ,(build-libcall #t src sexpr = e1 e2)))) + (define (go src sexpr e1 e2) + (or (eqvop-null-fptr e1 e2) + (relop-length RELOP= e1 e2) + (cond + [(constant? (lambda (x) (eqv? x 0)) e1) + (bind #t (e2) (zgo src sexpr e2 e1 e2))] + [(constant? (lambda (x) (eqv? x 0)) e2) + (bind #t (e1) (zgo src sexpr e1 e1 e2))] + [else (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline eq? ,e1 ,e2) + ,(build-libcall #t src sexpr = e1 e2)))]))) + (define-inline 2 = + [(e1 e2) (go src sexpr e1 e2)] + [(e1 . e*) #f]) + (define-inline 2 r6rs:= + [(e1 e2) (go src sexpr e1 e2)] + [(e1 e2 . e*) #f])) + (let () + (define-syntax define-relop-inline + (syntax-rules () + [(_ name r6rs:name relop op) + (let () + (define builder + (lambda (e1 e2 libcall) + (or (relop-length relop e1 e2) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline op ,e1 ,e2) + ,(libcall e1 e2)))))) + (define-inline 2 name + [(e1 e2) + (builder e1 e2 + (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] + ; TODO: handle 3-operand case w/3-operand library routine + [(e1 . e*) #f]) + (define-inline 2 r6rs:name + [(e1 e2) + (builder e1 e2 + (lambda (e1 e2) (build-libcall #t src sexpr name e1 e2)))] + ; TODO: handle 3-operand case w/3-operand library routine + [(e1 e2 . e*) #f]))])) + (define-relop-inline < r6rs:< RELOP< <) + (define-relop-inline <= r6rs:<= RELOP<= <=) + (define-relop-inline >= r6rs:>= RELOP>= >=) + (define-relop-inline > r6rs:> RELOP> >)) + (define-inline 3 positive? ; 3 so opt-level 2 errors come from positive? + [(e) (handle-prim src sexpr 3 '> (list e `(quote 0)))]) + (define-inline 3 nonnegative? ; 3 so opt-level 2 errors come from nonnegative? + [(e) (handle-prim src sexpr 3 '>= (list e `(quote 0)))]) + (define-inline 3 negative? ; 3 so opt-level 2 errors come from negative? + [(e) (handle-prim src sexpr 3 '< (list e `(quote 0)))]) + (define-inline 3 nonpositive? ; 3 so opt-level 2 errors come from nonpositive? + [(e) (handle-prim src sexpr 3 '<= (list e `(quote 0)))]) + (define-inline 2 zero? + [(e) + (or (relop-length RELOP= e) + (nanopass-case (L7 Expr) e + [(call ,info ,mdcl ,pr ,e) + (guard + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (make-ftype-pointer-null? e)] + [else + (bind #t (e) + (build-simple-or + (%inline eq? ,e (immediate ,(fix 0))) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + ,(build-libcall #t src sexpr zero? e))))]))]) + (define-inline 2 positive? [(e) (relop-length RELOP> e)]) + (define-inline 2 nonnegative? [(e) (relop-length RELOP>= e)]) + (define-inline 2 negative? [(e) (relop-length RELOP< e)]) + (define-inline 2 nonpositive? [(e) (relop-length RELOP<= e)]) + (let () + (define-syntax define-logorop-inline + (syntax-rules () + [(_ name ...) + (let () + (define build-logop + (lambda (src sexpr e1 e2 libcall) + (bind #t (e1 e2) + (bind #t ([t (%inline logor ,e1 ,e2)]) + `(if ,(%type-check mask-fixnum type-fixnum ,t) + ,t + ,(libcall src sexpr e1 e2)))))) + (let () + (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) + (define-inline 2 name + [() `(immediate ,(fix 0))] + [(e) (build-logop src sexpr e `(immediate ,(fix 0)) libcall)] + [(e1 e2) (build-logop src sexpr e1 e2 libcall)] + [(e1 . e*) #f])) + ...)])) + (define-logorop-inline logor logior bitwise-ior)) + (let () + (define-syntax define-logop-inline + (syntax-rules () + [(_ op unit name ...) + (let () + (define build-logop + (lambda (src sexpr e1 e2 libcall) + (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline op ,e1 ,e2) + ,(libcall src sexpr e1 e2))))) + (let () + (define libcall (lambda (src sexpr e1 e2) (build-libcall #t src sexpr name e1 e2))) + (define-inline 2 name + [() `(immediate ,(fix unit))] + [(e) (build-logop src sexpr e `(immediate ,(fix unit)) libcall)] + [(e1 e2) (build-logop src sexpr e1 e2 libcall)] + [(e1 . e*) #f])) + ...)])) + (define-logop-inline logand -1 logand bitwise-and) + (define-logop-inline logxor 0 logxor bitwise-xor)) + (let () + (define build-lognot + (lambda (e libcall) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%inline logxor ,e (immediate ,(fxlognot (constant mask-fixnum)))) + ,(libcall e))))) + + (define-inline 2 lognot + [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr lognot e)))]) + (define-inline 2 bitwise-not + [(e) (build-lognot e (lambda (e) (build-libcall #t src sexpr bitwise-not e)))])) + + (let () + (define build-logbit? + (lambda (e1 e2 libcall) + (or (nanopass-case (L7 Expr) e1 + [(quote ,d) + (or (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline logtest ,e2 (immediate ,(fix (ash 1 d)))) + ,(libcall e1 e2)))) + (and (and (target-fixnum? d) (> d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline < ,e2 (immediate ,(fix 0))) + ,(libcall e1 e2)))))] + [else #f]) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (constant fixnum-bits))))) + ,(%inline logtest + ,(%inline sra ,e2 ,(build-unfix e1)) + (immediate ,(fix 1))) + ,(libcall e1 e2)))))) + + (define-inline 2 logbit? + [(e1 e2) (build-logbit? e1 e2 (lambda (e1 e2) (build-libcall #t src sexpr logbit? e1 e2)))]) + (define-inline 2 bitwise-bit-set? + [(e1 e2) (build-logbit? e2 e1 (lambda (e2 e1) (build-libcall #t src sexpr bitwise-bit-set? e1 e2)))])) + + (define-inline 2 logbit1 + [(e1 e2) (or (nanopass-case (L7 Expr) e1 + [(quote ,d) + (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline logor ,e2 (immediate ,(fix (ash 1 d)))) + ,(build-libcall #t src sexpr logbit1 e1 e2))))] + [else #f]) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logor ,e2 + ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1))) + ,(build-libcall #t src sexpr logbit1 e1 e2))))]) + (define-inline 2 logbit0 + [(e1 e2) (or (nanopass-case (L7 Expr) e1 + [(quote ,d) + (and (and (fixnum? d) (fx<= 0 d (fx- (constant fixnum-bits) 2))) + (bind #t (e2) + `(if ,(%type-check mask-fixnum type-fixnum ,e2) + ,(%inline logand ,e2 (immediate ,(fix (lognot (ash 1 d))))) + ,(build-libcall #t src sexpr logbit0 e1 e2))))] + [else #f]) + (bind #t (e1 e2) + `(if ,(build-and + (build-fixnums? (list e1 e2)) + (%inline u< ,e1 (immediate ,(fix (fx- (constant fixnum-bits) 1))))) + ,(%inline logand ,e2 + ,(%inline lognot + ,(%inline sll (immediate ,(fix 1)) ,(build-unfix e1)))) + ,(build-libcall #t src sexpr logbit0 e1 e2))))]) + (define-inline 2 logtest + [(e1 e2) (bind #t (e1 e2) + `(if ,(build-fixnums? (list e1 e2)) + ,(%inline logtest ,e1 ,e2) + ,(build-libcall #t src sexpr logtest e1 e2)))]) + (define-inline 3 $flhash + [(e) (bind #t (e) + `(if ,(build-fl= e e) + ,(%inline logand + ,(%inline srl + ,(constant-case ptr-bits + [(32) (%inline + + ,(%mref ,e ,(constant flonum-data-disp)) + ,(%mref ,e ,(fx+ (constant flonum-data-disp) 4)))] + [(64) (%mref ,e ,(constant flonum-data-disp))]) + (immediate 1)) + (immediate ,(- (constant fixnum-factor)))) + ;; +nan.0 + (immediate ,(fix #xfa1e))))]) + (let () + (define build-flonum-extractor + (lambda (pos size e1) + (let ([cnt (- pos (constant fixnum-offset))] + [mask (* (- (expt 2 size) 1) (expt 2 (constant fixnum-offset)))]) + (%inline logand + ,(let ([body (constant-case native-endianness + [(unknown) + (constant-case ptr-bits + [(64) + (%inline srl ,(%mref ,e1 ,(constant flonum-data-disp)) (immediate 32))] + [(32) + (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)])] + [else + `(inline ,(make-info-load 'integer-32 #f) ,%load ,e1 ,%zero + (immediate ,(constant-case native-endianness + [(little) (fx+ (constant flonum-data-disp) 4)] + [(big) (constant flonum-data-disp)])))])]) + (let ([body (if (fx> cnt 0) + (%inline srl ,body (immediate ,cnt)) + body)]) + (if (fx< cnt 0) + (%inline sll ,body (immediate ,(fx- 0 cnt))) + body))) + (immediate ,mask))))) + + (define-inline 3 fllp + [(e) (build-flonum-extractor 19 12 e)]) + + (define-inline 3 $flonum-sign + [(e) (build-flonum-extractor 31 1 e)]) + + (define-inline 3 $flonum-exponent + [(e) (build-flonum-extractor 20 11 e)])) + + (define-inline 3 $fleqv? + [(e1 e2) + (bind #t (e1 e2) + `(if ,(build-fl= e1 e1) ; check e1 not +nan.0 + ,(constant-case ptr-bits + [(32) (build-and + (%inline eq? + ,(%mref ,e1 ,(constant flonum-data-disp)) + ,(%mref ,e2 ,(constant flonum-data-disp))) + (%inline eq? + ,(%mref ,e1 ,(fx+ (constant flonum-data-disp) 4)) + ,(%mref ,e2 ,(fx+ (constant flonum-data-disp) 4))))] + [(64) (%inline eq? + ,(%mref ,e1 ,(constant flonum-data-disp)) + ,(%mref ,e2 ,(constant flonum-data-disp)))] + [else ($oops 'compiler-internal + "$fleqv doesn't handle ptr-bits = ~s" + (constant ptr-bits))]) + ;; If e1 is +nan.0, see if e2 is +nan.0: + ,(build-not (build-fl= e2 e2))))]) + + (let () + (define build-fp-op-1 + (lambda (op e) + (bind #f fp (e) + (if (procedure? op) (op e) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t)) ,op ,e)))))) + (define build-fp-op-2 + (lambda (op e1 e2) + (bind #f fp (e1 e2) + (if (procedure? op) (op e1 e2) `(unboxed-fp (inline ,(make-info-unboxed-args '(#t #t)) ,op ,e1 ,e2)))))) + (define build-fl-adjust-sign + (lambda (e combine base) + `(unboxed-fp + ,(constant-case ptr-bits + [(64) + (let ([t (make-tmp 'flsgn)]) + `(let ([,t (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto ,e)]) + (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,t ,base))))] + [(32) + (let ([thi (make-tmp 'flsgnh)] + [tlo (make-tmp 'flsgnl)]) + (bind #t fp (e) + `(let ([,thi (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)] + [,tlo (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/lo ,e)]) + (inline ,null-info ,%fpcastfrom (inline ,null-info ,combine ,thi ,base) ,tlo))))])))) + (define build-flabs + (lambda (e) + (build-fl-adjust-sign e %logand (%inline srl (immediate -1) (immediate 1))))) + (define build-flneg + (lambda (e) + (build-fl-adjust-sign e %logxor (%inline sll (immediate -1) (immediate ,(fx- (constant ptr-bits) 1)))))) + (define build-fl-call + (lambda (entry . e*) + `(foreign-call ,(with-output-language (Ltype Type) + (make-info-foreign '(atomic) (map (lambda (e) `(fp-double-float)) e*) `(fp-double-float) #t)) + (literal ,(make-info-literal #f 'entry entry 0)) + ,e* ...))) + + (define-inline 3 fl+ + [() `(quote 0.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-fp-op-2 %fp+ e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl+ e1 e*)]) + + (define-inline 3 fl* + [() `(quote 1.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-fp-op-2 %fp* e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl* e1 e*)]) + + (define-inline 3 fl- + [(e) (build-flneg e)] + [(e1 e2) (build-fp-op-2 %fp- e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl- e1 e*)]) + + (define-inline 3 fl/ + [(e) (build-fp-op-2 %fp/ `(quote 1.0) e)] + [(e1 e2) (build-fp-op-2 %fp/ e1 e2)] + [(e1 . e*) (reduce-fp src sexpr 3 'fl/ e1 e*)]) + + (define-inline 3 flsqrt + [(e) + (constant-case architecture + [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] + [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])]) + + (define-inline 3 flsingle + [(e) (build-fp-op-1 %fpsingle e)]) + + (define-inline 3 flabs + [(e) (build-flabs e)]) + + (let () + (define-syntax define-fl-call + (syntax-rules () + [(_ id extra ...) + (define-inline 3 id + [(e) (build-fl-call (lookup-c-entry id) e)] + extra ...)])) + (define-syntax define-fl2-call + (syntax-rules () + [(_ id id2) + (define-fl-call id + [(e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)])])) + (define-fl-call flround) ; no support in SSE2 for flround, though this was added in SSE4.1 + (define-fl-call flfloor) + (define-fl-call flceiling) + (define-fl-call fltruncate) + (define-fl-call flsin) + (define-fl-call flcos) + (define-fl-call fltan) + (define-fl-call flasin) + (define-fl-call flacos) + (define-fl2-call flatan flatan2) + (define-fl-call flexp) + (define-fl2-call fllog fllog2)) + + (define-inline 3 flexpt + [(e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)]) + + (let () + (define build-fl-make-rectangular + (lambda (e1 e2) + (bind #f (e1 e2) + (bind #t ([t (%constant-alloc type-typed-object (constant size-inexactnum))]) + (%seq + (set! ,(%mref ,t ,(constant inexactnum-type-disp)) + ,(%constant type-inexactnum)) + (set! ,(%mref ,t ,%zero ,(constant inexactnum-real-disp) fp) + ,(%mref ,e1 ,%zero ,(constant flonum-data-disp) fp)) + (set! ,(%mref ,t ,%zero ,(constant inexactnum-imag-disp) fp) + ,(%mref ,e2 ,%zero ,(constant flonum-data-disp) fp)) + ,t))))) + + (define-inline 3 fl-make-rectangular + [(e1 e2) (build-fl-make-rectangular e1 e2)]) + + (define-inline 3 cfl- + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,(build-flneg e) + ,(build-fl-make-rectangular + (build-flneg (build-$inexactnum-real-part e)) + (build-flneg (build-$inexactnum-imag-part e)))))] + [(e1 e2) (build-libcall #f src sexpr cfl- e1 e2)] + ; TODO: add 3 argument version of cfl- library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl- e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl+ + [() `(quote 0.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-libcall #f src sexpr cfl+ e1 e2)] + ; TODO: add 3 argument version of cfl+ library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl+ e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl* + [() `(quote 1.0)] + [(e) (ensure-single-valued e)] + [(e1 e2) (build-libcall #f src sexpr cfl* e1 e2)] + ; TODO: add 3 argument version of cfl* library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl* e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl/ + [(e) (build-libcall #f src sexpr cfl/ `(quote 1.0) e)] + [(e1 e2) (build-libcall #f src sexpr cfl/ e1 e2)] + ; TODO: add 3 argument version of cfl/ library function + #;[(e1 e2 e3) (build-libcall #f src sexpr cfl/ e1 e2 e3)] + [(e1 e2 . e*) #f]) + + (define-inline 3 cfl-conjugate + [(e) (bind #t (e) + `(if ,(%type-check mask-flonum type-flonum ,e) + ,e + ,(build-fl-make-rectangular + (build-$inexactnum-real-part e) + (build-flneg (build-$inexactnum-imag-part e)))))])) + + (define-inline 3 $make-exactnum + [(e1 e2) (bind #f (e1 e2) + (bind #t ([t (%constant-alloc type-typed-object (constant size-exactnum))]) + (%seq + (set! ,(%mref ,t ,(constant exactnum-type-disp)) + ,(%constant type-exactnum)) + (set! ,(%mref ,t ,(constant exactnum-real-disp)) ,e1) + (set! ,(%mref ,t ,(constant exactnum-imag-disp)) ,e2) + ,t)))]) + + (let () + (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) + (define build-fl= + (case-lambda + [(e) (if (constant nan-single-comparison-true?) + (%seq ,e (quote #t)) + (bind #t fp (e) (build-fl= e e)))] + [(e1 e2) (bind #f fp (e1 e2) + `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp= ,e1 ,e2))])) + (define (build-fl<= e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp<= ,e1 ,e2)) + + (let () + (define-syntax define-fl-cmp-inline + (lambda (x) + (syntax-case x () + [(_ op r6rs:op builder inequality? swapped?) + (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] + [reducer (if (datum inequality?) + #'(reduce-fp-compare reduce-inequality) + #'(reduce-fp-compare reduce-equality))]) + #'(begin + (define-inline 3 op + [(e) (build-fl= e)] + [(e1 e2) (builder args ...)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)]) + (define-inline 3 r6rs:op + [(e1 e2) (builder args ...)] + [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)])))]))) + + (define-fl-cmp-inline fl= fl=? build-fl= #f #f) + (define-fl-cmp-inline fl< fl fl>? build-fl< #t #t) + (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) + (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) + (let () + (define-syntax build-bind-and-check + (syntax-rules () + [(_ src sexpr op e1 e2 body) + (if (known-flonum-result? e1) + (if (known-flonum-result? e2) + body + (bind #t (e2) + `(if ,(%type-check mask-flonum type-flonum ,e2) + ,body + ,(build-libcall #t src sexpr op e2 e2)))) + (if (known-flonum-result? e2) + (bind #t (e1) + `(if ,(%type-check mask-flonum type-flonum ,e1) + ,body + ,(build-libcall #t src sexpr op e1 e1))) + (bind #t (e1 e2) + `(if ,(build-and + (%type-check mask-flonum type-flonum ,e1) + (%type-check mask-flonum type-flonum ,e2)) + ,body + ,(build-libcall #t src sexpr op e1 e2)))))])) + (define build-check-fp-arguments + (lambda (e* build-libcall k) + (let loop ([e* e*] [check-e* '()] [all-e* '()]) + (cond + [(null? e*) + (let loop ([check-e* (reverse check-e*)]) + (cond + [(null? check-e*) (apply k (reverse all-e*))] + [(null? (cdr check-e*)) + (let ([e1 (car check-e*)]) + `(if ,(%type-check mask-flonum type-flonum ,e1) + ,(loop '()) + ,(build-libcall e1 e1)))] + [else + (let ([e1 (car check-e*)] + [e2 (cadr check-e*)]) + `(if ,(build-and + (%type-check mask-flonum type-flonum ,e1) + (%type-check mask-flonum type-flonum ,e2)) + ,(loop (cddr check-e*)) + ,(build-libcall e1 e2)))]))] + [else + (let ([e1 (car e*)]) + (if (known-flonum-result? e1) + (loop (cdr e*) check-e* (cons e1 all-e*)) + (bind #t (e1) + (loop (cdr e*) (cons e1 check-e*) (cons e1 all-e*)))))])))) + (define-syntax define-fl-cmp-inline + (lambda (x) + (syntax-case x () + [(_ op r6rs:op builder inequality? swapped?) + (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))] + [reducer (if (datum inequality?) + #'(reduce-fp-compare reduce-inequality) + #'(reduce-fp-compare reduce-equality))]) + #'(begin + (define-inline 2 op + [(e1) (if (known-flonum-result? e1) + (build-fl= e1) + (bind #t (e1) + `(if ,(%type-check mask-flonum type-flonum ,e1) + ,(build-fl= e1) + ,(build-libcall #t src sexpr op e1 e1))))] + [(e1 e2) (build-bind-and-check src sexpr op e1 e2 (builder args ...))] + [(e1 e2 . e*) (and + (fx<= (length e*) (fx- inline-args-limit 2)) + (build-check-fp-arguments (cons* e1 e2 e*) + (lambda (e1 e2) (build-libcall #t src sexpr op e1 e2)) + (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))]) + (define-inline 2 r6rs:op + [(e1 e2) (build-bind-and-check src sexpr r6rs:op e1 e2 (builder args ...))] + [(e1 e2 . e*) (and + (fx<= (length e*) (fx- inline-args-limit 2)) + (build-check-fp-arguments (cons* e1 e2 e*) + (lambda (e1 e2) (build-libcall #t src sexpr r6rs:op e1 e2)) + (lambda (e1 e2 . e*) (reducer src sexpr moi e1 e2 e*))))])))]))) + + (define-fl-cmp-inline fl= fl=? build-fl= #f #f) + (define-fl-cmp-inline fl< fl fl>? build-fl< #t #t) + (define-fl-cmp-inline fl<= fl<=? build-fl<= #t #f) + (define-fl-cmp-inline fl>= fl>=? build-fl<= #t #t)) + (let () + (define build-cfl= + ; NB: e1 and e2 must be bound + (lambda (e1 e2) + `(if ,(%type-check mask-flonum type-flonum ,e1) + (if ,(%type-check mask-flonum type-flonum ,e2) + ,(build-fl= e1 e2) + ,(build-and + (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e2)) + (build-fl= e1 (build-$inexactnum-real-part e2)))) + (if ,(%type-check mask-flonum type-flonum ,e2) + ,(build-and + (build-fl= `(quote 0.0) (build-$inexactnum-imag-part e1)) + (build-fl= e2 (build-$inexactnum-real-part e1))) + ,(build-and + (build-fl= + (build-$inexactnum-imag-part e1) + (build-$inexactnum-imag-part e2)) + (build-fl= + (build-$inexactnum-real-part e1) + (build-$inexactnum-real-part e2))))))) + (define-inline 3 cfl= + [(e) (if (constant nan-single-comparison-true?) + (%seq ,e (quote #t)) + (bind #f (e) (build-cfl= e e)))] + [(e1 e2) (bind #f (e1 e2) (build-cfl= e1 e2))] + ; TODO: should we avoid building for more then the 3 item case? + [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]))) + + (let () + (define build-checked-fp-op + (case-lambda + [(e k) + (if (known-flonum-result? e) + e + (bind #t (e) + `(if ,(build-flonums? (list e)) + ,e + ,(k e))))] + [(e1 op k) ; `op` can be a procedure that produces an unboxed value + (if (known-flonum-result? e1) + (build-fp-op-1 op e1) + (bind #t (e1) + (let ([e (build-fp-op-1 op e1)] + [k (lambda (e) + `(if ,(build-flonums? (list e1)) + ,e + ,(k e1)))]) + ((lift-fp-unboxed k) e))))] + [(e1 e2 op k) ; `op` can be a procedure that produces an unboxed value + ;; uses result of `e1` or `e2` twice for error if other is always a flonum + (let ([build (lambda (e1 e2) + (build-fp-op-2 op e1 e2))]) + (if (known-flonum-result? e1) + (if (known-flonum-result? e2) + (build e1 e2) + (bind #t (e2) + (build e1 `(if ,(build-flonums? (list e2)) + ,e2 + ,(k e2 e2))))) + (if (known-flonum-result? e2) + (bind #t (e1) + (build `(if ,(build-flonums? (list e1)) + ,e1 + ,(k e1 e1)) + e2)) + (bind #t (e1 e2) + (let ([e (build e1 e2)] + [k (lambda (e) + `(if ,(build-flonums? (list e1 e2)) + ,e + ,(k e1 e2)))]) + ((lift-fp-unboxed k) e))))))])) + + (define-inline 2 fl+ + [() `(quote 0.0)] + [(e) (build-checked-fp-op e + (lambda (e) + (build-libcall #t src sexpr fl+ e `(quote 0.0))))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp+ + (lambda (e1 e2) + (build-libcall #t src sexpr fl+ e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl+ e1 e*)]) + + (define-inline 2 fl* + [() `(quote 1.0)] + [(e) (build-checked-fp-op e + (lambda (e) + (build-libcall #t src sexpr fl* e `(quote 1.0))))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp* + (lambda (e1 e2) + (build-libcall #t src sexpr fl* e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl* e1 e*)]) + + (define-inline 2 fl- + [(e) (build-checked-fp-op e build-flneg + (lambda (e) + (build-libcall #t src sexpr flnegate e)))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp- + (lambda (e1 e2) + (build-libcall #t src sexpr fl- e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl- e1 e*)]) + + (define-inline 2 fl/ + [(e) (build-checked-fp-op `(quote 1.0) e %fp/ + (lambda (e1 e2) + (build-libcall #t src sexpr fl/ e1 e2)))] + [(e1 e2) (build-checked-fp-op e1 e2 %fp/ + (lambda (e1 e2) + (build-libcall #t src sexpr fl/ e1 e2)))] + [(e1 . e*) (reduce-fp src sexpr 2 'fl/ e1 e*)]) + + (define-inline 2 flabs + [(e) (build-checked-fp-op e build-flabs + (lambda (e) + (build-libcall #t src sexpr flabs e)))]) + + (define-inline 2 flsqrt + [(e) + (build-checked-fp-op e + (lambda (e) + (constant-case architecture + [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] + [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])) + (lambda (e) + (build-libcall #t src sexpr flsqrt e)))]) + + (define-inline 2 flsingle + [(e) + (build-checked-fp-op e + (lambda (e) (build-fp-op-1 %fpsingle e)) + (lambda (e) + (build-libcall #t src sexpr flsingle e)))]) + + (let () + (define-syntax define-fl-call + (syntax-rules () + [(_ id) + (define-inline 2 id + [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) + (lambda (e) + (build-libcall #t src sexpr id e)))])])) + (define-syntax define-fl2-call + (syntax-rules () + [(_ id id2) + (define-inline 2 id + [(e) (build-checked-fp-op e (lambda (e) (build-fl-call (lookup-c-entry id) e)) + (lambda (e) + (build-libcall #t src sexpr id e)))] + [(e1 e2) (build-checked-fp-op e1 e2 (lambda (e1 e2) (build-fl-call (lookup-c-entry id2) e1 e2)) + (lambda (e1 e2) + (build-libcall #t src sexpr id2 e1 e2)))])])) + (define-fl-call flround) + (define-fl-call flfloor) + (define-fl-call flceiling) + (define-fl-call fltruncate) + (define-fl-call flsin) + (define-fl-call flcos) + (define-fl-call fltan) + (define-fl-call flasin) + (define-fl-call flacos) + (define-fl2-call flatan flatan2) + (define-fl-call flexp) + (define-fl2-call fllog fllog2)) + + (define-inline 2 flexpt + [(e1 e2) (build-checked-fp-op e1 e2 + (lambda (e1 e2) (build-fl-call (lookup-c-entry flexpt) e1 e2)) + (lambda (e1 e2) + (build-libcall #t src sexpr flexpt e1 e2)))]) + + ;; NB: assuming that we have a trunc instruction for now, will need to change to support Sparc + (define-inline 3 flonum->fixnum + [(e-x) (bind #f fp (e-x) + (build-fix + `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)))]) + (define-inline 2 flonum->fixnum + [(e-x) (build-checked-fp-op e-x + (lambda (e-x) + (define (build-fl< e1 e2) `(inline ,(make-info-unboxed-args '(#t #t)) ,%fp< ,e1 ,e2)) + (bind #t (e-x) + `(if ,(build-and + (build-fl< e-x `(quote ,(constant too-positive-flonum-for-fixnum))) + (build-fl< `(quote ,(constant too-negative-flonum-for-fixnum)) e-x)) + ,(build-fix + `(inline ,(make-info-unboxed-args '(#t)) ,%fptrunc ,e-x)) + ;; We have to box the flonum to report an error: + ,(let ([t (make-tmp 't)]) + `(let ([,t ,(%constant-alloc type-flonum (constant size-flonum))]) + (seq + (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) ,e-x) + ,(build-libcall #t src sexpr flonum->fixnum t))))))) + (lambda (e-x) + (build-libcall #t src sexpr flonum->fixnum e-x)))]))) + + (let () + (define build-fixnum->flonum + ; NB: x must already be bound in order to ensure it is done before the flonum is allocated + (lambda (e-x k) + (k `(unboxed-fp ,(%inline fpt ,(build-unfix e-x)))))) + (define-inline 3 fixnum->flonum + [(e-x) (bind #f (e-x) (build-fixnum->flonum e-x values))]) + (define-inline 2 fixnum->flonum + [(e-x) (bind #t (e-x) + (build-fixnum->flonum e-x + (lift-fp-unboxed + (lambda (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e-x) + ,e + ,(build-libcall #t src sexpr fixnum->flonum e-x))))))]) + (define-inline 2 real->flonum + [(e-x) + (if (known-flonum-result? e-x) + e-x + (bind #t (e-x) + `(if ,(%type-check mask-fixnum type-fixnum ,e-x) + ,(build-fixnum->flonum e-x values) + (if ,(%type-check mask-flonum type-flonum ,e-x) + ,e-x + ,(build-libcall #t src sexpr real->flonum e-x `(quote real->flonum))))))])) + (define-inline 3 $real->flonum + [(x who) (build-$real->flonum src sexpr x who)]) + (define-inline 2 $record + [(tag . args) (build-$record tag args)]) + (define-inline 3 $object-address + [(e-ptr e-offset) + (unsigned->ptr + (%inline + ,e-ptr ,(build-unfix e-offset)) + (type->width ptr-type))]) + (define-inline 3 $address->object + [(e-addr e-roffset) + (bind #f (e-roffset) + (%inline - + ,(ptr->integer e-addr (type->width ptr-type)) + ,(build-unfix e-roffset)))]) + (define-inline 2 $object-ref + [(type base offset) + (nanopass-case (L7 Expr) type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (build-object-ref #f type base offset)))] + [else #f])]) + (define-inline 2 $swap-object-ref + [(type base offset) + (nanopass-case (L7 Expr) type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (build-object-ref #t type base offset)))] + [else #f])]) + (define-inline 3 foreign-ref + [(e-type e-addr e-offset) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (bind #f (e-offset) + (build-object-ref #f type + (ptr->integer e-addr (constant ptr-bits)) + e-offset))))] + [else #f])]) + (define-inline 3 $foreign-swap-ref + [(e-type e-addr e-offset) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (bind #f (e-offset) + (build-object-ref #t type + (ptr->integer e-addr (constant ptr-bits)) + e-offset))))] + [else #f])]) + (define-inline 2 $object-set! + [(type base offset value) + (nanopass-case (L7 Expr) type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) + (build-object-set! type base offset value)))] + [else #f])]) + (define-inline 3 foreign-set! + [(e-type e-addr e-offset e-value) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (or (>= (constant ptr-bits) (type->width type)) (eq? type 'double-float)) + (bind #f (e-offset e-value) + (build-object-set! type + (ptr->integer e-addr (constant ptr-bits)) + e-offset + e-value))))] + [else #f])]) + (define-inline 3 $foreign-swap-set! + [(e-type e-addr e-offset e-value) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean single-float))) + (>= (constant ptr-bits) (type->width type)) + (bind #f (e-offset e-value) + (build-swap-object-set! type + (ptr->integer e-addr (constant ptr-bits)) + e-offset + e-value))))] + [else #f])]) + (define-inline 2 $make-fptr + [(e-ftype e-addr) + (nanopass-case (L7 Expr) e-addr + [(call ,info ,mdcl ,pr ,e1) + (guard + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (bind #f (e-ftype e1) + (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) + (%seq + (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) + (set! ,(%mref ,t ,(constant record-data-disp)) + ,(%mref ,e1 ,(constant record-data-disp))) + ,t)))] + [else + (bind #f (e-ftype e-addr) + (bind #t ([t (%constant-alloc type-typed-object (fx* 2 (constant ptr-bytes)))]) + (%seq + (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype) + (set! ,(%mref ,t ,(constant record-data-disp)) + ,(ptr->integer e-addr (constant ptr-bits))) + ,t)))])]) + (define-inline 3 ftype-pointer-address + [(e-fptr) + (build-object-ref #f + (constant-case ptr-bits + [(64) 'unsigned-64] + [(32) 'unsigned-32]) + e-fptr %zero (constant record-data-disp))]) + (define-inline 3 ftype-pointer-null? + [(e-fptr) (make-ftype-pointer-null? e-fptr)]) + (define-inline 3 ftype-pointer=? + [(e1 e2) (make-ftype-pointer-equal? e1 e2)]) + (let () + (define build-fx+raw + (lambda (fx-arg raw-arg) + (if (constant? (lambda (x) (eqv? x 0)) fx-arg) + raw-arg + (%inline + ,raw-arg ,(build-unfix fx-arg))))) + (define $extract-fptr-address + (lambda (e-fptr) + (define suppress-unsafe-cast + (lambda (e-fptr) + (nanopass-case (L7 Expr) e-fptr + [(call ,info1 ,mdcl1 ,pr1 (quote ,d) (call ,info2 ,mdcl2 ,pr2 ,e)) + (guard + (eq? (primref-name pr1) '$make-fptr) + (all-set? (prim-mask unsafe) (primref-flags pr2)) + (eq? (primref-name pr2) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr2))) + e] + [else e-fptr]))) + (nanopass-case (L7 Expr) e-fptr + ; skip allocation and dereference of ftype-pointer for $fptr-fptr-ref + [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd + (guard + (eq? (primref-name pr) '$fptr-fptr-ref) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e2)]) + (bind #f (e-index e3) + `(inline ,(make-info-load ptr-type #f) ,%load + ,($extract-fptr-address e1) + ,e-index (immediate ,imm-offset))))] + ; skip allocation and dereference of ftype-pointer for $fptr-&ref + [(call ,info ,mdcl ,pr ,e1 ,e2 ,e3) ; e1, e2, e3 = fptr, offset, ftd + (guard + (eq? (primref-name pr) '$fptr-&ref) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (build-fx+raw e2 ($extract-fptr-address e1))] + ; skip allocation and dereference of ftype-pointer for $make-fptr + [(call ,info ,mdcl ,pr ,e1 ,e2) ; e1, e2 = ftd, (ptr) addr + (guard + (eq? (primref-name pr) '$make-fptr) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (nanopass-case (L7 Expr) e2 + [(call ,info ,mdcl ,pr ,e3) + (guard + (eq? (primref-name pr) 'ftype-pointer-address) + (all-set? (prim-mask unsafe) (primref-flags pr))) + (bind #f (e1) + (%mref ,e3 ,(constant record-data-disp)))] + [else + (bind #f (e1) + (ptr->integer e2 (constant ptr-bits)))])] + [else + `(inline ,(make-info-load ptr-type #f) ,%load ,(suppress-unsafe-cast e-fptr) ,%zero + ,(%constant record-data-disp))]))) + (let () + (define-inline 3 $fptr-offset-addr + [(e-fptr e-offset) + ; bind offset before doing the load (a) to maintain applicative order---the + ; load can cause an invalid memory reference---and (b) so that the raw value + ; isn't live across any calls + (bind #f (e-offset) + (build-fx+raw e-offset + ($extract-fptr-address e-fptr)))]) + (define-inline 3 $fptr-&ref + [(e-fptr e-offset e-ftd) + ; see comment in $fptr-offset-addr + (bind #f (e-offset e-ftd) + (build-$record e-ftd + (list (build-fx+raw e-offset ($extract-fptr-address e-fptr)))))])) + (define-inline 3 $fptr-fptr-ref + [(e-fptr e-offset e-ftd) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #f (e-index) + (build-$record e-ftd + (list `(inline ,(make-info-load ptr-type #f) ,%load + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset))))))]) + (define-inline 3 $fptr-fptr-set! + [(e-fptr e-offset e-val) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #f ([e-addr ($extract-fptr-address e-fptr)] e-index e-val) + `(inline ,(make-info-load ptr-type #f) ,%store ,e-addr ,e-index (immediate ,imm-offset) + (inline ,(make-info-load ptr-type #f) ,%load ,e-val ,%zero + ,(%constant record-data-disp)))))]) + (let () + (define $do-fptr-ref-inline + (lambda (swapped? type e-fptr e-offset) + (bind #f (e-offset) + (build-object-ref swapped? type ($extract-fptr-address e-fptr) e-offset)))) + (define-syntax define-fptr-ref-inline + (lambda (x) + (define build-inline + (lambda (name type ref maybe-k) + #`(define-inline 3 #,name + [(e-fptr e-offset) + #,((lambda (body) (if maybe-k #`(#,maybe-k #,body) body)) + #`($do-fptr-ref-inline #,ref #,type e-fptr e-offset))]))) + (syntax-case x () + [(_ name ?type ref) (build-inline #'name #'?type #'ref #f)] + [(_ name ?type ref ?k) (build-inline #'name #'?type #'ref #'?k)]))) + + (define-fptr-ref-inline $fptr-ref-integer-8 'integer-8 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-8 'unsigned-8 #f) + + (define-fptr-ref-inline $fptr-ref-integer-16 'integer-16 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-16 'unsigned-16 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-16 'integer-16 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-16 'unsigned-16 #t) + + (when-known-endianness + (define-fptr-ref-inline $fptr-ref-integer-24 'integer-24 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-24 'unsigned-24 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-24 'integer-24 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-24 'unsigned-24 #t)) + + (define-fptr-ref-inline $fptr-ref-integer-32 'integer-32 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-32 'unsigned-32 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-32 'integer-32 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-32 'unsigned-32 #t) + + (when-known-endianness + (define-fptr-ref-inline $fptr-ref-integer-40 'integer-40 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-40 'unsigned-40 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-40 'integer-40 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-40 'unsigned-40 #t) + + (define-fptr-ref-inline $fptr-ref-integer-48 'integer-48 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-48 'unsigned-48 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-48 'integer-48 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-48 'unsigned-48 #t) + + (define-fptr-ref-inline $fptr-ref-integer-56 'integer-56 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-56 'unsigned-56 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-56 'integer-56 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-56 'unsigned-56 #t)) + + (define-fptr-ref-inline $fptr-ref-integer-64 'integer-64 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-64 'unsigned-64 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-64 'integer-64 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-64 'unsigned-64 #t) + + (define-fptr-ref-inline $fptr-ref-double-float 'double-float #f) + (define-fptr-ref-inline $fptr-ref-swap-double-float 'double-float #t) + + (define-fptr-ref-inline $fptr-ref-single-float 'single-float #f) + (define-fptr-ref-inline $fptr-ref-swap-single-float 'single-float #t) + + (define-fptr-ref-inline $fptr-ref-char 'unsigned-8 #f + (lambda (x) (build-integer->char x))) + + (define-fptr-ref-inline $fptr-ref-wchar + (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) + #f + (lambda (x) (build-integer->char x))) + (define-fptr-ref-inline $fptr-ref-swap-wchar + (constant-case wchar-bits [(16) 'unsigned-16] [(32) 'unsigned-32]) + #t + (lambda (x) (build-integer->char x))) + + (define-fptr-ref-inline $fptr-ref-boolean + (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) + #f + (lambda (x) + `(if ,(%inline eq? ,x (immediate 0)) + ,(%constant sfalse) + ,(%constant strue)))) + (define-fptr-ref-inline $fptr-ref-swap-boolean + (constant-case int-bits [(32) 'unsigned-32] [(64) 'unsigned-64]) + #t + (lambda (x) + `(if ,(%inline eq? ,x (immediate 0)) + ,(%constant sfalse) + ,(%constant strue)))) + + (define-fptr-ref-inline $fptr-ref-fixnum 'fixnum #f) + (define-fptr-ref-inline $fptr-ref-swap-fixnum 'fixnum #t)) + (let () + (define $do-fptr-set!-inline + (lambda (set type e-fptr e-offset e-val) + (bind #f (e-offset) + (set type ($extract-fptr-address e-fptr) e-offset e-val)))) + (define-syntax define-fptr-set!-inline + (lambda (x) + (define build-body + (lambda (type set maybe-massage-val) + #``(seq ,e-info + #,(let ([body #`($do-fptr-set!-inline #,set #,type e-fptr e-offset e-val)]) + (if maybe-massage-val + #`,(bind #f (e-offset [e-val (#,maybe-massage-val e-val)]) #,body) + #`,(bind #f (e-offset e-val) #,body)))))) + (define build-inline + (lambda (name check-64? body) + #`(define-inline 3 #,name + [(e-info e-fptr e-offset e-val) + #,(if check-64? + #`(and (fx>= (constant ptr-bits) 64) #,body) + body)]))) + (syntax-case x () + [(_ check-64? name ?type set) + (build-inline #'name (datum check-64?) (build-body #'?type #'set #f))] + [(_ check-64? name ?type set ?massage-value) + (build-inline #'name (datum check-64?) (build-body #'?type #'set #'?massage-value))]))) + + (define-fptr-set!-inline #f $fptr-set-integer-8! 'integer-8 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-8! 'unsigned-8 build-object-set!) + + (define-fptr-set!-inline #f $fptr-set-integer-16! 'integer-16 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-16! 'unsigned-16 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-integer-16! 'integer-16 build-swap-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-unsigned-16! 'unsigned-16 build-swap-object-set!) + + (when-known-endianness + (define-fptr-set!-inline #f $fptr-set-integer-24! 'integer-24 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-24! 'unsigned-24 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-integer-24! 'integer-24 build-swap-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-unsigned-24! 'unsigned-24 build-swap-object-set!)) + + (define-fptr-set!-inline #f $fptr-set-integer-32! 'integer-32 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-32! 'unsigned-32 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-integer-32! 'integer-32 build-swap-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-unsigned-32! 'unsigned-32 build-swap-object-set!) + + (when-known-endianness + (define-fptr-set!-inline #t $fptr-set-integer-40! 'integer-40 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-40! 'unsigned-40 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-40! 'integer-40 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-40! 'unsigned-40 build-swap-object-set!) + + (define-fptr-set!-inline #t $fptr-set-integer-48! 'integer-48 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-48! 'unsigned-48 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-48! 'integer-48 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-48! 'unsigned-48 build-swap-object-set!) + + (define-fptr-set!-inline #t $fptr-set-integer-56! 'integer-56 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-56! 'unsigned-56 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-56! 'integer-56 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-56! 'unsigned-56 build-swap-object-set!)) + + (define-fptr-set!-inline #t $fptr-set-integer-64! 'integer-64 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-64! 'unsigned-64 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-64! 'integer-64 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-64! 'unsigned-64 build-swap-object-set!) + + (define-fptr-set!-inline #f $fptr-set-double-float! 'double-float build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-double-float! 'double-float build-swap-object-set!) + + (define-fptr-set!-inline #f $fptr-set-single-float! 'single-float build-object-set!) + + (define-fptr-set!-inline #f $fptr-set-char! 'unsigned-8 build-object-set! + (lambda (z) (build-char->integer z))) + + (define-fptr-set!-inline #f $fptr-set-wchar! + (constant-case wchar-bits + [(16) 'unsigned-16] + [(32) 'unsigned-32]) + build-object-set! + (lambda (z) (build-char->integer z))) + (define-fptr-set!-inline #f $fptr-set-swap-wchar! + (constant-case wchar-bits + [(16) 'unsigned-16] + [(32) 'unsigned-32]) + build-swap-object-set! + (lambda (z) (build-char->integer z))) + + (define-fptr-set!-inline #f $fptr-set-boolean! + (constant-case int-bits + [(32) 'unsigned-32] + [(64) 'unsigned-64]) + build-object-set! + (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) + (define-fptr-set!-inline #f $fptr-set-swap-boolean! + (constant-case int-bits + [(32) 'unsigned-32] + [(64) 'unsigned-64]) + build-swap-object-set! + (lambda (z) `(if ,z (immediate ,(fix 1)) (immediate ,(fix 0))))) + + (define-fptr-set!-inline #f $fptr-set-fixnum! 'fixnum build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-fixnum! 'fixnum build-swap-object-set!)) + (let () + (define-syntax define-fptr-bits-ref-inline + (lambda (x) + (syntax-case x () + [(_ name signed? type swapped?) + #'(define-inline 3 name + [(e-fptr e-offset e-start e-end) + (and (fixnum-constant? e-start) (fixnum-constant? e-end) + (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) + (and (<= (type->width 'type) (constant ptr-bits)) + (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) + ((if signed? fx<= fx<) (fx- imm-end imm-start) (constant fixnum-bits)) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #f (e-index) + (build-int-load swapped? 'type ($extract-fptr-address e-fptr) e-index imm-offset + (lambda (x) + ((if signed? extract-signed-bitfield extract-unsigned-bitfield) #t imm-start imm-end x))))))))])]))) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-8 #t unsigned-8 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-8 #f unsigned-8 #f) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-16 #t unsigned-16 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-16 #f unsigned-16 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-16 #t unsigned-16 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-16 #f unsigned-16 #t) + + (when-known-endianness + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-24 #t unsigned-24 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-24 #f unsigned-24 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-24 #t unsigned-24 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-24 #f unsigned-24 #t)) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-32 #t unsigned-32 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-32 #f unsigned-32 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-32 #t unsigned-32 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-32 #f unsigned-32 #t) + + (when-known-endianness + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-40 #t unsigned-40 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-40 #f unsigned-40 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-40 #t unsigned-40 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-40 #f unsigned-40 #t) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-48 #t unsigned-48 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-48 #f unsigned-48 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-48 #t unsigned-48 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-48 #f unsigned-48 #t) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-56 #t unsigned-56 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-56 #f unsigned-56 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-56 #t unsigned-56 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-56 #f unsigned-56 #t)) + + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-64 #t unsigned-64 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-64 #f unsigned-64 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-64 #t unsigned-64 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-64 #f unsigned-64 #t)) + (let () + (define-syntax define-fptr-bits-set-inline + (lambda (x) + (syntax-case x () + [(_ check-64? name type swapped?) + (with-syntax ([(checks ...) #'((fixnum-constant? e-start) (fixnum-constant? e-end))]) + (with-syntax ([(checks ...) (if (datum check-64?) + #'((fx>= (constant ptr-bits) 64) checks ...) + #'(checks ...))]) + #`(define-inline 3 name + [(e-fptr e-offset e-start e-end e-val) + (and + checks ... + (let ([imm-start (constant-value e-start)] [imm-end (constant-value e-end)]) + (and (<= (type->width 'type) (constant ptr-bits)) + (and (fx>= imm-start 0) (fx> imm-end imm-start) (fx<= imm-end (constant ptr-bits))) + (fx< (fx- imm-end imm-start) (constant fixnum-bits)) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #t (e-index) + (bind #f (e-val) + (bind #t ([e-addr ($extract-fptr-address e-fptr)]) + (build-int-load swapped? 'type e-addr e-index imm-offset + (lambda (x) + (build-int-store swapped? 'type e-addr e-index imm-offset + (insert-bitfield #t imm-start imm-end (type->width 'type) x + e-val)))))))))))])))]))) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-8! unsigned-8 #f) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-16! unsigned-16 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-16! unsigned-16 #t) + + (when-known-endianness + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-24! unsigned-24 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-24! unsigned-24 #t)) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-32! unsigned-32 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-32! unsigned-32 #t) + + (when-known-endianness + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-40! unsigned-40 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-40! unsigned-40 #t) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-48! unsigned-48 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-48! unsigned-48 #t) + + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-56! unsigned-56 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-56! unsigned-56 #t)) + + (define-fptr-bits-set-inline #t $fptr-set-bits-unsigned-64! unsigned-64 #f) + (define-fptr-bits-set-inline #t $fptr-set-bits-swap-unsigned-64! unsigned-64 #t)) + (define-inline 3 $fptr-locked-decr! + [(e-fptr e-offset) + `(seq + ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (%inline locked-decr! + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset))) + (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) + (define-inline 3 $fptr-locked-incr! + [(e-fptr e-offset) + `(seq + ,(let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (%inline locked-incr! + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset))) + (inline ,(make-info-condition-code 'eq? #f #t) ,%condition-code))]) + (let () + (define clear-lock + (lambda (e-fptr e-offset) + (let ([lock-type (constant-case ptr-bits [(32) 'integer-32] [(64) 'integer-64])]) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + `(inline ,(make-info-load lock-type #f) ,%store + ,($extract-fptr-address e-fptr) + ,e-index (immediate ,imm-offset) (immediate 0)))))) + (define-inline 3 $fptr-init-lock! + [(e-fptr e-offset) (clear-lock e-fptr e-offset)]) + (define-inline 3 $fptr-unlock! + [(e-fptr e-offset) (clear-lock e-fptr e-offset)])) + (define-inline 3 $fptr-lock! + [(e-fptr e-offset) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #t ([e-base ($extract-fptr-address e-fptr)]) + (%inline lock! ,e-base ,e-index (immediate ,imm-offset))))]) + (define-inline 3 $fptr-spin-lock! + [(e-fptr e-offset) + (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)]) + (bind #t ([e-base ($extract-fptr-address e-fptr)]) + (bind #t (e-index) + (let ([L1 (make-local-label 'L1)] [L2 (make-local-label 'L2)]) + `(label ,L1 + (if ,(%inline lock! ,e-base ,e-index (immediate ,imm-offset)) + ,(%constant svoid) + (seq + (pariah) + (label ,L2 + (seq + ,(%inline pause) + (if ,(%inline eq? (mref ,e-base ,e-index ,imm-offset uptr) (immediate 0)) + (goto ,L1) + (goto ,L2)))))))))))])) + (let () + (define build-port-flags-set? + (lambda (e-p e-flags) + (%inline logtest + ,(%mref ,e-p ,(constant port-type-disp)) + ,(nanopass-case (L7 Expr) e-flags + [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] + [else (%inline sll ,e-flags + (immediate ,(fx- (constant port-flags-offset) (constant fixnum-offset))))])))) + (define build-port-input-empty? + (lambda (e-p) + (%inline eq? + ,(%mref ,e-p ,(constant port-icount-disp)) + (immediate 0)))) + (define-inline 3 binary-port? + [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-binary)))]) + (define-inline 3 textual-port? + [(e-p) (build-not (build-port-flags-set? e-p `(quote ,(constant port-flag-binary))))]) + (define-inline 3 port-closed? + [(e-p) (build-port-flags-set? e-p `(quote ,(constant port-flag-closed)))]) + (define-inline 3 $port-flags-set? + [(e-p e-flags) (build-port-flags-set? e-p e-flags)]) + (define-inline 3 port-eof? + [(e-p) + (bind #t (e-p) + `(if ,(build-port-input-empty? e-p) + (if ,(build-port-flags-set? e-p `(quote ,(constant port-flag-eof))) + (immediate ,(constant strue)) + ,(build-libcall #t src sexpr unsafe-port-eof? e-p)) + (immediate ,(constant sfalse))))]) + (define-inline 2 port-eof? + [(e-p) + (let ([Llib (make-local-label 'Llib)]) + (bind #t (e-p) + `(if ,(%type-check mask-typed-object type-typed-object ,e-p) + ,(bind #t ([t0 (%mref ,e-p ,(constant typed-object-type-disp))]) + `(if ,(%type-check mask-input-port type-input-port ,t0) + (if ,(build-port-input-empty? e-p) + (if ,(%inline logtest ,t0 + (immediate ,(ash (constant port-flag-eof) (constant port-flags-offset)))) + (immediate ,(constant strue)) + (label ,Llib ,(build-libcall #t src sexpr safe-port-eof? e-p))) + (immediate ,(constant sfalse))) + (goto ,Llib))) + (goto ,Llib))))]) + (define-inline 3 port-input-empty? + [(e-p) (build-port-input-empty? e-p)]) + (define-inline 3 port-output-full? + [(e-p) + (%inline eq? + ,(%mref ,e-p ,(constant port-ocount-disp)) + (immediate 0))])) + (let () + (define build-set-port-flags! + (lambda (e-p e-flags) + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-type-disp)) + ,(%inline logor + ,(%mref ,e-p ,(constant port-type-disp)) + ,(nanopass-case (L7 Expr) e-flags + [(quote ,d) `(immediate ,(ash d (constant port-flags-offset)))] + [else + (translate e-flags + (constant fixnum-offset) + (constant port-flags-offset))])))))) + (define build-reset-port-flags! + (lambda (e-p e-flags) + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-type-disp)) + ,(%inline logand + ,(%mref ,e-p ,(constant port-type-disp)) + ,(nanopass-case (L7 Expr) e-flags + [(quote ,d) `(immediate ,(lognot (ash d (constant port-flags-offset))))] + [else + (%inline lognot + ,(translate e-flags + (constant fixnum-offset) + (constant port-flags-offset)))])))))) + (define-inline 3 $set-port-flags! + [(e-p e-flags) (build-set-port-flags! e-p e-flags)]) + (define-inline 3 $reset-port-flags! + [(e-p e-flags) (build-reset-port-flags! e-p e-flags)]) + (define-inline 3 mark-port-closed! + [(e-p) (build-set-port-flags! e-p `(quote ,(constant port-flag-closed)))]) + (let () + (define (go e-p e-bool flag) + (let ([e-flags `(quote ,flag)]) + (nanopass-case (L7 Expr) e-bool + [(quote ,d) + ((if d build-set-port-flags! build-reset-port-flags!) e-p e-flags)] + [else + (bind #t (e-p) + `(if ,e-bool + ,(build-set-port-flags! e-p e-flags) + ,(build-reset-port-flags! e-p e-flags)))]))) + (define-inline 3 set-port-bol! + [(e-p e-bool) (go e-p e-bool (constant port-flag-bol))]) + (define-inline 3 set-port-eof! + [(e-p e-bool) (go e-p e-bool (constant port-flag-eof))]))) + (let () + (define (build-port-input-size port-type e-p) + (bind #t (e-p) + (translate + (%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%mref ,e-p ,(constant port-ibuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-input-size + [(e-p) (build-port-input-size 'textual e-p)]) + (define-inline 3 binary-port-input-size + [(e-p) (build-port-input-size 'binary e-p)])) + (let () + (define (build-port-output-size port-type e-p) + (bind #t (e-p) + (translate + (%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%mref ,e-p ,(constant port-obuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-output-size + [(e-p) (build-port-output-size 'textual e-p)]) + (define-inline 3 binary-port-output-size + [(e-p) (build-port-output-size 'binary e-p)])) + (let () + (define (build-port-input-index port-type e-p) + (bind #t (e-p) + (translate + ; TODO: use lea2? + (%inline + + ,(%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%mref ,e-p ,(constant port-ibuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,(%mref ,e-p ,(constant port-icount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-input-index + [(e-p) (build-port-input-index 'textual e-p)]) + (define-inline 3 binary-port-input-index + [(e-p) (build-port-input-index 'binary e-p)])) + (let () + (define (build-port-output-index port-type e-p) + (bind #t (e-p) + (translate + (%inline + + ,(%inline - + ,(%inline - + ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%mref ,e-p ,(constant port-obuffer-disp))) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,(%mref ,e-p ,(constant port-ocount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-output-index + [(e-p) (build-port-output-index 'textual e-p)]) + (define-inline 3 binary-port-output-index + [(e-p) (build-port-output-index 'binary e-p)])) + (let () + (define (build-port-input-count port-type e-p) + (bind #t (e-p) + (translate + (%inline - + (immediate 0) + ,(%mref ,e-p ,(constant port-icount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-input-count + [(e-p) (build-port-input-count 'textual e-p)]) + (define-inline 3 binary-port-input-count + [(e-p) (build-port-input-count 'binary e-p)])) + (let () + (define (build-port-output-count port-type e-p) + (bind #t (e-p) + (translate + (%inline - + (immediate 0) + ,(%mref ,e-p ,(constant port-ocount-disp))) + (if (eq? port-type 'textual) (constant string-char-offset) 0) + (constant fixnum-offset)))) + (define-inline 3 textual-port-output-count + [(e-p) (build-port-output-count 'textual e-p)]) + (define-inline 3 binary-port-output-count + [(e-p) (build-port-output-count 'binary e-p)])) + (let () + (define (build-set-port-input-size! port-type e-p e-x) + ; actually, set last to buffer[0] + size; count to size + (bind #t (e-p) + (bind #t ([e-x (translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0))]) + `(seq + (set! ,(%mref ,e-p ,(constant port-icount-disp)) + ,(%inline - (immediate 0) ,e-x)) + (set! ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%inline + + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,e-x)))))) + (define-inline 3 set-textual-port-input-size! + [(e-p e-x) (build-set-port-input-size! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-input-size! + [(e-p e-x) (build-set-port-input-size! 'binary e-p e-x)])) + (let () + (define (build-set-port-output-size! port-type e-p e-x) + ; actually, set last to buffer[0] + size; count to size + (bind #t (e-p) + (bind #t ([e-x (translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0))]) + `(seq + (set! ,(%mref ,e-p ,(constant port-ocount-disp)) + ,(%inline - (immediate 0) ,e-x)) + (set! ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%inline + + ,(%inline + + ,(%mref ,e-p ,(constant port-obuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))) + ,e-x)))))) + (define-inline 3 set-textual-port-output-size! + [(e-p e-x) (build-set-port-output-size! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-output-size! + [(e-p e-x) (build-set-port-output-size! 'binary e-p e-x)])) + (let () + (define (build-set-port-input-index! port-type e-p e-x) + ; actually, set count to index - size, where size = last - buffer[0] + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-icount-disp)) + ,(%inline - + ,(translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0)) + ,(%inline - + ,(%mref ,e-p ,(constant port-ilast-disp)) + ,(%inline + + ,(%mref ,e-p ,(constant port-ibuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp))))))))) + (define-inline 3 set-textual-port-input-index! + [(e-p e-x) (build-set-port-input-index! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-input-index! + [(e-p e-x) (build-set-port-input-index! 'binary e-p e-x)])) + (let () + (define (build-set-port-output-index! port-type e-p e-x) + ; actually, set count to index - size, where size = last - buffer[0] + (bind #t (e-p) + `(set! ,(%mref ,e-p ,(constant port-ocount-disp)) + ,(%inline - + ,(translate e-x + (constant fixnum-offset) + (if (eq? port-type 'textual) (constant string-char-offset) 0)) + ,(%inline - + ,(%mref ,e-p ,(constant port-olast-disp)) + ,(%inline + + ,(%mref ,e-p ,(constant port-obuffer-disp)) + (immediate + ,(if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp))))))))) + (define-inline 3 set-textual-port-output-index! + [(e-p e-x) (build-set-port-output-index! 'textual e-p e-x)]) + (define-inline 3 set-binary-port-output-index! + [(e-p e-x) (build-set-port-output-index! 'binary e-p e-x)])) + (let () + (define (make-build-set-port-buffer! port-type ibuffer-disp icount-disp ilast-disp) + (lambda (e-p e-b new?) + (bind #t (e-p e-b) + `(seq + ,(if new? + `(set! ,(%mref ,e-p ,ibuffer-disp) ,e-b) + (build-dirty-store e-p ibuffer-disp e-b)) + ,(bind #t ([e-length (if (eq? port-type 'textual) + (translate + (%inline logand + ,(%mref ,e-b ,(constant string-type-disp)) + (immediate ,(fx- (expt 2 (constant string-length-offset))))) + (constant string-length-offset) + (constant string-char-offset)) + (%inline srl + ,(%mref ,e-b ,(constant bytevector-type-disp)) + ,(%constant bytevector-length-offset)))]) + `(seq + (set! ,(%mref ,e-p ,icount-disp) + ,(%inline - (immediate 0) ,e-length)) + (set! ,(%mref ,e-p ,ilast-disp) + ,(%lea ,e-b ,e-length + (if (eq? port-type 'textual) + (constant string-data-disp) + (constant bytevector-data-disp)))))))))) + (define (make-port e-name e-handler e-ib e-ob e-info flags set-ibuf! set-obuf!) + (bind #f (e-name e-handler e-info e-ib e-ob) + (bind #t ([e-p (%constant-alloc type-typed-object (constant size-port))]) + (%seq + (set! ,(%mref ,e-p ,(constant port-type-disp)) (immediate ,flags)) + (set! ,(%mref ,e-p ,(constant port-handler-disp)) ,e-handler) + (set! ,(%mref ,e-p ,(constant port-name-disp)) ,e-name) + (set! ,(%mref ,e-p ,(constant port-info-disp)) ,e-info) + ,(set-ibuf! e-p e-ib #t) + ,(set-obuf! e-p e-ob #t) + ,e-p)))) + (define (make-build-clear-count count-disp) + (lambda (e-p e-b new?) + `(set! ,(%mref ,e-p ,count-disp) (immediate 0)))) + (let () + (define build-set-textual-port-input-buffer! + (make-build-set-port-buffer! 'textual + (constant port-ibuffer-disp) + (constant port-icount-disp) + (constant port-ilast-disp))) + (define build-set-textual-port-output-buffer! + (make-build-set-port-buffer! 'textual + (constant port-obuffer-disp) + (constant port-ocount-disp) + (constant port-olast-disp))) + (define-inline 3 set-textual-port-input-buffer! + [(e-p e-b) (build-set-textual-port-input-buffer! e-p e-b #f)]) + (define-inline 3 set-textual-port-output-buffer! + [(e-p e-b) (build-set-textual-port-output-buffer! e-p e-b #f)]) + (let () + (define (go e-name e-handler e-ib e-info) + (make-port e-name e-handler e-ib `(quote "") e-info + (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE)) + build-set-textual-port-input-buffer! + (make-build-clear-count (constant port-ocount-disp)))) + (define-inline 3 $make-textual-input-port + [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] + [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) + (let () + (define (go e-name e-handler e-ob e-info) + (make-port e-name e-handler `(quote "") e-ob e-info + (constant type-output-port) + (make-build-clear-count (constant port-icount-disp)) + build-set-textual-port-output-buffer!)) + (define-inline 3 $make-textual-output-port + [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] + [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) + (let () + (define (go e-name e-handler e-ib e-ob e-info) + (make-port e-name e-handler e-ib e-ob e-info + (constant type-io-port) + build-set-textual-port-input-buffer! + build-set-textual-port-output-buffer!)) + (define-inline 3 $make-textual-input/output-port + [(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))] + [(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)]))) + (let () + (define build-set-binary-port-input-buffer! + (make-build-set-port-buffer! 'binary + (constant port-ibuffer-disp) + (constant port-icount-disp) + (constant port-ilast-disp))) + (define build-set-binary-port-output-buffer! + (make-build-set-port-buffer! 'binary + (constant port-obuffer-disp) + (constant port-ocount-disp) + (constant port-olast-disp))) + (define-inline 3 set-binary-port-input-buffer! + [(e-p e-b) (build-set-binary-port-input-buffer! e-p e-b #f)]) + (define-inline 3 set-binary-port-output-buffer! + [(e-p e-b) (build-set-binary-port-output-buffer! e-p e-b #f)]) + (let () + (define (go e-name e-handler e-ib e-info) + (make-port e-name e-handler e-ib `(quote #vu8()) e-info + (fxlogor (constant type-input-port) (constant PORT-FLAG-INPUT-MODE) (constant PORT-FLAG-BINARY)) + build-set-binary-port-input-buffer! + (make-build-clear-count (constant port-ocount-disp)))) + (define-inline 3 $make-binary-input-port + [(e-name e-handler e-ib) (go e-name e-handler e-ib `(quote #f))] + [(e-name e-handler e-ib e-info) (go e-name e-handler e-ib e-info)])) + (let () + (define (go e-name e-handler e-ob e-info) + (make-port e-name e-handler `(quote #vu8()) e-ob e-info + (fxlogor (constant type-output-port) (constant PORT-FLAG-BINARY)) + (make-build-clear-count (constant port-icount-disp)) + build-set-binary-port-output-buffer!)) + (define-inline 3 $make-binary-output-port + [(e-name e-handler e-ob) (go e-name e-handler e-ob `(quote #f))] + [(e-name e-handler e-ob e-info) (go e-name e-handler e-ob e-info)])) + (let () + (define (go e-name e-handler e-ib e-ob e-info) + (make-port e-name e-handler e-ib e-ob e-info + (fxlogor (constant type-io-port) (constant PORT-FLAG-BINARY)) + build-set-binary-port-input-buffer! + build-set-binary-port-output-buffer!)) + (define-inline 3 $make-binary-input/output-port + [(e-name e-handler e-ib e-ob) (go e-name e-handler e-ib e-ob `(quote #f))] + [(e-name e-handler e-ib e-ob e-info) (go e-name e-handler e-ib e-ob e-info)])))) + (let () + (define build-fxvector-ref-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector never-immutable-flag)) + (define build-fxvector-set!-check (build-ref-check fxvector-type-disp maximum-fxvector-length fxvector-length-offset type-fxvector mask-fxvector never-immutable-flag)) + (define-inline 2 $fxvector-ref-check? + [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-ref-check e-fv e-i #f))]) + (define-inline 2 $fxvector-set!-check? + [(e-fv e-i) (bind #t (e-fv e-i) (build-fxvector-set!-check e-fv e-i #f))]) + (let () + (define (go e-fv e-i) + (cond + [(expr->index e-i 1 (constant maximum-fxvector-length)) => + (lambda (index) + (%mref ,e-fv + ,(+ (fix index) (constant fxvector-data-disp))))] + [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))])) + (define-inline 3 fxvector-ref + [(e-fv e-i) (go e-fv e-i)]) + (define-inline 2 fxvector-ref + [(e-fv e-i) + (bind #t (e-fv e-i) + `(if ,(build-fxvector-ref-check e-fv e-i #f) + ,(go e-fv e-i) + ,(build-libcall #t src sexpr fxvector-ref e-fv e-i)))])) + (let () + (define (go e-fv e-i e-new) + `(set! + ,(cond + [(expr->index e-i 1 (constant maximum-fxvector-length)) => + (lambda (index) + (%mref ,e-fv + ,(+ (fix index) (constant fxvector-data-disp))))] + [else (%mref ,e-fv ,e-i ,(constant fxvector-data-disp))]) + ,e-new)) + (define-inline 3 fxvector-set! + [(e-fv e-i e-new) + (go e-fv e-i e-new)]) + (define-inline 2 fxvector-set! + [(e-fv e-i e-new) + (bind #t (e-fv e-i e-new) + `(if ,(build-fxvector-set!-check e-fv e-i e-new) + ,(go e-fv e-i e-new) + ,(build-libcall #t src sexpr fxvector-set! e-fv e-i e-new)))]))) + (let () + (define build-flvector-ref-check (build-ref-check flvector-type-disp maximum-flvector-length flvector-length-offset type-flvector mask-flvector never-immutable-flag)) + (define build-flvector-set!-check (build-ref-check flvector-type-disp maximum-flvector-length flvector-length-offset type-flvector mask-flvector never-immutable-flag)) + (define-inline 2 $flvector-ref-check? + [(e-fv e-i) (bind #t (e-fv e-i) (build-flvector-ref-check e-fv e-i #f))]) + (define-inline 2 $flvector-set!-check? + [(e-fv e-i) (bind #t (e-fv e-i) (build-flvector-set!-check e-fv e-i #f))]) + (let () + (define (go e-fv e-i) + (cond + [(expr->index e-i 1 (constant maximum-flvector-length)) => + (lambda (index) + `(unboxed-fp ,(%mref ,e-fv ,%zero ,(+ (fx* index (constant flonum-bytes)) (constant flvector-data-disp)) fp)))] + [else `(unboxed-fp ,(%mref ,e-fv ,(build-double-scale e-i) ,(constant flvector-data-disp) fp))])) + (define-inline 3 flvector-ref + [(e-fv e-i) (go e-fv e-i)]) + (define-inline 2 flvector-ref + [(e-fv e-i) + (bind #t (e-fv e-i) + `(if ,(build-flvector-ref-check e-fv e-i #f) + ,(go e-fv e-i) + ,(build-libcall #t src sexpr flvector-ref e-fv e-i)))])) + (let () + (define (go e-fv e-i e-new) + `(set! + ,(cond + [(expr->index e-i 1 (constant maximum-flvector-length)) => + (lambda (index) + (%mref ,e-fv ,%zero ,(+ (fx* index (constant flonum-bytes)) (constant flvector-data-disp)) fp))] + [else (%mref ,e-fv ,(build-double-scale e-i) ,(constant flvector-data-disp) fp)]) + ,e-new)) + (define (checked-go src sexpr e-fv e-i e-new add-check) + `(if ,(add-check (build-flvector-set!-check e-fv e-i #f)) + ,(go e-fv e-i e-new) + ,(build-libcall #t src sexpr flvector-set! e-fv e-i e-new))) + (define-inline 3 flvector-set! + [(e-fv e-i e-new) + (go e-fv e-i e-new)]) + (define-inline 2 flvector-set! + [(e-fv e-i e-new) + (bind #t (e-fv e-i) + (if (known-flonum-result? e-new) + (bind #t fp (e-new) + (checked-go src sexpr e-fv e-i e-new values)) + (bind #t (e-new) + (checked-go src sexpr e-fv e-i e-new + (lambda (e) + (build-and e (build-flonums? (list e-new))))))))]))) + (let () + (define build-string-ref-check + (lambda (e-s e-i) + ((build-ref-check string-type-disp maximum-string-length string-length-offset type-string mask-string string-immutable-flag) e-s e-i #f))) + (define build-string-set!-check + (lambda (e-s e-i) + ((build-ref-check string-type-disp maximum-string-length string-length-offset type-mutable-string mask-mutable-string string-immutable-flag) e-s e-i #f))) + (define-inline 2 $string-ref-check? + [(e-s e-i) (bind #t (e-s e-i) (build-string-ref-check e-s e-i))]) + (define-inline 2 $string-set!-check? + [(e-s e-i) (bind #t (e-s e-i) (build-string-set!-check e-s e-i))]) + (let () + (define (go e-s e-i) + (cond + [(expr->index e-i 1 (constant maximum-string-length)) => + (lambda (index) + `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s ,%zero + (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp)))))] + [else + `(inline ,(make-info-load (string-char-type) #f) ,%load ,e-s + ,(translate e-i + (constant fixnum-offset) + (constant string-char-offset)) + ,(%constant string-data-disp))])) + (define-inline 3 string-ref + [(e-s e-i) (go e-s e-i)]) + (define-inline 2 string-ref + [(e-s e-i) + (bind #t (e-s e-i) + `(if ,(build-string-ref-check e-s e-i) + ,(go e-s e-i) + ,(build-libcall #t src sexpr string-ref e-s e-i)))])) + (let () + (define (go e-s e-i e-new) + (cond + [(expr->index e-i 1 (constant maximum-string-length)) => + (lambda (index) + `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s ,%zero + (immediate ,(+ (* (constant string-char-bytes) index) (constant string-data-disp))) + ,e-new))] + [else + `(inline ,(make-info-load (string-char-type) #f) ,%store ,e-s + ,(translate e-i + (constant fixnum-offset) + (constant string-char-offset)) + ,(%constant string-data-disp) + ,e-new)])) + (define-inline 3 string-set! + [(e-s e-i e-new) (go e-s e-i e-new)]) + (define-inline 2 string-set! + [(e-s e-i e-new) + (bind #t (e-s e-i e-new) + `(if ,(let ([e-ref-check (build-string-set!-check e-s e-i)]) + (if (constant? char? e-new) + e-ref-check + (build-and e-ref-check (%type-check mask-char type-char ,e-new)))) + ,(go e-s e-i e-new) + ,(build-libcall #t src sexpr string-set! e-s e-i e-new)))]) + (define-inline 3 $string-set-immutable! + [(e-s) ((build-set-immutable! string-type-disp string-immutable-flag) e-s)]))) + (let () + (define build-vector-ref-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-vector mask-vector vector-immutable-flag)) + (define build-vector-set!-check (build-ref-check vector-type-disp maximum-vector-length vector-length-offset type-mutable-vector mask-mutable-vector vector-immutable-flag)) + (define-inline 2 $vector-ref-check? + [(e-v e-i) (bind #t (e-v e-i) (build-vector-ref-check e-v e-i #f))]) + (define-inline 2 $vector-set!-check? + [(e-v e-i) (bind #t (e-v e-i) (build-vector-set!-check e-v e-i #f))]) + (let () + (define (go e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant vector-data-disp))])) + (define-inline 3 vector-ref + [(e-v e-i) (go e-v e-i)]) + (define-inline 2 vector-ref + [(e-v e-i) + (bind #t (e-v e-i) + `(if ,(build-vector-ref-check e-v e-i #f) + ,(go e-v e-i) + ,(build-libcall #t src sexpr vector-ref e-v e-i)))])) + (let () + (define (go e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant vector-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new)])) + (define-inline 3 vector-set! + [(e-v e-i e-new) (go e-v e-i e-new)]) + (define-inline 2 vector-set! + [(e-v e-i e-new) + (bind #t (e-v e-i) + (dirty-store-bind #t (e-new) + `(if ,(build-vector-set!-check e-v e-i #f) + ,(go e-v e-i e-new) + ,(build-libcall #t src sexpr vector-set! e-v e-i e-new))))]) + (define-inline 3 $vector-set-immutable! + [(e-fv) ((build-set-immutable! vector-type-disp vector-immutable-flag) e-fv)])) + (let () + (define (go e-v e-i e-old e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v %zero (+ (fix d) (constant vector-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] + [else (build-dirty-store e-v e-i (constant vector-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) + (define-inline 3 vector-cas! + [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)]) + (define-inline 2 vector-cas! + [(e-v e-i e-old e-new) + (bind #t (e-v e-i e-old) + (dirty-store-bind #t (e-new) + `(if ,(build-vector-set!-check e-v e-i #f) + ,(go e-v e-i e-old e-new) + ,(build-libcall #t src sexpr vector-cas! e-v e-i e-old e-new))))])) + (let () + (define (go e-v e-i e-new) + `(set! + ,(nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant vector-data-disp))]) + ,e-new)) + (define-inline 3 vector-set-fixnum! + [(e-v e-i e-new) (go e-v e-i e-new)]) + (define-inline 2 vector-set-fixnum! + [(e-v e-i e-new) + (bind #t (e-v e-i e-new) + `(if ,(build-vector-set!-check e-v e-i e-new) + ,(go e-v e-i e-new) + ,(build-libcall #t src sexpr vector-set-fixnum! e-v e-i e-new)))]))) + (let () + (define (go e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))])) + (define-inline 3 stencil-vector-ref + [(e-v e-i) (go e-v e-i)])) + (let () + (define (go e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant stencil-vector-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant stencil-vector-data-disp) e-new)])) + (define-inline 3 stencil-vector-set! + [(e-v e-i e-new) (go e-v e-i e-new)])) + (let () + (define (go e-v e-i e-new) + `(set! + ,(nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant stencil-vector-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant stencil-vector-data-disp))]) + ,e-new)) + (define-inline 3 $stencil-vector-set! + [(e-v e-i e-new) (go e-v e-i e-new)])) + (let () + (define (go e-v e-i) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (%mref ,e-v ,(+ (fix d) (constant record-data-disp)))] + [else (%mref ,e-v ,e-i ,(constant record-data-disp))])) + (define-inline 3 $record-ref + [(e-v e-i) (go e-v e-i)])) + (let () + (define (go e-v e-i e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v (+ (fix d) (constant record-data-disp)) e-new)] + [else (build-dirty-store e-v e-i (constant record-data-disp) e-new)])) + (define-inline 3 $record-set! + [(e-v e-i e-new) (go e-v e-i e-new)])) + (let () + (define (go e-v e-i e-old e-new) + (nanopass-case (L7 Expr) e-i + [(quote ,d) + (guard (target-fixnum? d)) + (build-dirty-store e-v %zero (+ (fix d) (constant record-data-disp)) e-new (make-build-cas e-old) build-cas-seq)] + [else (build-dirty-store e-v e-i (constant record-data-disp) e-new (make-build-cas e-old) build-cas-seq)])) + (define-inline 3 $record-cas! + [(e-v e-i e-old e-new) (go e-v e-i e-old e-new)])) + (let () + (define build-bytevector-ref-check + (lambda (e-bits e-bv e-i check-mutable?) + (nanopass-case (L7 Expr) e-bits + [(quote ,d) + (guard (and (fixnum? d) (fx> d 0) (fx= (* (fxquotient d 8) 8) d))) + (let ([bits d] [bytes (fxquotient d 8)]) + (bind #t (e-bv e-i) + (build-and + (%type-check mask-typed-object type-typed-object ,e-bv) + (bind #t ([t (%mref ,e-bv ,(constant bytevector-type-disp))]) + (build-and + (if check-mutable? + (%type-check mask-mutable-bytevector type-mutable-bytevector ,t) + (%type-check mask-bytevector type-bytevector ,t)) + (cond + [(expr->index e-i bytes (constant maximum-bytevector-length)) => + (lambda (index) + (%inline u< + (immediate ,(logor (ash (+ index (fx- bytes 1)) (constant bytevector-length-offset)) + (constant type-bytevector) (constant bytevector-immutable-flag))) + ,t))] + [else + (build-and + ($type-check (fxlogor (fix (fx- bytes 1)) (constant mask-fixnum)) (constant type-fixnum) e-i) + (%inline u< + ; NB. add cannot overflow or change negative to positive when + ; low-order (log2 bytes) bits of fixnum value are zero, as + ; guaranteed by type-check above + ,(if (fx= bytes 1) + e-i + (%inline + ,e-i (immediate ,(fix (fx- bytes 1))))) + ,(%inline logand + ,(translate t + (constant bytevector-length-offset) + (constant fixnum-offset)) + (immediate ,(- (constant fixnum-factor))))))]))))))] + [(seq (profile ,src) ,[e]) (and e `(seq (profile ,src) ,e))] + [else #f]))) + (define-inline 2 $bytevector-ref-check? + [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #f)]) + (define-inline 2 $bytevector-set!-check? + [(e-bits e-bv e-i) (build-bytevector-ref-check e-bits e-bv e-i #t)])) + (let () + (define build-bytevector-fill + (let ([filler (make-build-fill 1 (constant bytevector-data-disp))]) + (lambda (e-bv e-bytes e-fill) + (bind #t uptr ([e-fill (build-unfix e-fill)]) + (filler e-bv e-bytes e-fill))))) + (let () + (define do-make-bytevector + (lambda (e-length maybe-e-fill) + ; NB: caller must bind maybe-e-fill + (safe-assert (or (not maybe-e-fill) (no-need-to-bind? #f maybe-e-fill))) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(bytevector)) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-bytevector) n))]) + `(seq + (set! ,(%mref ,t ,(constant bytevector-type-disp)) + (immediate ,(fx+ (fx* n (constant bytevector-length-factor)) + (constant type-bytevector)))) + ,(if maybe-e-fill + (build-bytevector-fill t `(immediate ,n) maybe-e-fill) + t))))) + (bind #t (e-length) + (let ([t-bytes (make-tmp 'tbytes 'uptr)] [t-vec (make-tmp 'tvec)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(bytevector)) + (let ([,t-bytes ,(build-unfix e-length)]) + (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,t-bytes + (immediate ,(fx+ (constant header-size-bytevector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-vec ,(constant bytevector-type-disp)) + ,(build-type/length t-bytes + (constant type-bytevector) + 0 + (constant bytevector-length-offset))) + ,(if maybe-e-fill + (build-bytevector-fill t-vec t-bytes maybe-e-fill) + t-vec)))))))))) + (let () + (define valid-length? + (lambda (e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-bytevector-length)))) + e-length))) + (define-inline 2 make-bytevector + [(e-length) (and (valid-length? e-length) (do-make-bytevector e-length #f))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) e-fill) + (do-make-bytevector e-length e-fill))])) + (define-inline 3 make-bytevector + [(e-length) (do-make-bytevector e-length #f)] + [(e-length e-fill) (bind #f (e-fill) (do-make-bytevector e-length e-fill))])) + (define-inline 3 bytevector-fill! + [(e-bv e-fill) + (bind #t (e-bv e-fill) + `(seq + ,(build-bytevector-fill e-bv + (%inline srl + ,(%mref ,e-bv ,(constant bytevector-type-disp)) + ,(%constant bytevector-length-offset)) + e-fill) + ,(%constant svoid)))]) + (define-inline 2 bytevector->immutable-bytevector + [(e-bv) + (nanopass-case (L7 Expr) e-bv + [(quote ,d) + (guard (bytevector? d) (= 0 (bytevector-length d))) + `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-bytevector) 0))] + [else #f])])) + + (let () + (define build-bytevector + (lambda (e*) + (define (find-k n) + (constant-case native-endianness + [(unknown) + (values 1 'unsigned-8)] + [else + (let loop ([bytes (constant-case ptr-bits [(32) 4] [(64) 8])] + [type* (constant-case ptr-bits + [(32) '(unsigned-32 unsigned-16 unsigned-8)] + [(64) '(unsigned-64 unsigned-32 unsigned-16 unsigned-8)])]) + (let ([bytes/2 (fxsrl bytes 1)]) + (if (fx<= n bytes/2) + (loop bytes/2 (cdr type*)) + (values bytes (car type*)))))])) + (define (build-chunk k n e*) + (define (build-shift e shift) + (if (fx= shift 0) e (%inline sll ,e (immediate ,shift)))) + (let loop ([k (constant-case native-endianness + [(little) (fxmin k n)] + [(big) k] + [(unknown) (safe-assert (= k 1)) 1])] + [e* (constant-case native-endianness + [(little) (reverse (if (fx<= n k) e* (list-head e* k)))] + [(big) e*] + [(unknown) e*])] + [constant-part 0] + [expression-part #f] + [expression-shift 0] + [mask? #f]) ; no need to mask the high-order byte + (if (fx= k 0) + (if expression-part + (let ([expression-part (build-shift expression-part expression-shift)]) + (if (= constant-part 0) + expression-part + (%inline logor ,expression-part (immediate ,constant-part)))) + `(immediate ,constant-part)) + (let ([k (fx- k 1)] + [constant-part (ash constant-part 8)] + [expression-shift (fx+ expression-shift 8)]) + (if (null? e*) + (loop k e* constant-part expression-part expression-shift #t) + (let ([e (car e*)] [e* (cdr e*)]) + (if (fixnum-constant? e) + (loop k e* (logor constant-part (logand (constant-value e) #xff)) expression-part expression-shift #t) + (loop k e* constant-part + (let* ([e (build-unfix e)] + [e (if mask? (%inline logand ,e (immediate #xff)) e)]) + (if expression-part + (%inline logor ,(build-shift expression-part expression-shift) ,e) + e)) + 0 #t)))))))) + (let ([len (length e*)]) + (if (fx= len 0) + `(quote ,(bytevector)) + (list-bind #f (e*) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-bytevector) len))]) + `(seq + (set! ,(%mref ,t ,(constant bytevector-type-disp)) + (immediate ,(+ (* len (constant bytevector-length-factor)) + (constant type-bytevector)))) + ; build and store k-octet (k = 4 on 32-bit machines, k = 8 on 64-bit + ; machines) chunks, taking endianness into account. for the last + ; chunk, set k = 1, 2, 4, or 8 depending on the number of octets + ; remaining, padding with zeros as necessary. + ,(let f ([e* e*] [n (length e*)] [offset (constant bytevector-data-disp)]) + (let-values ([(k type) (find-k n)]) + `(seq + (inline ,(make-info-load type #f) ,%store ,t ,%zero (immediate ,offset) + ,(build-chunk k n e*)) + ,(if (fx<= n k) + t + (f (list-tail e* k) (fx- n k) (fx+ offset k))))))))))))) + + (define-inline 2 bytevector + [e* (and (andmap + (lambda (x) + (constant? + (lambda (x) (and (fixnum? x) (fx<= -128 x 255))) + x)) + e*) + (build-bytevector e*))]) + + (define-inline 3 bytevector + [e* (build-bytevector e*)])) + + (let () + (define byte-offset + (lambda (off) + (cond + [(nanopass-case (L7 Expr) off + [(quote ,d) + (and (and (integer? d) (exact? d)) + (let ([n (+ d (constant bytevector-data-disp))]) + (and (target-fixnum? n) + `(quote ,n))))] + [else #f])] + [else (%inline + ,off + (quote ,(constant bytevector-data-disp)))]))) + + (define-inline 3 bytevector-copy! + [(bv1 off1 bv2 off2 n) + (%primcall src sexpr $byte-copy! ,bv1 ,(byte-offset off1) ,bv2 ,(byte-offset off2) ,n)])) + + (define-inline 3 bytevector-truncate! + [(bv len) + (if (fixnum-constant? len) + (let ([len (constant-value len)]) + (if (fx= len 0) + `(quote ,(bytevector)) + (bind #t (bv) + `(seq + (set! ,(%mref ,bv ,(constant bytevector-type-disp)) + (immediate ,(fx+ (fx* len (constant bytevector-length-factor)) + (constant type-bytevector)))) + ,bv)))) + (bind #t (bv len) + `(if ,(%inline eq? ,len (immediate 0)) + (quote ,(bytevector)) + (seq + (set! ,(%mref ,bv ,(constant bytevector-type-disp)) + ,(build-type/length len + (constant type-bytevector) + (constant fixnum-offset) + (constant bytevector-length-offset))) + ,bv))))]) + + (define-inline 3 $bytevector-set-immutable! + [(bv) ((build-set-immutable! bytevector-type-disp bytevector-immutable-flag) bv)]) + + (let () + (define bv-index-offset + (lambda (offset-expr) + (if (fixnum-constant? offset-expr) + (values %zero (+ (constant bytevector-data-disp) (constant-value offset-expr))) + (values (build-unfix offset-expr) (constant bytevector-data-disp))))) + + (define bv-offset-okay? + (lambda (x mask) + (constant? (lambda (x) (and (target-fixnum? x) (>= x 0) (eq? (logand x mask) 0))) x))) + + (let () + (define-syntax define-bv-8-inline + (syntax-rules () + [(_ name type) + (define-inline 2 name + [(e-bv e-offset) + (bind #t (e-bv e-offset) + `(if ,(handle-prim #f #f 3 '$bytevector-ref-check? (list `(quote 8) e-bv e-offset)) + ,(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref #f 'type e-bv e-index imm-offset)) + ,(build-libcall #t src sexpr name e-bv e-offset)))])])) + + (define-bv-8-inline bytevector-s8-ref integer-8) + (define-bv-8-inline bytevector-u8-ref unsigned-8)) + + (let () + (define-syntax define-bv-native-ref-inline + (lambda (x) + (syntax-case x () + [(_ name type) + #'(define-inline 3 name + [(e-bv e-offset) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref #f 'type e-bv e-index imm-offset))])]))) + + (define-bv-native-ref-inline bytevector-s8-ref integer-8) + (define-bv-native-ref-inline bytevector-u8-ref unsigned-8) + + (define-bv-native-ref-inline bytevector-s16-native-ref integer-16) + (define-bv-native-ref-inline bytevector-u16-native-ref unsigned-16) + + (define-bv-native-ref-inline bytevector-s32-native-ref integer-32) + (define-bv-native-ref-inline bytevector-u32-native-ref unsigned-32) + + (define-bv-native-ref-inline bytevector-s64-native-ref integer-64) + (define-bv-native-ref-inline bytevector-u64-native-ref unsigned-64) + + (define-bv-native-ref-inline bytevector-ieee-single-native-ref single-float) + (define-bv-native-ref-inline bytevector-ieee-double-native-ref double-float) + + ;; Inline to enable unboxing: + (define-inline 2 bytevector-ieee-double-native-ref + [(e-bv e-offset) + (bind #t (e-bv e-offset) + (let ([info (make-info-call #f #f #f #f #f)]) + `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-ref-check?) (quote 64) ,e-bv ,e-offset) + (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-ref) ,e-bv ,e-offset) + ,(build-libcall #t src sexpr bytevector-ieee-double-native-ref e-bv e-offset))))])) + + (let () + (define-syntax define-bv-native-int-set!-inline + (lambda (x) + (syntax-case x () + [(_ check-64? name type) + (with-syntax ([body #'(let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-set! 'type e-bv e-index imm-offset e-val))]) + (with-syntax ([body (if (datum check-64?) + #'(and (>= (constant ptr-bits) 64) body) + #'body)]) + #'(define-inline 3 name + [(e-bv e-offset e-val) body])))]))) + + (define-bv-native-int-set!-inline #f bytevector-s8-set! integer-8) + (define-bv-native-int-set!-inline #f bytevector-u8-set! unsigned-8) + (define-bv-native-int-set!-inline #f $bytevector-set! unsigned-8) + + (define-bv-native-int-set!-inline #f bytevector-s16-native-set! integer-16) + (define-bv-native-int-set!-inline #f bytevector-u16-native-set! unsigned-16) + + (define-bv-native-int-set!-inline #f bytevector-s32-native-set! integer-32) + (define-bv-native-int-set!-inline #f bytevector-u32-native-set! unsigned-32) + + (define-bv-native-int-set!-inline #t bytevector-s64-native-set! integer-64) + (define-bv-native-int-set!-inline #t bytevector-u64-native-set! unsigned-64)) + + (let () + (define-syntax define-bv-native-ieee-set!-inline + (lambda (x) + (syntax-case x () + [(_ name type) + #'(define-inline 3 name + [(e-bv e-offset e-val) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (bind #f (e-bv e-index) + (build-object-set! 'type e-bv e-index imm-offset + (build-$real->flonum src sexpr e-val `(quote name)))))])]))) + + (define-bv-native-ieee-set!-inline bytevector-ieee-single-native-set! single-float) + (define-bv-native-ieee-set!-inline bytevector-ieee-double-native-set! double-float) + + ;; Inline to enable unboxing: + (define-inline 2 bytevector-ieee-double-native-set! + [(e-bv e-offset e-val) + (bind #t (e-bv e-offset) + (let ([info (make-info-call #f #f #f #f #f)]) + `(if (call ,info ,#f ,(lookup-primref 3 '$bytevector-set!-check?) (quote 64) ,e-bv ,e-offset) + ;; checks to make sure e-val produces a real number: + (call ,info ,#f ,(lookup-primref 3 'bytevector-ieee-double-native-set!) ,e-bv ,e-offset ,e-val) + ,(build-libcall #t src sexpr bytevector-ieee-double-native-set! e-bv e-offset))))])) + + (let () + (define-syntax define-bv-int-ref-inline + (lambda (x) + (define p2? + (lambda (n) + (let f ([i 1]) + (or (fx= i n) + (and (not (fx> i n)) (f (fxsll i 1))))))) + (syntax-case x () + [(_ name type mask) + #`(define-inline 3 name + [(e-bv e-offset e-eness) + (and (or (constant unaligned-integers) + (and #,(p2? (fx+ (datum mask) 1)) (bv-offset-okay? e-offset mask))) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) + 'type e-bv e-index imm-offset)))])]))) + + (define-bv-int-ref-inline bytevector-s16-ref integer-16 1) + (define-bv-int-ref-inline bytevector-u16-ref unsigned-16 1) + + (when-known-endianness + (define-bv-int-ref-inline bytevector-s24-ref integer-24 1) + (define-bv-int-ref-inline bytevector-u24-ref unsigned-24 1)) + + (define-bv-int-ref-inline bytevector-s32-ref integer-32 3) + (define-bv-int-ref-inline bytevector-u32-ref unsigned-32 3) + + (when-known-endianness + (define-bv-int-ref-inline bytevector-s40-ref integer-40 3) + (define-bv-int-ref-inline bytevector-u40-ref unsigned-40 3) + + (define-bv-int-ref-inline bytevector-s48-ref integer-48 3) + (define-bv-int-ref-inline bytevector-u48-ref unsigned-48 3) + + (define-bv-int-ref-inline bytevector-s56-ref integer-56 7) + (define-bv-int-ref-inline bytevector-u56-ref unsigned-56 7)) + + (define-bv-int-ref-inline bytevector-s64-ref integer-64 7) + (define-bv-int-ref-inline bytevector-u64-ref unsigned-64 7)) + + (let () + (define-syntax define-bv-ieee-ref-inline + (lambda (x) + (syntax-case x () + [(_ name type mask) + #'(define-inline 3 name + [(e-bv e-offset e-eness) + (and (or (constant unaligned-floats) + (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref #f 'type e-bv e-index imm-offset)))])]))) + + (define-bv-ieee-ref-inline bytevector-ieee-single-ref single-float 3) + (define-bv-ieee-ref-inline bytevector-ieee-double-ref double-float 7)) + + (let () + (define-syntax define-bv-int-set!-inline + (lambda (x) + (syntax-case x () + [(_ check-64? name type mask) + (with-syntax ([body #'(and (or (constant unaligned-integers) + (and mask (bv-offset-okay? e-offset mask))) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (if (eq? (constant-value e-eness) (constant native-endianness)) + (build-object-set! 'type e-bv e-index imm-offset e-value) + (build-swap-object-set! 'type e-bv e-index imm-offset e-value))))]) + (with-syntax ([body (if (datum check-64?) + #'(and (>= (constant ptr-bits) 64) body) + #'body)]) + #'(define-inline 3 name + [(e-bv e-offset e-value e-eness) body])))]))) + + (define-bv-int-set!-inline #f bytevector-s16-set! integer-16 1) + (define-bv-int-set!-inline #f bytevector-u16-set! unsigned-16 1) + + (define-bv-int-set!-inline #f bytevector-s24-set! integer-24 #f) + (define-bv-int-set!-inline #f bytevector-u24-set! unsigned-24 #f) + + (define-bv-int-set!-inline #f bytevector-s32-set! integer-32 3) + (define-bv-int-set!-inline #f bytevector-u32-set! unsigned-32 3) + + (define-bv-int-set!-inline #t bytevector-s40-set! integer-40 #f) + (define-bv-int-set!-inline #t bytevector-u40-set! unsigned-40 #f) + + (define-bv-int-set!-inline #t bytevector-s48-set! integer-48 #f) + (define-bv-int-set!-inline #t bytevector-u48-set! unsigned-48 #f) + + (define-bv-int-set!-inline #t bytevector-s56-set! integer-56 #f) + (define-bv-int-set!-inline #t bytevector-u56-set! unsigned-56 #f) + + (define-bv-int-set!-inline #t bytevector-s64-set! integer-64 7) + (define-bv-int-set!-inline #t bytevector-u64-set! unsigned-64 7)) + + (let () + (define-syntax define-bv-ieee-set!-inline + (lambda (x) + (syntax-case x () + [(_ name type mask) + #'(define-inline 3 name + [(e-bv e-offset e-value e-eness) + (and (or (constant unaligned-floats) (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (bind #f (e-bv e-index) + (build-object-set! 'type e-bv e-index imm-offset + (build-$real->flonum src sexpr e-value + `(quote name))))))])]))) + + (define-bv-ieee-set!-inline bytevector-ieee-single-set! single-float 3) + (define-bv-ieee-set!-inline bytevector-ieee-double-set! double-float 7)) + + (let () + (define anyint-ref-helper + (lambda (type mask e-bv e-offset e-eness) + (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) + type e-bv e-index imm-offset))))) + (define-syntax define-bv-anyint-ref-inline + (syntax-rules () + [(_ name type8 type16 type32 type64) + (define-inline 3 name + [(e-bv e-offset e-eness e-size) + (and (fixnum-constant? e-size) + (case (constant-value e-size) + [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + `(seq + ,e-eness + ,(build-object-ref #f 'type8 e-bv e-index imm-offset)))] + [(2) (anyint-ref-helper 'type16 #b1 e-bv e-offset e-eness)] + [(4) (anyint-ref-helper 'type32 #b11 e-bv e-offset e-eness)] + [(8) (anyint-ref-helper 'type64 #b111 e-bv e-offset e-eness)] + [else #f]))])])) + + (define-bv-anyint-ref-inline bytevector-sint-ref + integer-8 integer-16 integer-32 integer-64) + (define-bv-anyint-ref-inline bytevector-uint-ref + unsigned-8 unsigned-16 unsigned-32 unsigned-64)) + + (let () + (define anyint-set!-helper + (lambda (type mask e-bv e-offset e-value e-eness) + (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) + (constant? (lambda (x) (memq x '(big little))) e-eness) + (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + (if (eq? (constant-value e-eness) (constant native-endianness)) + (build-object-set! type e-bv e-index imm-offset e-value) + (build-swap-object-set! type e-bv e-index imm-offset e-value)))))) + (define-syntax define-bv-anyint-set!-inline + (syntax-rules () + [(_ name type8 type16 type32 type64) + (define-inline 3 name + [(e-bv e-offset e-value e-eness e-size) + (and (fixnum-constant? e-size) + (case (constant-value e-size) + [(1) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) + `(seq + ,e-eness + ,(build-object-set! 'type8 e-bv e-index imm-offset e-value)))] + [(2) (anyint-set!-helper 'type16 1 e-bv e-offset e-value e-eness)] + [(4) (anyint-set!-helper 'type32 3 e-bv e-offset e-value e-eness)] + [(8) (and (>= (constant ptr-bits) 64) + (anyint-set!-helper 'type64 7 e-bv e-offset e-value e-eness))] + [else #f]))])])) + + (define-bv-anyint-set!-inline bytevector-sint-set! + integer-8 integer-16 integer-32 integer-64) + (define-bv-anyint-set!-inline bytevector-uint-set! + unsigned-8 unsigned-16 unsigned-32 unsigned-64))) + + (let () + (define (byte-count e-n) + (or (nanopass-case (L7 Expr) e-n + [(quote ,d) + (and (and (integer? d) (exact? d)) + (let ([n (* d (constant string-char-bytes))]) + (and (target-fixnum? n) + `(immediate ,(fix n)))))] + [else #f]) + (%inline sll ,e-n ,(%constant string-char-offset)))) + (define byte-offset + (lambda (e-off) + (or (nanopass-case (L7 Expr) e-off + [(quote ,d) + (and (and (integer? d) (exact? d)) + (let ([n (+ (* d (constant string-char-bytes)) + (constant string-data-disp))]) + (and (target-fixnum? n) + `(immediate ,(fix n)))))] + [else #f]) + (%inline + + ,(%inline sll ,e-off ,(%constant string-char-offset)) + (immediate ,(fix (constant string-data-disp))))))) + (define-inline 3 string-copy! + [(e-bv1 e-off1 e-bv2 e-off2 e-n) + (%primcall src sexpr $byte-copy! ,e-bv1 ,(byte-offset e-off1) ,e-bv2 ,(byte-offset e-off2) ,(byte-count e-n))])) + + (define-inline 3 string-truncate! + [(e-str e-len) + (if (fixnum-constant? e-len) + (let ([len (constant-value e-len)]) + (if (fx= len 0) + `(quote ,(string)) + (bind #t (e-str) + `(seq + (set! ,(%mref ,e-str ,(constant string-type-disp)) + (immediate ,(fx+ (fx* len (constant string-length-factor)) + (constant type-string)))) + ,e-str)))) + (bind #t (e-str e-len) + `(if ,(%inline eq? ,e-len (immediate 0)) + (quote ,(string)) + (seq + (set! ,(%mref ,e-str ,(constant string-type-disp)) + ,(build-type/length e-len + (constant type-string) + (constant fixnum-offset) + (constant string-length-offset))) + ,e-str))))]) + + (let () + (define build-string-fill + (make-build-fill (constant string-char-bytes) (constant string-data-disp))) + (let () + (define do-make-string + (lambda (e-length e-fill) + ; NB: caller must bind e-fill + (safe-assert (no-need-to-bind? #f e-fill)) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(string)) + (let ([bytes (fx* n (constant string-char-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-string) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant string-type-disp)) + (immediate ,(fx+ (fx* n (constant string-length-factor)) + (constant type-string)))) + ,(build-string-fill t `(immediate ,bytes) e-fill)))))) + (bind #t (e-length) + (let ([t-bytes (make-tmp 'tsize 'uptr)] [t-str (make-tmp 'tstr)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(string)) + (let ([,t-bytes ,(translate e-length + (constant fixnum-offset) + (constant string-char-offset))]) + (let ([,t-str (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,t-bytes + (immediate ,(fx+ (constant header-size-string) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-str ,(constant string-type-disp)) + ,(build-type/length t-bytes + (constant type-string) + (constant string-char-offset) + (constant string-length-offset))) + ,(build-string-fill t-str t-bytes e-fill)))))))))) + (define default-fill `(immediate ,(ptr->imm #\nul))) + (define-inline 3 make-string + [(e-length) (do-make-string e-length default-fill)] + [(e-length e-fill) (bind #t (e-fill) (do-make-string e-length e-fill))]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-string-length)))) + e-length)) + (define-inline 2 make-string + [(e-length) + (and (valid-length? e-length) + (do-make-string e-length default-fill))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? char? e-fill) + (do-make-string e-length e-fill))]))) + (define-inline 3 string-fill! + [(e-str e-fill) + `(seq + ,(bind #t (e-str e-fill) + (build-string-fill e-str + (translate + (%inline logxor + ,(%mref ,e-str ,(constant string-type-disp)) + ,(%constant type-string)) + (constant string-length-offset) + (constant string-char-offset)) + e-fill)) + ,(%constant svoid))]) + (define-inline 2 string->immutable-string + [(e-str) + (nanopass-case (L7 Expr) e-str + [(quote ,d) + (guard (string? d) (= 0 (string-length d))) + `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-string) 0))] + [else #f])])) + + (let () + (define build-fxvector-fill + (make-build-fill (constant ptr-bytes) (constant fxvector-data-disp))) + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (let () + (define do-make-fxvector + (lambda (e-length e-fill) + ; NB: caller must bind e-fill + (safe-assert (no-need-to-bind? #f e-fill)) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(fxvector)) + (let ([bytes (fx* n (constant ptr-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-fxvector) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant fxvector-type-disp)) + (immediate ,(fx+ (fx* n (constant fxvector-length-factor)) + (constant type-fxvector)))) + ,(build-fxvector-fill t `(immediate ,bytes) e-fill)))))) + (bind #t (e-length) ; fixnum length doubles as byte count + (let ([t-fxv (make-tmp 'tfxv)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(fxvector)) + (let ([,t-fxv (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,e-length + (immediate ,(fx+ (constant header-size-fxvector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-fxv ,(constant fxvector-type-disp)) + ,(build-type/length e-length + (constant type-fxvector) + (constant fixnum-offset) + (constant fxvector-length-offset))) + ,(build-fxvector-fill t-fxv e-length e-fill))))))))) + (define default-fill `(immediate ,(fix 0))) + (define-inline 3 make-fxvector + [(e-length) (do-make-fxvector e-length default-fill)] + [(e-length e-fill) (bind #t (e-fill) (do-make-fxvector e-length e-fill))]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-fxvector-length)))) + e-length)) + (define-inline 2 make-fxvector + [(e-length) + (and (valid-length? e-length) + (do-make-fxvector e-length default-fill))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? fixnum? e-fill) + (do-make-fxvector e-length e-fill))]))) + (define-inline 3 fxvector-fill! + [(e-fxv e-fill) + `(seq + ,(bind #t (e-fxv e-fill) + (build-fxvector-fill e-fxv + (translate + (%inline logxor + ,(%mref ,e-fxv ,(constant fxvector-type-disp)) + ,(%constant type-fxvector)) + (constant fxvector-length-offset) + (constant fixnum-offset)) + e-fill)) + ,(%constant svoid))])) + + (let () + ;; Used only to fill with 0s: + (define build-flvector-fill + (make-build-fill (constant ptr-bytes) (constant flvector-data-disp))) + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (let () + (define do-make-flvector + (lambda (e-length) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(flvector)) + (let ([bytes (fx* n (constant flonum-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-flvector) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant flvector-type-disp)) + (immediate ,(fx+ (fx* n (constant flvector-length-factor)) + (constant type-flvector)))) + ,(build-flvector-fill t `(immediate ,bytes) `(immediate 0))))))) + (bind #t (e-length) ; fixnum length doubles as byte count + (let ([t-fxv (make-tmp 'tfxv)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(flvector)) + (let ([,t-fxv (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,(build-double-scale e-length) + (immediate ,(fx+ (constant header-size-flvector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-fxv ,(constant flvector-type-disp)) + ,(build-type/length e-length + (constant type-flvector) + (constant fixnum-offset) + (constant flvector-length-offset))) + ,(build-flvector-fill t-fxv (build-double-scale e-length) `(immediate 0)))))))))) + (define-inline 3 make-flvector + [(e-length) (do-make-flvector e-length)] + [(e-length e-init) #f]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= 0 x (constant maximum-flvector-length)))) + e-length)) + (define-inline 2 make-flvector + [(e-length) + (and (valid-length? e-length) + (do-make-flvector e-length))] + [(e-length e-init) #f])))) + + (let () + (define build-vector-fill + (make-build-fill (constant ptr-bytes) (constant vector-data-disp))) + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (let () + (define do-make-vector + (lambda (e-length e-fill) + ; NB: caller must bind e-fill + (safe-assert (no-need-to-bind? #f e-fill)) + (if (constant? (lambda (x) (and (fixnum? x) (fx<= 0 x 10000))) e-length) + (let ([n (constant-value e-length)]) + (if (fx= n 0) + `(quote ,(vector)) + (let ([bytes (fx* n (constant ptr-bytes))]) + (bind #t ([t (%constant-alloc type-typed-object + (fx+ (constant header-size-vector) bytes))]) + `(seq + (set! ,(%mref ,t ,(constant vector-type-disp)) + (immediate ,(+ (fx* n (constant vector-length-factor)) + (constant type-vector)))) + ,(build-vector-fill t `(immediate ,bytes) e-fill)))))) + (bind #t (e-length) ; fixnum length doubles as byte count + (let ([t-vec (make-tmp 'tvec)]) + `(if ,(%inline eq? ,e-length (immediate 0)) + (quote ,(vector)) + (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,e-length + (immediate ,(fx+ (constant header-size-vector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-vec ,(constant vector-type-disp)) + ,(build-type/length e-length + (constant type-vector) + (constant fixnum-offset) + (constant vector-length-offset))) + ,(build-vector-fill t-vec e-length e-fill))))))))) + (define default-fill `(immediate ,(fix 0))) + (define-inline 3 make-vector + [(e-length) (do-make-vector e-length default-fill)] + [(e-length e-fill) (bind #t (e-fill) (do-make-vector e-length e-fill))]) + (let () + (define (valid-length? e-length) + (constant? + (lambda (x) (and (target-fixnum? x) (>= x 0))) + e-length)) + (define-inline 2 make-vector + [(e-length) + (and (valid-length? e-length) + (do-make-vector e-length default-fill))] + [(e-length e-fill) + (and (valid-length? e-length) + (constant? fixnum? e-fill) + (do-make-vector e-length e-fill))])) + (define-inline 2 vector->immutable-vector + [(e-vec) + (nanopass-case (L7 Expr) e-vec + [(quote ,d) + (guard (vector? d) (fx= 0 (vector-length d))) + `(literal ,(make-info-literal #f 'entry (lookup-c-entry null-immutable-vector) 0))] + [else #f])]))) + + (let () + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (let () + (define build-stencil-vector-type + (lambda (e-mask) ; e-mask is used only once + (%inline logor + (immediate ,(constant type-stencil-vector)) + ,(%inline sll ,e-mask (immediate ,(fx- (constant stencil-vector-mask-offset) + (constant fixnum-offset))))))) + (define do-stencil-vector + (lambda (e-mask e-val*) + (list-bind #f (e-val*) + (bind #f (e-mask) + (let ([t-vec (make-tmp 'tvec)]) + `(let ([,t-vec ,(%constant-alloc type-typed-object + (fx+ (constant header-size-stencil-vector) + (fx* (length e-val*) (constant ptr-bytes))))]) + ,(let loop ([e-val* e-val*] [i 0]) + (if (null? e-val*) + `(seq + (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) + ,(build-stencil-vector-type e-mask)) + ,t-vec) + `(seq + (set! ,(%mref ,t-vec ,(fx+ i (constant stencil-vector-data-disp))) ,(car e-val*)) + ,(loop (cdr e-val*) (fx+ i (constant ptr-bytes)))))))))))) + (define do-make-stencil-vector + (lambda (e-length e-mask) + (bind #t (e-length) + (bind #f (e-mask) + (let ([t-vec (make-tmp 'tvec)]) + `(let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,e-length + (immediate ,(fx+ (constant header-size-stencil-vector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + ,(%seq + (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp)) + ,(build-stencil-vector-type e-mask)) + ;; Content not filled! This function is meant to be called by + ;; `$stencil-vector-update`, which has GC disabled between + ;; allocation and filling in the data + ,t-vec))))))) + (define-inline 3 stencil-vector + [(e-mask . e-val*) + (do-stencil-vector e-mask e-val*)]) + (define-inline 2 $make-stencil-vector + [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) + (define-inline 3 $make-stencil-vector + [(e-length e-mask) (do-make-stencil-vector e-length e-mask)]) + (define-inline 3 stencil-vector-update + [(e-vec e-sub-mask e-add-mask . e-val*) + `(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 '$stencil-vector-update) + ,e-vec ,e-sub-mask ,e-add-mask ,e-val* ...)]) + (define-inline 3 stencil-vector-truncate! + [(e-vec e-mask) + (bind #f (e-vec e-mask) + `(seq + (set! ,(%mref ,e-vec ,(constant stencil-vector-type-disp)) + ,(build-stencil-vector-type e-mask)) + ,(%constant svoid)))]))) + (let () + (meta-assert (= (constant log2-ptr-bytes) (constant fixnum-offset))) + (define-inline 3 $make-eqhash-vector + [(e-length) + (let ([t-vec (make-tmp 'tvec)] + [t-idx (make-assigned-tmp 't-idx)] + [Ltop (make-local-label 'Ltop)]) + `(let ([,t-idx ,e-length]) + (if ,(%inline eq? ,t-idx (immediate 0)) + (quote ,(vector)) + (let ([,t-vec (alloc ,(make-info-alloc (constant type-typed-object) #f #f) + ,(%inline logand + ,(%inline + ,t-idx + (immediate ,(fx+ (constant header-size-vector) + (fx- (constant byte-alignment) 1)))) + (immediate ,(- (constant byte-alignment)))))]) + (seq + (set! ,(%mref ,t-vec ,(constant vector-type-disp)) + ,(build-type/length t-idx + (constant type-vector) + (constant fixnum-offset) + (constant vector-length-offset))) + (label ,Ltop + ,(%seq + (set! ,t-idx ,(%inline - ,t-idx (immediate ,(fix 1)))) + (set! ,(%mref ,t-vec ,t-idx ,(constant vector-data-disp)) ,t-idx) + (if ,(%inline eq? ,t-idx (immediate 0)) + ,t-vec + (goto ,Ltop)))))))))])) + + (let () + (define build-continuation?-test + (lambda (e) ; e must be bound + (build-and + (%type-check mask-closure type-closure ,e) + (%type-check mask-continuation-code type-continuation-code + ,(%mref + ,(%inline - + ,(%mref ,e ,(constant closure-code-disp)) + ,(%constant code-data-disp)) + ,(constant code-type-disp)))))) + (define-inline 2 $continuation? + [(e) (bind #t (e) + (build-continuation?-test e))]) + (define-inline 2 $assert-continuation + [(e) (bind #t (e) + `(if ,(build-and + (build-continuation?-test e) + (%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders))) + ,(%constant svoid) + ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] + [(e1 e2) (bind #t (e1 e2) + `(if ,(build-and + (build-continuation?-test e1) + (build-and + (%inline eq? ,(%mref ,e1 ,(constant continuation-winders-disp)) ,(%tc-ref winders)) + (build-simple-or + (%inline eq? ,e2 ,(%mref ,e1 ,(constant continuation-attachments-disp))) + (build-and + (%type-check mask-pair type-pair ,e2) + (%inline eq? ,(%mref ,e2 ,(constant pair-cdr-disp)) ,(%mref ,e1 ,(constant continuation-attachments-disp))))))) + ,(%constant svoid) + ,(build-libcall #t src sexpr $check-continuation e1 (%constant strue) e2)))]) + (define-inline 3 $assert-continuation + [(e) (bind #t (e) + `(if ,(%inline eq? ,(%mref ,e ,(constant continuation-winders-disp)) ,(%tc-ref winders)) + ,(%constant svoid) + ,(build-libcall #t src sexpr $check-continuation e (%constant sfalse) (%constant sfalse))))] + [(e1 e2) #f])) + + (define-inline 3 $continuation-stack-length + [(e) + (translate (%mref ,e ,(constant continuation-stack-length-disp)) + (constant fixnum-offset) + (constant log2-ptr-bytes))]) + (define-inline 3 $continuation-stack-clength + [(e) + (translate (%mref ,e ,(constant continuation-stack-clength-disp)) + (constant fixnum-offset) + (constant log2-ptr-bytes))]) + (let () + (define (build-ra e) + (%mref ,e ,(constant continuation-return-address-disp))) + (define (build-stack-ra e-k e-i) + (%mref ,(%mref ,e-k ,(constant continuation-stack-disp)) + ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) + 0)) + + (define build-return-code + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([t `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline + ,ra ,(%constant compact-return-address-toplink-disp)) + ,(%inline + ,ra ,(%constant return-address-toplink-disp)))]) + (%inline - ,t ,(%mref ,t 0)))))) + (define build-return-offset + (lambda (e-ra) + (bind #t ([ra e-ra]) + (build-fix + `(if ,(%inline logtest ,(%mref ,ra ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ,(%inline - ,(%mref ,ra ,(constant compact-return-address-toplink-disp)) + ,(%constant compact-return-address-toplink-disp)) + ,(%inline - ,(%mref ,ra ,(constant return-address-toplink-disp)) + ,(%constant return-address-toplink-disp))))))) + (define build-return-livemask + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) + `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) + ,(%inline sll ,(%inline srl ,mask+size+mode ,(%constant compact-frame-mask-offset)) + ,(%constant fixnum-offset)) + ,(%mref ,ra ,(constant return-address-livemask-disp))))))) + (define build-return-frame-words + (lambda (e-ra) + (bind #t ([ra e-ra]) + (bind #t ([mask+size+mode (%mref ,ra ,(constant compact-return-address-mask+size+mode-disp))]) + `(if ,(%inline logtest ,mask+size+mode ,(%constant compact-header-mask)) + ,(%inline sll ,(%inline logand ,(%inline srl ,mask+size+mode ,(%constant compact-frame-words-offset)) + ,(%constant compact-frame-words-mask)) + ,(%constant fixnum-offset)) + ,(%mref ,ra ,(constant return-address-frame-size-disp))))))) + + (define-inline 3 $continuation-return-code + [(e) (build-return-code (build-ra e))]) + (define-inline 3 $continuation-return-offset + [(e) (build-return-offset (build-ra e))]) + (define-inline 3 $continuation-return-livemask + [(e) (build-return-livemask (build-ra e))]) + (define-inline 3 $continuation-return-frame-words + [(e) (build-return-frame-words (build-ra e))]) + (define-inline 3 $continuation-stack-ref + [(e-k e-i) + (%mref + ,(%mref ,e-k ,(constant continuation-stack-disp)) + ,(translate e-i (constant fixnum-offset) (constant log2-ptr-bytes)) + 0)]) + (define-inline 3 $continuation-stack-return-code + [(e-k e-i) (build-return-code (build-stack-ra e-k e-i))]) + (define-inline 3 $continuation-stack-return-offset + [(e-k e-i) (build-return-offset (build-stack-ra e-k e-i))]) + (define-inline 3 $continuation-stack-return-frame-words + [(e-k e-i) (build-return-frame-words (build-stack-ra e-k e-i))])) + + (define-inline 2 $foreign-char? + [(e) + (bind #t (e) + (build-and + (%type-check mask-char type-char ,e) + (%inline < ,e (immediate ,(ptr->imm (integer->char #x100))))))]) + (define-inline 2 $foreign-wchar? + [(e) + (constant-case wchar-bits + [(16) + (bind #t (e) + (build-and + (%type-check mask-char type-char ,e) + (%inline < ,e (immediate ,(ptr->imm (integer->char #x10000))))))] + [(32) (%type-check mask-char type-char ,e)])]) + (define-inline 2 $integer-8? + [(e) + (unless (fx>= (constant fixnum-bits) 8) ($oops '$integer-8? "unexpected fixnum-bits")) + (bind #t (e) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x80))) + (immediate ,(fix #x180)))))]) + (define-inline 2 $integer-16? + [(e) + (unless (fx>= (constant fixnum-bits) 16) ($oops '$integer-16? "unexpected fixnum-bits")) + (bind #t (e) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x8000))) + (immediate ,(fix #x18000)))))]) + (define-inline 2 $integer-24? + [(e) + (unless (fx>= (constant fixnum-bits) 24) ($oops '$integer-24? "unexpected fixnum-bits")) + (bind #t (e) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x800000))) + (immediate ,(fix #x1800000)))))]) + (define-inline 2 $integer-32? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x80000000))) + (immediate ,(fix #x180000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-80000000)))))))))]) + (define-inline 2 $integer-40? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x8000000000))) + (immediate ,(fix #x18000000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-8000000000)))))))))]) + (define-inline 2 $integer-48? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x800000000000))) + (immediate ,(fix #x1800000000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-800000000000)))))))))]) + (define-inline 2 $integer-56? + [(e) + (bind #t (e) + (if (fx>= (constant fixnum-bits) 32) + (build-and + (%type-check mask-fixnum type-fixnum ,e) + (%inline u< + ,(%inline + ,e (immediate ,(fix #x80000000000000))) + (immediate ,(fix #x180000000000000)))) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-80000000000000)))))))))]) + (define-inline 2 $integer-64? + [(e) + (when (fx>= (constant fixnum-bits) 64) ($oops '$integer-64? "unexpected fixnum-bits")) + (bind #t (e) + (build-simple-or + (%type-check mask-fixnum type-fixnum ,e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant bignum-type-disp))]) + `(if ,(%type-check mask-signed-bignum type-positive-bignum ,t) + ,(build-libcall #f #f sexpr <= e `(quote #xffffffffffffffff)) + ,(build-and + (%type-check mask-signed-bignum type-negative-bignum ,t) + (build-libcall #f #f sexpr >= e `(quote #x-8000000000000000))))))))]) + (define-inline 3 char->integer + ; assumes types are set up so that fixnum tag will be right after the shift + [(e-char) (build-char->integer e-char)]) + (define-inline 2 char->integer + ; assumes types are set up so that fixnum tag will be right after the shift + [(e-char) + (bind #t (e-char) + `(if ,(%type-check mask-char type-char ,e-char) + ,(%inline srl ,e-char + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset)))) + ,(build-libcall #t src sexpr char->integer e-char)))]) + (define-inline 3 char- + ; assumes fixnum is zero + [(e1 e2) + (%inline srl + ,(%inline - ,e1 ,e2) + (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset))))]) + (define-inline 3 integer->char + [(e-int) (build-integer->char e-int)]) + (define-inline 3 boolean=? + [(e1 e2) (%inline eq? ,e1 ,e2)] + [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) + (define-inline 3 symbol=? + [(e1 e2) (%inline eq? ,e1 ,e2)] + [(e1 e2 . e*) (reduce-equality src sexpr moi e1 e2 e*)]) + (let () + (define (go e flag) + (%inline logtest + ,(%mref ,e ,(constant record-type-flags-disp)) + (immediate ,(fix flag)))) + (define-inline 3 record-type-opaque? + [(e) (go e (constant rtd-opaque))]) + (define-inline 3 record-type-sealed? + [(e) (go e (constant rtd-sealed))]) + (define-inline 3 $record-type-act-sealed? + [(e) (go e (fxior (constant rtd-sealed) (constant rtd-act-sealed)))]) + (define-inline 3 record-type-generative? + [(e) (go e (constant rtd-generative))])) + (let () + (define build-record? + (lambda (e) + (bind #t (e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + (bind #t ([t (%mref ,e ,(constant typed-object-type-disp))]) + (build-and + (%type-check mask-record type-record ,t) + (build-not + (%inline logtest + ,(%mref ,t ,(constant record-type-flags-disp)) + (immediate ,(fix (constant rtd-opaque))))))))))) + (define build-sealed-isa? + (lambda (e e-rtd assume-record?) + (bind #t (e) + (bind #f (e-rtd) + (maybe-build-and + (and (not assume-record?) + (%type-check mask-typed-object type-typed-object ,e)) + (%inline eq? + ,(%mref ,e ,(constant typed-object-type-disp)) + ,e-rtd)))))) + (define build-unsealed-isa? + (lambda (e e-rtd assume-record?) + (let ([known-depth (nanopass-case (L7 Expr) e-rtd + [(quote ,d) (and (record-type-descriptor? d) + (vector-length (rtd-ancestors d)))] + [else #f])]) + ;; `t` is rtd of `e`, and it's used once + (define (compare-at-depth t known-depth) + (cond + [(eqv? known-depth (constant minimum-ancestry-vector-length)) + ;; no need to check ancestry array length + (%inline eq? ,e-rtd ,(%mref ,(%mref ,t ,(constant record-type-ancestry-disp)) + ,(fx+ (constant vector-data-disp) + (fx* (fx- known-depth 1) (constant ptr-bytes)))))] + [known-depth + ;; need to check ancestry array length + (let ([a (make-tmp 'a)]) + `(let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))]) + (if ,(%inline <= + (immediate ,(fxsll known-depth (constant vector-length-offset))) + ,(%mref ,a ,(constant vector-type-disp))) + ,(%inline eq? ,e-rtd ,(%mref ,a ,(fx+ (constant vector-data-disp) + (fx* (fx- known-depth 1) (constant ptr-bytes))))) + ,(%constant sfalse))))] + [else + (bind #t (e-rtd) + (let ([a (make-tmp 'a)] [rtd-a (make-tmp 'rtd-a)] [rtd-len (make-tmp 'rtd-len)]) + `(let ([,rtd-a ,(%mref ,e-rtd ,(constant record-type-ancestry-disp))]) + (let ([,a ,(%mref ,t ,(constant record-type-ancestry-disp))]) + (let ([,rtd-len ,(%mref ,rtd-a ,(constant vector-type-disp))]) + (if ,(%inline <= ,rtd-len ,(%mref ,a ,(constant vector-type-disp))) + ,(begin + ;; take advantage of being able to use the type field of a vector + ;; as a pointer offset with just shifting: + (safe-assert (zero? (constant type-vector))) + (%inline eq? ,e-rtd ,(%mref ,a + ,(translate rtd-len (constant vector-length-offset) (constant log2-ptr-bytes)) + ,(fx- (constant vector-data-disp) (constant ptr-bytes))))) + ,(%constant sfalse)))))))])) + (cond + [assume-record? + (compare-at-depth (%mref ,e ,(constant typed-object-type-disp)) known-depth)] + [else + (let ([t (make-tmp 't)]) + (bind #t (e) + (build-and + (%type-check mask-typed-object type-typed-object ,e) + `(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))]) + ,(build-and + (%type-check mask-record type-record ,t) + (compare-at-depth t known-depth))))))])))) + (define-inline 3 record? + [(e) (build-record? e)] + [(e e-rtd) + (if (constant? (lambda (x) + (and (record-type-descriptor? x) + (record-type-sealed? x))) + e-rtd) + (build-sealed-isa? e e-rtd #f) + (build-unsealed-isa? e e-rtd #f))]) + (define-inline 3 record-instance? + [(e e-rtd) + (if (constant? (lambda (x) + (and (record-type-descriptor? x) + (record-type-sealed? x))) + e-rtd) + (build-sealed-isa? e e-rtd #t) + (build-unsealed-isa? e e-rtd #t))]) + (define-inline 2 r6rs:record? + [(e) (build-record? e)]) + (define-inline 2 record? + [(e) (build-record? e)] + [(e e-rtd) + (nanopass-case (L7 Expr) e-rtd + [(quote ,d) + (and (record-type-descriptor? d) + (if (record-type-sealed? d) + (build-sealed-isa? e e-rtd #f) + (build-unsealed-isa? e e-rtd #f)))] + [else #f])]) + (define-inline 2 $sealed-record? + [(e e-rtd) (build-sealed-isa? e e-rtd #f)]) + (define-inline 2 $sealed-record-instance? + [(e e-rtd) (build-sealed-isa? e e-rtd #t)]) + (define-inline 3 $record-type-field-count + [(e) (%inline srl ,(%inline - ,(%mref ,e ,(constant record-type-size-disp)) + (immediate ,(fxsll (fx- (constant record-data-disp) (constant record-type-disp)) + (constant fixnum-offset)))) + ,(%constant log2-ptr-bytes))]) + (define-inline 2 eq-hashtable? + [(e) (let ([rtd (let () (include "hashtable-types.ss") (record-type-descriptor eq-ht))]) + (let ([e-rtd `(quote ,rtd)]) + (if (record-type-sealed? rtd) + (build-sealed-isa? e e-rtd #f) + (build-unsealed-isa? e e-rtd #f))))])) + (define-inline 2 gensym? + [(e) + (bind #t (e) + (build-and + (%type-check mask-symbol type-symbol ,e) + (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) + `(if ,t + ,(build-and (%type-check mask-pair type-pair ,t) + (build-and (%mref ,t ,(constant pair-cdr-disp)) + (%constant strue))) + ,(%constant strue)))))]) + (define-inline 2 uninterned-symbol? + [(e) + (bind #t (e) + (build-and + (%type-check mask-symbol type-symbol ,e) + (bind #t ([t (%mref ,e ,(constant symbol-name-disp))]) + (build-and (%type-check mask-pair type-pair ,t) + (build-not (%mref ,t ,(constant pair-cdr-disp)))))))]) + (let () + (define build-make-symbol + (lambda (e-name) + (bind #t ([t (%constant-alloc type-symbol (constant size-symbol))]) + (%seq + (set! ,(%mref ,t ,(constant symbol-name-disp)) ,e-name) + (set! ,(%mref ,t ,(constant symbol-value-disp)) ,(%constant sunbound)) + (set! ,(%mref ,t ,(constant symbol-pvalue-disp)) + (literal + ,(make-info-literal #f 'library + (lookup-libspec nonprocedure-code) + (constant code-data-disp)))) + (set! ,(%mref ,t ,(constant symbol-plist-disp)) ,(%constant snil)) + (set! ,(%mref ,t ,(constant symbol-splist-disp)) ,(%constant snil)) + (set! ,(%mref ,t ,(constant symbol-hash-disp)) ,(%constant sfalse)) + ,t)))) + (define (go e-pname) + (bind #t ([t (%constant-alloc type-pair (constant size-pair))]) + (%seq + (set! ,(%mref ,t ,(constant pair-cdr-disp)) ,e-pname) + (set! ,(%mref ,t ,(constant pair-car-disp)) ,(%constant sfalse)) + ,(build-make-symbol t)))) + (define-inline 3 $gensym + [() (build-make-symbol (%constant sfalse))] + [(e-pname) (bind #f (e-pname) (go e-pname))] + [(e-pname e-uname) #f]) + (define-inline 3 gensym + [() (build-make-symbol (%constant sfalse))] + [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] + [(e-pname e-uname) #f]) + (define-inline 2 gensym + [() (build-make-symbol (%constant sfalse))] + [(e-pname) (and (constant? immutable-string? e-pname) (go e-pname))] + [(e-pname e-uname) #f])) + (define-inline 3 symbol->string + [(e-sym) + (bind #t (e-sym) + (bind #t ([e-name (%mref ,e-sym ,(constant symbol-name-disp))]) + `(if ,e-name + (if ,(%type-check mask-pair type-pair ,e-name) + ,(bind #t ([e-cdr (%mref ,e-name ,(constant pair-cdr-disp))]) + `(if ,e-cdr + ,e-cdr + ,(%mref ,e-name ,(constant pair-car-disp)))) + ,e-name) + ,(%primcall #f sexpr $gensym->pretty-name ,e-sym))))]) + (define-inline 3 $fxaddress + [(e) (%inline logand + ,(let ([n (- (log2 (constant typemod)) (constant fixnum-offset))]) + (if (> n 0) (%inline sra ,e (immediate ,n)) e)) + (immediate ,(- (constant fixnum-factor))))]) + (define-inline 3 $set-timer + [(e) (bind #f (e) + (bind #t ([t (build-fix (ref-reg %trap))]) + `(seq + (set! ,(ref-reg %trap) ,(build-unfix e)) + ,t)))]) + (define-inline 3 $get-timer + [() (build-fix (ref-reg %trap))]) + (define-inline 3 directory-separator? + [(e) (if-feature windows + (bind #t (e) + (build-simple-or + (%inline eq? ,e (immediate ,(ptr->imm #\/))) + (%inline eq? ,e (immediate ,(ptr->imm #\\))))) + (%inline eq? ,e (immediate ,(ptr->imm #\/))))]) + (let () + (define add-cdrs + (lambda (n e) + (if (fx= n 0) + e + (add-cdrs (fx- n 1) (%mref ,e ,(constant pair-cdr-disp)))))) + (define-inline 3 list-ref + [(e-ls e-n) + (nanopass-case (L7 Expr) e-n + [(quote ,d) + (and (and (fixnum? d) (fx< d 4)) + (%mref ,(add-cdrs d e-ls) ,(constant pair-car-disp)))] + [else #f])]) + (define-inline 3 list-tail + [(e-ls e-n) + (nanopass-case (L7 Expr) e-n + [(quote ,d) (and (and (fixnum? d) (fx<= d 4)) (add-cdrs d e-ls))] + [else #f])])) + (let () + (define (go0 src sexpr subtype) + (%primcall src sexpr $make-eq-hashtable + (immediate ,(fix (constant hashtable-default-size))) + (immediate ,(fix subtype)))) + (define (go1 src sexpr e-size subtype) + (nanopass-case (L7 Expr) e-size + [(quote ,d) + ; d must be a fixnum? for $hashtable-size-minlen and a + ; target-machine fixnum for cross compiling + (and (and (fixnum? d) (target-fixnum? d) (fx>= d 0)) + (%primcall src sexpr $make-eq-hashtable + (immediate ,(fix ($hashtable-size->minlen d))) + (immediate ,(fix subtype))))] + [else #f])) + (define-inline 3 make-eq-hashtable + [() (go0 src sexpr (constant eq-hashtable-subtype-normal))] + [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-normal))]) + (define-inline 3 make-weak-eq-hashtable + [() (go0 src sexpr (constant eq-hashtable-subtype-weak))] + [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-weak))]) + (define-inline 3 make-ephemeron-eq-hashtable + [() (go0 src sexpr (constant eq-hashtable-subtype-ephemeron))] + [(e-size) (go1 src sexpr e-size (constant eq-hashtable-subtype-ephemeron))])) + (let () + (define-syntax def-put-x + (syntax-rules () + [(_ name x-length) + (define-inline 3 name + [(e-bop e-x) + (bind #t (e-x) + (build-libcall #f src sexpr name e-bop e-x `(immediate 0) + (handle-prim #f #f 3 'x-length (list e-x))))] + [(e-bop e-x e-start) + (bind #t (e-x e-start) + (build-libcall #f src sexpr name e-bop e-x e-start + (%inline - + ,(handle-prim #f #f 3 'x-length (list e-x)) + ,e-start)))] + [(e-bop e-x e-start e-count) + (build-libcall #f src sexpr name e-bop e-x e-start e-count)])])) + (def-put-x put-bytevector bytevector-length) + (def-put-x put-bytevector-some bytevector-length) + (def-put-x put-string string-length) + (def-put-x put-string-some string-length)) + + (define-inline 3 $read-time-stamp-counter + [() + (constant-case architecture + [(x86) + (%seq + ; returns low-order 32 bits in eax, high-order in edx + (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-time-stamp-counter)) + ,(u32xu32->ptr %edx %eax))] + [(x86_64) + (%seq + ; returns low-order 32 bits in rax, high-order in rdx + (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-time-stamp-counter)) + ,(unsigned->ptr + (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) + 64))] + [(arm32 pb) (unsigned->ptr (%inline read-time-stamp-counter) 32)] + [(arm64) (unsigned->ptr (%inline read-time-stamp-counter) 64)] + [(ppc32) + (let ([t-hi (make-tmp 't-hi)]) + `(let ([,t-hi (inline ,(make-info-kill* (reg-list %real-zero)) + ,%read-time-stamp-counter)]) + ,(u32xu32->ptr t-hi %real-zero)))])]) + + (define-inline 3 $read-performance-monitoring-counter + [(e) + (constant-case architecture + [(x86) + (%seq + (set! ,%eax (inline ,(make-info-kill* (reg-list %edx)) ,%read-performance-monitoring-counter ,(build-unfix e))) + ,(u32xu32->ptr %edx %eax))] + [(x86_64) + (%seq + (set! ,%rax (inline ,(make-info-kill* (reg-list %rdx)) ,%read-performance-monitoring-counter ,(build-unfix e))) + ,(unsigned->ptr + (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) + 64))] + [(arm32 ppc32 pb) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)] + [(arm64) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 64)])]) + + (define-inline 3 assert-unreachable + [() (%constant svoid)]) + + )) ; expand-primitives module + +(set! $np-expand-primitives np-expand-primitives) +) diff --git a/racket/src/ChezScheme/s/np-help.ss b/racket/src/ChezScheme/s/np-help.ss new file mode 100644 index 0000000000..aa2fb1c2ab --- /dev/null +++ b/racket/src/ChezScheme/s/np-help.ss @@ -0,0 +1,206 @@ +;; Helpers for "cpnanopass.ss" and "cpprim.ss", especially +;; "%"-prefixed macros that abbreviate expression constructions + +(define-syntax tc-disp + (lambda (x) + (syntax-case x () + [(_ name) + (case (datum name) + [(%ac0) (constant tc-ac0-disp)] + [(%ac1) (constant tc-ac1-disp)] + [(%sfp) (constant tc-sfp-disp)] + [(%cp) (constant tc-cp-disp)] + [(%esp) (constant tc-esp-disp)] + [(%ap) (constant tc-ap-disp)] + [(%eap) (constant tc-eap-disp)] + [(%trap) (constant tc-trap-disp)] + [(%xp) (constant tc-xp-disp)] + [(%yp) (constant tc-yp-disp)] + [(%save1) (constant tc-save1-disp)] + [else #f])]))) + +(define-syntax %type-check + (lambda (x) + (syntax-case x () + [(k mask type expr) + (with-implicit (k $type-check quasiquote) + #'($type-check (constant mask) (constant type) `expr))]))) + +(define-syntax %typed-object-check ; NB: caller must bind e + (lambda (x) + (syntax-case x () + [(k mask type expr) + (with-implicit (k quasiquote %type-check %constant %mref) + #'`(if ,(%type-check mask-typed-object type-typed-object expr) + ,(%type-check mask type + ,(%mref expr ,(constant typed-object-type-disp))) + ,(%constant sfalse)))]))) + +(define-syntax %seq + (lambda (x) + (syntax-case x () + [(k e1 ... e2) + (with-implicit (k quasiquote) + #``#,(fold-right (lambda (x body) #`(seq #,x #,body)) + #'e2 #'(e1 ...)))]))) + +(define-syntax %mref + (lambda (x) + (syntax-case x () + [(k e0 e1 imm type) + (with-implicit (k quasiquote) + #'`(mref e0 e1 imm type))] + [(k e0 e1 imm) + (with-implicit (k quasiquote) + #'`(mref e0 e1 imm uptr))] + [(k e0 imm) + (with-implicit (k quasiquote) + #'`(mref e0 ,%zero imm uptr))]))) + +(define-syntax %inline + (lambda (x) + (syntax-case x () + [(k name e ...) + (with-implicit (k quasiquote) + #'`(inline ,null-info ,(%primitive name) e ...))]))) + +(define-syntax %lea + (lambda (x) + (syntax-case x () + [(k base offset) + (with-implicit (k quasiquote) + #'`(inline ,(make-info-lea offset) ,%lea1 base))] + [(k base index offset) + (with-implicit (k quasiquote) + #'`(inline ,(make-info-lea offset) ,%lea2 base index))]))) + +(define-syntax %constant + (lambda (x) + (syntax-case x () + [(k x) + (with-implicit (k quasiquote) + #'`(immediate ,(constant x)))]))) + +(define-syntax %tc-ref + (lambda (x) + (define-who field-type + (lambda (struct field) + (cond + [(assq field (getprop struct '*fields* '())) => + (lambda (a) + (apply + (lambda (field type disp len) type) + a))] + [else ($oops who "undefined field ~s-~s" struct field)]))) + (syntax-case x () + [(k field) #'(k ,%tc field)] + [(k e-tc field) + (if (memq (field-type 'tc (datum field)) '(ptr xptr uptr iptr)) + (with-implicit (k %mref) + #`(%mref e-tc + #,(lookup-constant + (string->symbol + (format "tc-~a-disp" (datum field)))))) + (syntax-error x "non-ptr-size tc field"))]))) + +(define-syntax %constant-alloc + (lambda (x) + (syntax-case x () + [(k tag size) #'(k tag size #f #f)] + [(k tag size save-flrv?) #'(k tag size save-flrv? #f)] + [(k tag size save-flrv? save-asm-ra?) + (with-implicit (k quasiquote) + #'`(alloc + ,(make-info-alloc (constant tag) save-flrv? save-asm-ra?) + (immediate ,(c-alloc-align size))))]))) + +(define-syntax %mv-jump + (lambda (x) + (syntax-case x () + [(k ret-reg (live ...)) + (with-implicit (k quasiquote %mref %inline %constant) + #'`(if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-mask)) + ;; compact: use regular return or error? + (if ,(%inline logtest ,(%mref ret-reg ,(constant compact-return-address-mask+size+mode-disp)) + ,(%constant compact-header-values-error-mask)) + ;; values error: + (jump (literal ,(make-info-literal #f 'library-code + (lookup-libspec values-error) + (constant code-data-disp))) + (live ...)) + ;; regular return point: + (jump ret-reg (live ...))) + ;; non-compact rp-header + (jump ,(%mref ret-reg ,(constant return-address-mv-return-address-disp)) (live ...))))]))) + + + +; for use only after mdcl field has been added to the call syntax +(define-syntax %primcall + (lambda (x) + (syntax-case x () + [(k src sexpr prim arg ...) + (identifier? #'prim) + (with-implicit (k quasiquote) + #``(call ,(make-info-call src sexpr #f #f #f) #f + ,(lookup-primref 3 'prim) + arg ...))]))) + +(define-syntax define-$type-check + (lambda (x) + (syntax-case x () + [(k L) (with-implicit (k $type-check) + #'(define $type-check + (lambda (mask type expr) + (with-output-language L + (cond + [(fx= type 0) (%inline log!test ,expr (immediate ,mask))] + [(= mask (constant byte-constant-mask)) (%inline eq? ,expr (immediate ,type))] + [else (%inline type-check? ,expr (immediate ,mask) (immediate ,type))])))))]))) + +(define target-fixnum? + (if (and (= (constant most-negative-fixnum) (most-negative-fixnum)) + (= (constant most-positive-fixnum) (most-positive-fixnum))) + fixnum? + (lambda (x) + (and (or (fixnum? x) (bignum? x)) + (<= (constant most-negative-fixnum) x (constant most-positive-fixnum)))))) + +(define unfix + (lambda (imm) + (ash imm (fx- (constant fixnum-offset))))) + +(define fix + (lambda (imm) + (ash imm (constant fixnum-offset)))) + +(define ptr->imm + (lambda (x) + (cond + [(eq? x #f) (constant sfalse)] + [(eq? x #t) (constant strue)] + [(eq? x (void)) (constant svoid)] + [(null? x) (constant snil)] + [(eof-object? x) (constant seof)] + [($unbound-object? x) (constant sunbound)] + [(bwp-object? x) (constant sbwp)] + [(eq? x '#1=#1#) (constant black-hole)] + [(target-fixnum? x) (fix x)] + [(char? x) (+ (* (constant char-factor) (char->integer x)) (constant type-char))] + [else #f]))) + +(define-syntax ref-reg + (lambda (x) + (syntax-case x () + [(k reg) + (identifier? #'reg) + (if (real-register? (datum reg)) + #'reg + (with-implicit (k %mref) #`(%mref ,%tc ,(tc-disp reg))))]))) + +(define (fp-type? type) + (nanopass-case (Ltype Type) type + [(fp-double-float) #t] + [(fp-single-float) #t] + [else #f])) diff --git a/racket/src/ChezScheme/s/np-info.ss b/racket/src/ChezScheme/s/np-info.ss new file mode 100644 index 0000000000..da3629016b --- /dev/null +++ b/racket/src/ChezScheme/s/np-info.ss @@ -0,0 +1,258 @@ +;; Records used by "cpnanopass.ss" and "cpprim.ss" + +(define-record-type ctci ; compile-time version of code-info + (nongenerative #{ctci bcpkdd2y9yyv643zicd4jbe3y-0}) + (sealed #t) + (fields (mutable live) (mutable rpi*) (mutable closure-fv-names)) + (protocol + (lambda (new) + (lambda () + (new #f '() #f))))) + +(define-record-type ctrpi ; compile-time version of rp-info + (nongenerative #{ctrpi bcpkdd2y9yyv643zicd4jbe3y-1}) + (sealed #t) + (fields label src sexpr mask)) + +(define-record-type info-lambda + (nongenerative #{info-lambda bcpkdd2y9yyv643zicd4jbe3y-2}) + (parent info) + (sealed #t) + (fields src sexpr libspec (mutable interface*) (mutable dcl*) (mutable flags) (mutable fv*) (mutable name) + (mutable well-known?) (mutable closure-rep) ctci (mutable pinfo*) seqno) + (protocol + (lambda (pargs->new) + (rec cons-info-lambda + (case-lambda + [(src sexpr libspec interface*) (cons-info-lambda src sexpr libspec interface* #f 0)] + [(src sexpr libspec interface* name) (cons-info-lambda src sexpr libspec interface* name 0)] + [(src sexpr libspec interface* name flags) + ((pargs->new) src sexpr libspec interface* + (map (lambda (iface) (make-direct-call-label 'dcl)) interface*) + (if (eq? (subset-mode) 'system) (fxlogor flags (constant code-flag-system)) flags) + '() name #f 'closure (and (generate-inspector-information) (make-ctci)) '() ($np-next-lambda-seqno))]))))) + +(define-record-type info-call + (nongenerative #{info-call bcpkdd2y9yyv643zicd4jbe3y-3}) + (parent info) + (sealed #t) + (fields src sexpr (mutable check?) pariah? error? shift-attachment? shift-consumer-attachment?*) + (protocol + (lambda (pargs->new) + (case-lambda + [(src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*) + ((pargs->new) src sexpr check? pariah? error? shift-attachment? shift-consumer-attachment?*)] + [(src sexpr check? pariah? error?) + ((pargs->new) src sexpr check? pariah? error? #f '())])))) + +(define-record-type info-newframe + (nongenerative #{info-newframe bcpkdd2y9yyv643zicd4jbe3y-4}) + (parent info) + (sealed #t) + (fields + src + sexpr + cnfv* + nfv* + nfv** + (mutable weight) + (mutable call-live*) + (mutable frame-words) + (mutable local-save*)) + (protocol + (lambda (pargs->new) + (lambda (src sexpr cnfv* nfv* nfv**) + ((pargs->new) src sexpr cnfv* nfv* nfv** 0 #f #f #f))))) + +(define-record-type info-kill* + (nongenerative #{info-kill* bcpkdd2y9yyv643zicd4jbe3y-5}) + (parent info) + (fields kill*)) + +(define-record-type info-kill*-live* + (nongenerative #{info-kill*-live* bcpkdd2y9yyv643zicd4jbe3y-6}) + (parent info-kill*) + (fields live*) + (protocol + (lambda (new) + (case-lambda + [(kill* live*) + ((new kill*) live*)] + [(kill*) + ((new kill*) (reg-list))])))) + +(define-record-type info-asmlib + (nongenerative #{info-asmlib bcpkdd2y9yyv643zicd4jbe3y-7}) + (parent info-kill*-live*) + (sealed #t) + (fields libspec save-ra?) + (protocol + (lambda (new) + (case-lambda + [(kill* libspec save-ra? live*) + ((new kill* live*) libspec save-ra?)] + [(kill* libspec save-ra?) + ((new kill*) libspec save-ra?)])))) + +(module (intrinsic-info-asmlib intrinsic-return-live* intrinsic-entry-live* intrinsic-modify-reg* dorest-intrinsics) + ; standing on our heads here to avoid referencing registers at + ; load time...would be cleaner if registers were immutable, + ; i.e., mutable fields (direct and inherited from var) were kept + ; in separate tables...but that might add more cost to register + ; allocation, which is already expensive. + (define-record-type intrinsic + (nongenerative #{intrinsic bcpkdd2y9yyv643zicd4jbe3y-8}) + (sealed #t) + (fields libspec get-kill* get-live* get-rv*)) + (define intrinsic-info-asmlib + (lambda (intrinsic save-ra?) + (make-info-asmlib ((intrinsic-get-kill* intrinsic)) + (intrinsic-libspec intrinsic) + save-ra? + ((intrinsic-get-live* intrinsic))))) + (define intrinsic-return-live* + ; used a handful of times, just while compiling library.ss...don't bother optimizing + (lambda (intrinsic) + (fold-left (lambda (live* kill) (remq kill live*)) + (vector->list regvec) ((intrinsic-get-kill* intrinsic))))) + (define intrinsic-entry-live* + ; used a handful of times, just while compiling library.ss...don't bother optimizing + (lambda (intrinsic) ; return-live* - rv + live* + (fold-left (lambda (live* live) (if (memq live live*) live* (cons live live*))) + (fold-left (lambda (live* rv) (remq rv live*)) + (intrinsic-return-live* intrinsic) + ((intrinsic-get-rv* intrinsic))) + ((intrinsic-get-live* intrinsic))))) + (define intrinsic-modify-reg* + (lambda (intrinsic) + (append ((intrinsic-get-rv* intrinsic)) + ((intrinsic-get-kill* intrinsic))))) + (define-syntax declare-intrinsic + (syntax-rules (unquote) + [(_ name entry-name (kill ...) (live ...) (rv ...)) + (begin + (define name + (make-intrinsic + (lookup-libspec entry-name) + (lambda () (reg-list kill ...)) + (lambda () (reg-list live ...)) + (lambda () (reg-list rv ...)))) + (export name))])) + ; must include in kill ... any register explicitly assigned by the intrinsic + ; plus additional registers as needed to avoid spilled unspillables. the + ; list could be machine-dependent but at this point it doesn't matter. + (declare-intrinsic dofargint32 dofargint32 (%ts %td %xp) (%ac0) (%ac0)) + (constant-case ptr-bits + [(32) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0 %ac1))] + [(64) (declare-intrinsic dofargint64 dofargint64 (%ts %td %xp) (%ac0) (%ac0))]) + (declare-intrinsic dofretint32 dofretint32 (%ts %td %xp) (%ac0) (%ac0)) + (constant-case ptr-bits + [(32) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] + [(64) (declare-intrinsic dofretint64 dofretint64 (%ts %td %xp) (%ac0) (%ac0))]) + (declare-intrinsic dofretuns32 dofretuns32 (%ts %td %xp) (%ac0) (%ac0)) + (constant-case ptr-bits + [(32) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0 %ac1) (%ac0))] + [(64) (declare-intrinsic dofretuns64 dofretuns64 (%ts %td %xp) (%ac0) (%ac0))]) + (declare-intrinsic dofretu8* dofretu8* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic dofretu16* dofretu16* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic dofretu32* dofretu32* (%ac0 %ts %td %cp %ac1) (%ac0) (%xp)) + (declare-intrinsic get-room get-room () (%xp) (%xp)) + (declare-intrinsic scan-remembered-set scan-remembered-set () () ()) + (declare-intrinsic reify-1cc reify-1cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; %reify1 & %reify2 are defined as needed per machine... + (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts %reify1 %reify2) () (%td)) ; ... to have enough registers to allocate + (declare-intrinsic dooverflow dooverflow () () ()) + (declare-intrinsic dooverflood dooverflood () (%xp) ()) + ; a dorest routine takes all of the register and frame arguments from the rest + ; argument forward and also modifies the rest argument. for the rest argument, + ; this is a wash (it's live both before and after). the others should also be + ; listed as live. it's inconvenient and currently unnecessary to do so. + ; (actually currently impossible to list the infinite set of frame arguments) + (define-syntax dorest-intrinsic-max (identifier-syntax 5)) + (export dorest-intrinsic-max) + (define (list-xtail ls n) + (if (or (null? ls) (fx= n 0)) + ls + (list-xtail (cdr ls) (fx1- n)))) + (define dorest-intrinsics + (let () + (define-syntax dorests + (lambda (x) + #`(vector #,@ + (let f ([i 0]) + (if (fx> i dorest-intrinsic-max) + '() + (cons #`(make-intrinsic + (lookup-libspec #,(construct-name #'k "dorest" i)) + (lambda () (reg-list %ac0 %xp %ts %td)) + (lambda () (reg-cons* %ac0 (list-xtail arg-registers #,i))) + (lambda () (let ([ls (list-xtail arg-registers #,i)]) (if (null? ls) '() (list (car ls)))))) + (f (fx+ i 1)))))))) + dorests))) + +(define-record-type info-alloc + (nongenerative #{info-alloc bcpkdd2y9yyv643zicd4jbe3y-9}) + (parent info) + (sealed #t) + (fields tag save-flrv? save-ra?)) + +(define-record-type info-foreign + (nongenerative #{info-foreign bcpkdd2y9yyv643zicd4jbe3y-10}) + (parent info) + (sealed #t) + (fields conv* arg-type* result-type unboxed? (mutable name)) + (protocol + (lambda (pargs->new) + (lambda (conv* arg-type* result-type unboxed?) + ((pargs->new) conv* arg-type* result-type unboxed? #f))))) + +(define-record-type info-literal + (nongenerative #{info-literal bcpkdd2y9yyv643zicd4jbe3y-11}) + (parent info) + (sealed #t) + (fields indirect? type addr offset)) + +(define-record-type info-lea + (nongenerative #{info-lea bcpkdd2y9yyv643zicd4jbe3y-12}) + (parent info) + (sealed #t) + (fields offset)) + +(define-record-type info-load + (nongenerative #{info-load bcpkdd2y9yyv643zicd4jbe3y-13}) + (parent info) + (sealed #t) + (fields type swapped?)) + +(define-record-type info-condition-code + (nongenerative #{info-condition-code bcpkdd2y9yyv643zicd4jbe3y-14}) + (parent info) + (sealed #t) + (fields type reversed? invertible?)) + +(define-record-type info-c-simple-call + (nongenerative #{info-c-simple-call bcpkdd2y9yyv643zicd4jbe3y-15}) + (parent info-kill*-live*) + (sealed #t) + (fields save-ra? entry) + (protocol + (lambda (new) + (case-lambda + [(save-ra? entry) ((new '() '()) save-ra? entry)] + [(live* save-ra? entry) ((new '() live*) save-ra? entry)])))) + +(define-record-type info-c-return + (nongenerative #{info-c-return bcpkdd2y9yyv643zicd4jbe3y-16}) + (parent info) + (sealed #t) + (fields offset)) + +(define-record-type info-inline + (nongenerative #{info-inline bcpkdd2y9yyv643zicd4jbe3y-17}) + (parent info) + (sealed #t) + (fields)) + +(define-record-type info-unboxed-args + (nongenerative #{info-unboxed-args bcpkdd2y9yyv643zicd4jbe3y-18}) + (parent info) + (fields unboxed?*)) diff --git a/racket/src/ChezScheme/s/np-languages.ss b/racket/src/ChezScheme/s/np-languages.ss index eab5f30c35..91bdeb1f57 100644 --- a/racket/src/ChezScheme/s/np-languages.ss +++ b/racket/src/ChezScheme/s/np-languages.ss @@ -87,13 +87,13 @@ (define-record-type var (fields (mutable index) (mutable spillable-conflict*) (mutable unspillable-conflict*)) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-1}) (protocol (lambda (new) (lambda () (new #f #f #f))))) (define-record-type (fv $make-fv fv?) (parent var) (fields offset type) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-2}) (sealed #t) (protocol (lambda (pargs->new) @@ -108,7 +108,7 @@ (define-record-type reg (parent var) (fields name mdinfo tc-disp callee-save? type (mutable precolored)) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-3}) (sealed #t) (protocol (lambda (pargs->new) @@ -181,7 +181,7 @@ (mutable save-weight) ; must be a fixnum! (mutable live-count) ; must be a fixnum! ) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-4}) (sealed #t) (protocol (lambda (pargs->new) @@ -232,7 +232,8 @@ (eq-hashtable-set! ht x sym) sym))))) - (define-record-type info (nongenerative)) + (define-record-type info + (nongenerative #{info n93q6qho9id46fha8itaytldd-5})) (define null-info (make-info)) @@ -242,12 +243,12 @@ (fprintf p "#")))) (define-record-type label - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-6}) (fields name)) (define-record-type libspec-label (parent label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-7}) (sealed #t) (fields libspec live-reg*) (protocol @@ -259,7 +260,7 @@ ; different purposes in different passes. (define-record-type local-label (parent label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-8}) (fields (mutable func) (mutable offset) (mutable iteration) (mutable block) ; following used by place-overflow-and-trap-check pass (mutable overflow-check) (mutable trap-check)) @@ -270,7 +271,7 @@ (define-record-type direct-call-label (parent local-label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-9}) (sealed #t) (fields (mutable referenced)) (protocol @@ -280,7 +281,7 @@ (define-record-type return-point-label (parent local-label) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-10}) (sealed #t) (fields (mutable compact?)) (protocol @@ -319,6 +320,7 @@ ; records, and make sure other record types have been discarded. also formally sets up ; CaseLambdaClause as entry point for language. (define-language L1 + (nongenerative-id #{L1 jczowy6yjfz400ntojb6av7y0-1}) (terminals (uvar (x)) (datum (d)) @@ -356,24 +358,28 @@ ; introducing let (define-language L2 (extends L1) + (nongenerative-id #{L2 jczowy6yjfz400ntojb6av7y0-2}) (entry CaseLambdaExpr) (Expr (e body) (+ (let ([x e] ...) body)))) ; removes moi; also adds name to info-lambda & info-foreign (define-language L3 (extends L2) + (nongenerative-id #{L3 jczowy6yjfz400ntojb6av7y0-3}) (entry CaseLambdaExpr) (Expr (e body) (- (moi)))) ; removes assignable indefinite-extent variables from the language (define-language L4 (extends L3) + (nongenerative-id #{L4 jczowy6yjfz400ntojb6av7y0-4}) (entry CaseLambdaExpr) (Expr (e body) (- (set! x e)))) ; introducing mvlet, and mvcall (define-language L4.5 (extends L4) + (nongenerative-id #{L4.5 jczowy6yjfz400ntojb6av7y0-4.5}) (terminals (+ (label (l)) (maybe-label (mdcl)) @@ -387,6 +393,7 @@ ; removes foreign, adds foreign-call, updates fcallable (define-language L4.75 (extends L4.5) + (nongenerative-id #{L4.75 jczowy6yjfz400ntojb6av7y0-4.75}) (entry CaseLambdaExpr) (Expr (e body) (- (foreign info e) @@ -397,6 +404,7 @@ ; adds loop form (define-language L4.875 (extends L4.75) + (nongenerative-id #{L4.875 jczowy6yjfz400ntojb6av7y0-4.875}) (entry CaseLambdaExpr) (Expr (e body) (+ (loop x (x* ...) body) => (loop x body)))) @@ -411,6 +419,7 @@ ; exposes continuation-attachment operations (define-language L4.9375 (extends L4.875) + (nongenerative-id #{L4.9375 jczowy6yjfz400ntojb6av7y0-4.9375}) (terminals (+ (attachment-op (aop))) (+ (continuation-op (cop))) @@ -425,12 +434,14 @@ ; moves all case lambda expressions into rhs of letrec (define-language L5 (extends L4.9375) + (nongenerative-id #{L5 jczowy6yjfz400ntojb6av7y0-5}) (entry CaseLambdaExpr) (Expr (e body) (- le))) ; replaces letrec with labels and closures forms (define-language L6 (extends L5) + (nongenerative-id #{L6 jczowy6yjfz400ntojb6av7y0-6}) (terminals (+ (maybe-var (mcp)))) (entry CaseLambdaExpr) @@ -449,6 +460,7 @@ ; move labels to top level and expands closures forms to more primitive operations (define-language L7 (extends L6) + (nongenerative-id #{L7 jczowy6yjfz400ntojb6av7y0-7}) (terminals (- (uvar (x)) (fixnum (interface))) @@ -486,7 +498,7 @@ (define-record-type primitive (fields name type pure? (mutable handler)) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-11}) (sealed #t) (protocol (lambda (new) @@ -519,7 +531,7 @@ [(_ name type pure?) (with-syntax ([%name (construct-name #'name "%" #'name)]) #'(begin - (define %name (make-primitive 'name 'type pure?)) + (define-once %name (make-primitive '%name 'type pure?)) (export %name)))]))) (define-syntax %primitive @@ -672,6 +684,7 @@ ; '(), (eof-object), ($unbound-object), #!bwp, characters, and fixnums as ; scheme-object ptrs and inlines primitive calls (define-language L9 (extends L7) + (nongenerative-id #{L9 jczowy6yjfz400ntojb6av7y0-9}) (entry Program) (terminals (- (datum (d)) @@ -686,6 +699,7 @@ ; determine where we should be placing interrupt and overflow (define-language L9.5 (extends L9) + (nongenerative-id #{L9.5 jczowy6yjfz400ntojb6av7y0-9.5}) (entry Program) (terminals (+ (boolean (ioc)))) @@ -695,6 +709,7 @@ ; remove the loop form (define-language L9.75 (extends L9.5) + (nongenerative-id #{L9.75 jczowy6yjfz400ntojb6av7y0-9.75}) (entry Program) (Expr (e body) (- (loop x (x* ...) body)))) @@ -706,6 +721,7 @@ ; Rhs expressions can appear on the right-hand-side of a set! or anywhere arbitrary ; Exprs can appear. Exprs appear in the body of a case-lambda clause. (define-language L10 (extends L9.75) + (nongenerative-id #{L10 jczowy6yjfz400ntojb6av7y0-10}) (terminals (+ (uvar (local)))) (entry Program) @@ -751,6 +767,7 @@ (set! lvalue rhs)))) (define-language L10.5 (extends L10) + (nongenerative-id #{L10.5 jczowy6yjfz400ntojb6av7y0-10.5}) (entry Program) (Rhs (rhs) (- (call info mdcl (maybe t0) t1 ...) @@ -768,6 +785,7 @@ ; labels used as arguments to make-closure, closure-ref, and closure-set! are ; marked as literals so they will not be turned into scheme constants again. (define-language L11 (extends L10.5) + (nongenerative-id #{L11 jczowy6yjfz400ntojb6av7y0-11}) (terminals (- (primitive (prim))) (+ (value-primitive (value-prim)) @@ -831,6 +849,7 @@ (tail tl)))) (define-language L12 (extends L11) + (nongenerative-id #{L12 jczowy6yjfz400ntojb6av7y0-12}) (terminals (- (fixnum (interface offset)) (label (l))) @@ -854,6 +873,7 @@ (mverror-point)))) (define-language L12.5 (extends L12) + (nongenerative-id #{L12.5 jczowy6yjfz400ntojb6av7y0-12.5}) (entry Program) (terminals (- (boolean (ioc)))) @@ -869,6 +889,7 @@ ; longer have arguments; case-lambda is resposible for dispatching to correct ; clause, even when the game is being played (define-language L13 + (nongenerative-id #{L13 jczowy6yjfz400ntojb6av7y0-13}) (terminals (fixnum (max-fv offset)) (fv (fv)) @@ -943,6 +964,7 @@ (goto l))) (define-language L13.5 (extends L13) + (nongenerative-id #{L13.5 jczowy6yjfz400ntojb6av7y0-13.5}) (terminals (- (symbol (sym)))) (entry Program) @@ -950,6 +972,7 @@ (- (hand-coded sym)))) (define-language L14 (extends L13.5) + (nongenerative-id #{L14 jczowy6yjfz400ntojb6av7y0-14}) (entry Program) (Rhs (rhs) (- (alloc info t)))) @@ -968,7 +991,7 @@ (mutable loop-headers) (mutable index) (mutable weight)) - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-12}) (protocol (lambda (new) (lambda () @@ -983,7 +1006,7 @@ (loop-header #b100000)) (define-record-type live-info - (nongenerative) + (nongenerative #{var n93q6qho9id46fha8itaytldd-13}) (sealed #t) (fields (mutable live) @@ -1002,6 +1025,7 @@ (fprintf p "#" (live-info-live x)))))) (define-language L15a + (nongenerative-id #{L15a jczowy6yjfz400ntojb6av7y0-15a}) (terminals (var (x cnfv var)) (reg (reg)) @@ -1057,6 +1081,7 @@ (asm-c-return info reg* ...))) (define-language L15b (extends L15a) + (nongenerative-id #{L15b jczowy6yjfz400ntojb6av7y0-15b}) (terminals (- (var (x cnfv var)) (reg (reg)) @@ -1090,6 +1115,7 @@ (eq? (uvar-type x) 'fp))))) (define-language L15c (extends L15b) + (nongenerative-id #{L15c jczowy6yjfz400ntojb6av7y0-15c}) (terminals (- (var (x var))) (+ (ur (x)))) @@ -1101,6 +1127,7 @@ (- (fp-offset live-info imm)))) (define-language L15d (extends L15c) + (nongenerative-id #{L15d jczowy6yjfz400ntojb6av7y0-15d}) (terminals (- (pred-primitive (pred-prim)) (value-primitive (value-prim)) @@ -1129,6 +1156,7 @@ (+ (jump t)))) (define-language L15e (extends L15d) + (nongenerative-id #{L15e jczowy6yjfz400ntojb6av7y0-15e}) (terminals (- (ur (x))) (+ (reg (x)))) @@ -1142,6 +1170,7 @@ (+ (set! lvalue rhs)))) (define-language L16 (extends L15e) + (nongenerative-id #{L16 jczowy6yjfz400ntojb6av7y0-16}) (entry Program) (Effect (e) (- (overflow-check p e* ...)))) diff --git a/racket/src/ChezScheme/s/np-register.ss b/racket/src/ChezScheme/s/np-register.ss new file mode 100644 index 0000000000..7f0a689d14 --- /dev/null +++ b/racket/src/ChezScheme/s/np-register.ss @@ -0,0 +1,180 @@ +(define-syntax architecture + (let ([fn (format "~a.ss" (constant architecture))]) + (with-source-path 'architecture fn + (lambda (fn) + (let* ([p ($open-file-input-port 'include fn)] + [sfd ($source-file-descriptor fn p)] + [p (transcoded-port p (current-transcoder))]) + (let ([do-read ($make-read p sfd 0)]) + (let* ([regs (do-read)] [inst (do-read)] [asm (do-read)]) + (when (eof-object? asm) ($oops #f "too few expressions in ~a" fn)) + (unless (eof-object? (do-read)) ($oops #f "too many expressions in ~a" fn)) + (close-input-port p) + (lambda (x) + (syntax-case x (registers instructions assembler) + [(k registers) (datum->syntax #'k regs)] + [(k instructions) (datum->syntax #'k inst)] + [(k assembler) (datum->syntax #'k asm)]))))))))) + +(define-syntax define-reserved-registers + (lambda (x) + (syntax-case x () + [(_ [regid alias ... callee-save? mdinfo type] ...) + (syntax-case #'(regid ...) (%tc %sfp) [(%tc %sfp . others) #t] [_ #f]) + #'(begin + (begin + (define-once regid (make-reg 'regid 'mdinfo (tc-disp regid) callee-save? 'type)) + (module (alias ...) (define x regid) (define alias x) ...)) + ...)]))) + +(define-syntax define-allocable-registers + (lambda (x) + (assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max))) + (syntax-case x () + [(_ regvec arg-registers extra-registers extra-fpregisters with-initialized-registers + [regid reg-alias ... callee-save? mdinfo type] ...) + (with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...) (extra-fpregid ...)) + (syntax-case #'([regid type] ...) (%ac0 %xp %ts %td uptr) + [([%ac0 _] [%xp _] [%ts _] [%td _] [other other-type] ...) + (let f ([other* #'(other ...)] + [other-type* #'(other-type ...)] + [rtc-disp* '()] + [arg-offset (constant tc-arg-regs-disp)] + [fp-offset (constant tc-fpregs-disp)] + [rextra* '()] + [rfpextra* '()]) + (if (null? other*) + (cond + [(not (fx= (length rextra*) (constant asm-arg-reg-max))) + (syntax-error x (format "asm-arg-reg-max extra registers are not specified ~s" (syntax->datum rextra*)))] + [(not (fx= (length rfpextra*) (constant asm-fpreg-max))) + (syntax-error x (format "asm-fpreg-max extra registers are not specified ~s" (syntax->datum rfpextra*)))] + [else + (let ([extra* (reverse rextra*)] + [fpextra* (reverse rfpextra*)]) + (list + (list* + (constant tc-ac0-disp) + (constant tc-xp-disp) + (constant tc-ts-disp) + (constant tc-td-disp) + (reverse rtc-disp*)) + (list-head extra* (constant asm-arg-reg-cnt)) + (list-tail extra* (constant asm-arg-reg-cnt)) + fpextra*))]) + (let ([other (car other*)]) + (if (memq (syntax->datum other) '(%ac1 %yp %cp %ret)) + (f (cdr other*) (cdr other-type*) (cons #`(tc-disp #,other) rtc-disp*) + arg-offset fp-offset rextra* rfpextra*) + (if (eq? (syntax->datum (car other-type*)) 'fp) + (f (cdr other*) (cdr other-type*) (cons fp-offset rtc-disp*) + arg-offset (fx+ fp-offset (constant double-bytes)) rextra* (cons other rfpextra*)) + (f (cdr other*) (cdr other-type*) (cons arg-offset rtc-disp*) + (fx+ arg-offset (constant ptr-bytes)) fp-offset (cons other rextra*) rfpextra*))))))] + [_ (syntax-error x "missing or out-of-order required registers")])] + [(regid-loc ...) (generate-temporaries #'(regid ...))]) + #'(begin + (define-syntax define-squawking-parameter + (syntax-rules () + [(_ (id (... ...)) loc) + (begin + (define-once loc (id (... ...)) ($make-thread-parameter #f)) + (define-syntax id + (lambda (q) + (unless (identifier? q) (syntax-error q)) + #`(let ([x (loc)]) + (unless x (syntax-error #'#,q "uninitialized")) + x))) + (... ...))] + [(_ id loc) (define-squawking-parameter (id) loc)])) + (define-squawking-parameter (regid reg-alias ...) regid-loc) + ... + (define-squawking-parameter regvec regvec-loc) + (define-squawking-parameter arg-registers arg-registers-loc) + (define-squawking-parameter extra-registers extra-registers-loc) + (define-squawking-parameter extra-fpregisters extra-fpregisters-loc) + (define-syntax with-initialized-registers + (syntax-rules () + [(_ b1 b2 (... ...)) + (parameterize ([regid-loc (make-reg 'regid 'mdinfo tc-disp callee-save? 'type)] ...) + (parameterize ([regvec-loc (vector regid ...)] + [arg-registers-loc (list arg-regid ...)] + [extra-registers-loc (list extra-regid ...)] + [extra-fpregisters-loc (list extra-fpregid ...)]) + (let () b1 b2 (... ...))))]))))]))) + +(define-syntax define-machine-dependent-registers + (lambda (x) + (syntax-case x () + [(_ [regid alias ... callee-save? mdinfo type] ...) + #'(begin + (begin + (define-once regid (make-reg 'regid 'mdinfo #f callee-save? 'type)) + (module (alias ...) (define x regid) (define alias x) ...)) + ...)]))) + +(define-syntax define-registers + (lambda (x) + (syntax-case x (reserved allocable machine-dependent) + [(k (reserved [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) + (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) + (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...)) + (with-implicit (k regvec arg-registers extra-registers extra-fpregisters real-register? with-initialized-registers) + #`(begin + (define-reserved-registers [rreg rreg-alias ... rreg-callee-save? rreg-mdinfo rreg-type] ...) + (define-allocable-registers regvec arg-registers extra-registers extra-fpregisters with-initialized-registers + [areg areg-alias ... areg-callee-save? areg-mdinfo areg-type] ...) + (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo mdreg-type] ...) + (define-syntax real-register? + (with-syntax ([real-reg* #''(rreg ... rreg-alias ... ... areg ... areg-alias ... ... mdreg ... mdreg-alias ... ...)]) + (syntax-rules () + [(_ e) (memq e real-reg*)])))))]))) + +(architecture registers) + +; pseudo register used for mref's with no actual index +(define-once %zero (make-reg 'zero #f #f #f #f)) + +;; define %ref-ret to be sfp[0] on machines w/no ret register +;; +;; The ret register, if any, is used to pass a return address to a +;; function. All functions currently stash the ret register in +;; sfp[0] and return to sfp[0] instead of the ret register, so the +;; register doesn't have to be saved and restored for non-tail +;; calls --- so use sfp[0] instead of the ret registerr to refer +;; to the current call's return address. (A leaf procedure could +;; do better, but doesn't currently.) +(define-syntax %ref-ret + (lambda (x) + (meta-cond + [(real-register? '%ret) #'%ret] + [else (with-syntax ([%mref (datum->syntax x '%mref)]) + #'(%mref ,%sfp 0))]))) + +(define-syntax reg-cons* + (lambda (x) + (syntax-case x () + [(_ ?reg ... ?reg*) + (fold-right + (lambda (reg reg*) + (cond + [(real-register? (syntax->datum reg)) + #`(cons #,reg #,reg*)] + [else reg*])) + #'?reg* #'(?reg ...))]))) + +(define-syntax reg-list + (syntax-rules () + [(_ ?reg ...) (reg-cons* ?reg ... '())])) + +(define-syntax with-saved-ret-reg + (lambda (x) + (syntax-case x () + [(k ?e) + (if (real-register? '%ret) + (with-implicit (k %seq %mref) + #'(%seq + (set! ,(%mref ,%sfp 0) ,%ret) + ,?e + (set! ,%ret ,(%mref ,%sfp 0)))) + #'?e)]))) diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index 19952a1102..ea89d57507 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -2274,6 +2274,8 @@ ($np-last-pass [flags single-valued]) ($np-reset-timers! [flags single-valued]) ($np-tracer [flags single-valued]) + ($np-expand-primitives [flags single-valued]) + ($np-next-lambda-seqno [flags single-valued]) ($null-continuation [flags single-valued]) ($object-address [flags single-valued]) ($object-in-heap? [sig [(ptr) -> (boolean)]] [flags discard])