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])