Chez Scheme: split cpprim out of cpnanopass

Moving the np-expand-primtives pass to a separately compiled source
file reduces peak memory use when compiling Chez Scheme from about 1.3
GB to about 0.7 GB on a 64-bit platform. It's also nice from a
code-navigation perspective to split a 19k-line file to a 10k-line
file plus 8k-line file (and some additional small files).

The overall time for Chez Scheme to compile itself is only slightly
affected, even though some support functions, macros, and record
declarations end up getting compiled twice.

racket/src/ChezScheme/IMPLEMENTATION.md

@@ -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
+"cpprim.ss" for that part of the compiler. The content of "prims.ss"
-"prims.ss" is compiled in unsafe mode, so that's why safe mode needs
+is compiled in unsafe mode, so that's why safe mode needs to be
-to be selected explicitly when needed.
+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
+ * and then compiles to machine code (see "cpnanopass.ss" and
-   involves many individual passes that convert through many different
+   "cpprim.ss"), which involves many individual passes that convert
-   intermediate forms (see "np-language.ss").
+   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

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

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

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

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?*))

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 "#<info>"))))
 
   (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 ~s>" (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* ...))))

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

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