Merge tag 'upstream/7.8' into dfsg

leave deleted files deleted.

109 files changed, 11463 insertions, 3096 deletions

diff --git a/src/ChezScheme/IMPLEMENTATION b/src/ChezScheme/IMPLEMENTATION
new file mode 100644
index 0000000000..e42e7f9288
--- /dev/null
+++ b/src/ChezScheme/IMPLEMENTATION
@@ -0,0 +1,812 @@
+Getting Started
+---------------
+
+Most of the Chez Scheme implementation is in the "s" directory. The
+C-implemented kernel is in the "c" directory.
+
+Some key files in "s":
+
+ * "cmacro.ss": object layouts and other global constants
+
+ * "syntax.ss": the macro expander
+
+ * "cpnanopass.ss": the main compiler
+
+ * "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"
+
+ * "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"
+
+Scheme Objects
+--------------
+
+A Scheme object is represented at run time by a pointer. The low bits
+of the pointer indicate the general type of the object, such as "pair"
+or "closure". The memory referenced by the pointer may have an
+additional tag word to further refine the pointer-tag type.
+
+See also:
+
+  Don't Stop the BiBOP: Flexible and Efficient Storage Management for
+  Dynamically Typed Languages.
+  R. Kent Dybvig, David Eby, and Carl Bruggeman.
+  Indiana University TR #400, 1994.
+
+For example, if "cmacro.ss" says
+
+  (define-constant type-pair         #b001)
+
+then that means an address with only the lowest bit set among the low
+three bits refers to a pair. To get the address where the pair content
+is stored, round *up* to the nearest word. So, on a 64-bit machine,
+add 7 to get to the `car` and add 15 to get to the `cdr`. Since
+allocation on a 64-byte machine is 16-byte aligned, the hexadecimal
+form of every pair pointer will end in "9".
+
+The `type-typed-object` type,
+
+ (define-constant type-typed-object #b111)
+
+refers to an object whose first word indicates its type. In the case
+of a Scheme record, that first word will be a record-type descriptor
+--- that is, a pointer to a record type, which is itself represented
+as a record. The based record type, `#!base-rtd` has itself as its
+record type. Since the type bits are all ones, on a 64-bit machine,
+every object tagged with an additional type workd will end in "F" in
+hexadecimal, and adding 1 to the pointer produces the address
+containing the record content (which starts with the rrecord type, so
+add 9 instead to get to the first field in the record).
+
+As another example, a vector is represented as `type-typed-object`
+pointer where the first word is a fixnum. That is, a fixnum used a
+type word indicates a vector. The fixnum value is the vector's length
+in wordobjects, but shifted up by 1 bit, and then the low bit is set
+to 1 for an immutable vector.
+
+Most kinds of Scheme values are represented records, so the layout is
+defined by `define-record-type` and similar. For the primitive object
+types that are not records (and even a few that are), the layouts are
+defined in "camcros.ss". For example, an `exactnum` (i.e., a complex
+number with exact real and imaginary components) is defined as
+
+ (define-primitive-structure-disps exactnum type-typed-object
+   ([iptr type]
+    [ptr real]
+    [ptr imag]))
+
+The `type-typed-object` in the first line indicates that an exactnum
+is represented by a pointer that is tagged with `type-typed-object`,
+and so we should expect the first first to be a type word. That's why
+the first field above is `type`, and it turns out that it will always
+contain the value `type-inexactnum`. The `iptr` type for `type` means
+"a pointer-sized signed integer". The `ptr` type for `real` and `imag`
+means "pointer" or "Scheme object".
+
+Functions and Calls
+-------------------
+
+Scheme code does not use the C stack, except to the degree that it
+interacts with C functions. Instead, the Scheme continuation is a
+separate, heap-allocated, linked list of stack segments. Locally, you
+can just view the continuatiton as a stack and assume that overflow
+and continuation operations are handled as needed at the boundaries.
+
+See also:
+ 
+ Representing Control in the Presence of First-Class Continuations.
+ Robert Hieb, R. Kent Dybvig, and Carl Bruggeman.
+ Programming Language Design and Implementation, 1990.
+
+ Compiler and Runtime Support for Continuation Marks.
+ Matthew Flatt and R. Kent Dybvig.
+ Programming Language Design and Implementation, 2020.
+
+To the degree that the runtime system needs global state, that state
+is in the thread context (so, it's thread-local), which we'll
+abbreviate as "TC". Some machine register is desgined as the `%tc`
+register, and it's initialized on entry to Scheme code. For the
+defintion of TC, see `(define-primitive-structure-disps tc ...)` in
+"cmacro.ss".
+
+The first several fields of TC are virtual registers that may be
+assigned to machine registers, in which case the TC and registers are
+synced on entry and exit from Scheme code, including when calling
+kernel functionality from Scheme code. In particular, the SFP (Scheme
+frame pointer) virtual register must be assigned to a real register,
+because it's the Scheme stack pointer. The TC and SFP registers are
+the only two that absolutely must be registers, but AP (allocation
+pointer) and TRAP registers are also good candidates on architectures
+where plenty of registers are available.
+
+The Scheme stack grows up, and SFP points to the beginning (i.e., the
+low address) of the current stack frame. The first word of a stack
+frame is the return address, so a frame looks like this:
+
+                ^
+                |          (higher addresses)
+              future
+              frames
+          |------------|
+          |   var N    |
+          |------------|
+          |     ...    | ....
+          |------------|
+          |   var 1    | SFP[1]
+          |------------|
+          |  ret addr  | SFP[0]
+ SFP ->   |------------|
+             previous
+              frames 
+                |          (lower addresses)
+                v
+
+On entry to a Scheme function, a check ensures that the difference
+between SFP and the end of the current stack segment is big enough to
+accomodate the (spilled) variables of the called function, plus enough
+slop to deal with some primitive operations.
+
+A non-tail call moves SFP past all the live variables of the current
+function, installs the return address as as pointer within the current
+function, and then jumps to the called function. Function calls and
+returns do not use machine "call" and "return" instructions;
+everything is just a "jump". ("Call" and "return" instructions are
+used for for C interactions.) It's the caller's responsibity to reset
+SFP back on return, since the caller knows how much it moved SFP
+before calling.
+
+The compiler can use a register for the return address instead of
+immediately installing it in SFP[0] on a call. That mode is triggered
+by giving one of the regisers the name `%ret` (as described in
+"Machine Registers" below). Currently, however, the called Scheme
+function will immediatelly copy the register into SFP[0], and it will
+always return by jumping to SFP[0]. So, until the compiler improves to
+deal with leaf functions differently, using a return register can help
+only with hand-coded leaf functions that don't immediately move the
+return register into SFP[0].
+
+There are two ways that control transitions from C to Scheme: an
+initial call through `S_generic_invoke` (see "scheme.c") or via a
+foreign callable. Both of those go through `S_call_help` (see
+"schlib.c"). The `S_generic_invoke` function calls `S_call_help`
+directly. A foreign callable is represented by generated code that
+converts arguments and then calls `S_call_help` to run the Scheme
+procedure that is wrapped by the callable.
+
+The `S_call_help` function calls the hand-coded `invoke` code (see
+"cpnanopass.ss"). The `invoke` code sets things up for the Scheme
+world and jumps to the target Scheme function. When control returns
+from the called Scheme function back to `invoke`, `invoke` finishes
+not with a C return, but by calling `S_return` (see "schlib.c"), which
+gets back to `S_call_help` through a longjmp. The indirect return
+through longjmp helps the Scheme stack and C stack be independent,
+which is part of how Scheme continuations interact with foreign
+functions.
+
+For a non-tail call in Scheme, the return address is not right after
+the jump instruction for the call. Instead, the return address is a
+little later, and there's some data just before that return address
+that describes the calling function's stack frame. The GC needs that
+information, for example, to know which part of the current Scheme
+stack is populated by live variables. The data is represented by
+either the `rp-header` or `rp-compact-header` (see "cmacro.ss") shape.
+So, when you disassemble code generated by the Chez Scheme compiler,
+you may see garbage instructions mingled with the well-formed
+instructions, but the garbage will always be jumped over.
+
+Compilation Pipeline
+--------------------
+
+Compilation
+
+ * starts with an S-expression (possibly with annotations for source
+   locations),
+
+ * converts it to a syntax object (see "syntax.ss"),
+
+ * expands macros (see "syntax.ss") and produces an `Lsrc`
+   representation in terms of core forms (see `Lsrc` in
+   "base-lang.ss"),
+
+ * 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").
+
+See also:
+
+   Nanopass compiler infrastructure.
+   Dipanwita Sarkar.
+   Indiana University PhD dissertation, 2008
+
+   A Nanopass Framework for Commercial Compiler Development.
+   Andrew W. Keep.
+   Indiana University PhD dissertation, 2013
+
+Note that the core macro expander always converts its input to the
+`Lsrc` intermediate form. That intermediate form can be converted back
+to an S-expression (see "uncprep.ss", whose name you should parse as
+"undo-compilerpass-representation").
+
+In the initial intermediate form, `Lsrc`, all primitive operations are
+represented as calls to functions. In later passes in "cpnanopass.ss",
+some primitive operations get inlined into a combination of core
+forms, some of which are `inline` forms. The `inline` forms eventually
+get delivered to a backend for instruction selection. For example, a
+use of safe `fx+` is inlines as argument checks that guard an `(inline
++ ...)`, and the `(inline + ...)` eventually becomes a machine-level
+addition instruction.
+
+Machine Registers
+-----------------
+
+Each backend file, such as "x86_64.ss" or "arm64.ss", starts with a
+description of the machine's registers. It has three parts in
+`define-registers`:
+
+(define-registers
+  (reserved
+    <reg>
+    ...)
+  (allocable
+    <reg>
+    ...)
+  (machine-dependent
+    <reg>
+    ...))
+
+Each <reg> has the form
+
+    [<name> ... <preserved? / callee-saved?> <num> <type>]
+
+ * The <name>s in one <reg> will all refer to the same register, and
+   the first <name> is used as the canonical name. By convention, each
+   <name> starts with `%`. The compiler gives specific meaning to a
+   few names listed below, and a backend can use any names otherwise.
+
+ * The information on preserved (i.e, callee-saved) registers helps
+   the compiler save registers as needed before some C interactons.
+
+ * The <num> value is for the private use of the backend. Typically,
+   it corresponds to the register's representation within machine
+   instructions.
+
+ * The <type> is either 'uptr or 'fp, indicating whether the register
+   holds a pointer/integer value (i.e., an unsigned integer that is
+   the same size as a pointer) or a floating-point value. For
+   `allocatable` registers, the different types of registers represent
+   different allocation pools.
+
+The `reserved` section describes registers that the compiler needs and
+that will be used only for a designated purpose. The registers will
+never be allocated to Scheme variables in a compiled function. The
+`reserved` section must start with `%tc` and `%sfp`, and it must list
+only registers with a recognized name as the canonical name.
+
+The `machine-dependent` section describes additional registers that
+also will not be allocated. They are also not saved automatically for
+C interactions.
+
+The `allocable` section describes registers that may be mapped to
+specific purposes by using a recognized canonical name, but generally
+these registers are allocated as needed to hold Scheme variables and
+temporaries (including registers with recognized names in situations
+where the recognized purpose is not needed). Registers in this
+category are automatically saved as needed for C interactions.
+
+The main recognized register names, roughly in order of usefulness as
+real machine registers:
+
+ %tc - the first reserved register, must be mapped as reserved
+ %sfp - the second reserved register, must be mapped as reserved
+ %ap - allocation pointer (for fast bump allocation)
+ %trap - counter for when to check signals, including GC signal
+
+ %eap - end of bump-allocatable region
+ %esp - end of current stack segment
+
+ %cp - used for a procedure about to be called
+ %ac0 - used for argument count and call results
+ 
+ %ac1 - various scratch and communication purposes
+ %xp  - ditto
+ %yp  - ditto
+
+Each of the registers maps to a slot in the TC, so they are sometimes
+used to communicate between compiled code and the C-implemented
+kernel. For example, `S_call_help` expects the function to be called
+in AC1 with the argument count in AC0 (as usual).
+
+A few more names are recognized to direct the compiler in different
+ways:
+
+ %ret - use a return register insteda of just SFP[0]
+
+ %reify1, %reify2 - a kind of manual allocation of registers for
+                    certain hand-coded routines, which otherwise could
+                    run out of registers to use
+
+Variables and Register Allocation
+---------------------------------
+
+A variables in Scheme code can be allocated either to a register or to
+a location in the stack frame, and the same goes for temporaries that
+are needed to evaluate subexpressions. Naturally, variables and
+temporaries with non-overlapping extents can be mapped to the same
+register or frame location. Currently, only variables with the same
+type, integer/pointer versus floating-point, can be allocated to the
+same frame location.
+
+An early pass in the compiler converts mutable variables to
+pair-valued immutable variables, but assignment to variables is still
+allowed within the compiler's representation. (The early conversion of
+mutables variables ensures that mutation is properly shared for, say,
+variables in captured continuations.) That is, even though variables
+and temporaries are typically assigned only once, the compiler's
+intermediate representation is not a single-asssignment form like
+SSA.
+
+Each variable or temporary will be allocated to one spot for it's
+whole lifetime. So, from the register-allocation perspective, it's
+better to use
+
+   (set! var1 ...)
+   ... var1 ...
+   ... code that doesn't use var1 ...
+   (set! var2 ...)
+   ... var2 ...
+
+than to reuse var1 like
+
+   (set! var1 ...)
+   ... var1 ...
+   ... code that doesn't use var1 ...
+   (set! var1 ...)
+   ... var1 ...
+
+Intermediate code in later passes of the compiler can also refer to
+registers directly, and those uses are taken into account by the
+register allocator.
+
+Overall, the allocator see several kinds of "variables":
+
+ * real registers;
+
+ * Scheme variables and temporaries as represented by `uvar`s, each of
+   which is eventually allocated to a real register or to a frame
+   location;
+
+ * unspillable varriables, each of which must be allocated to a real
+   register; these are introduced by a backend during the
+   instruction-selection pass, where an instruction may require a
+   register argument; and
+
+ * pre-colored unspillable variables, each which must be allocated to
+   a specific real register; these are introduced by a backend where
+   an instruction may require an argument in a specific registers.
+
+The difference between a pre-colored unspillable and just using the
+real register is that you declare intent to the register allocator,
+and it can sometimes tell you if things go wrong. For example,
+
+        (set! %r1 v1)
+        (set! must-be-r1 v2)
+        ... use %r1 and must-be-r1 ...
+
+has clearly gone wrong. In contrast, the register allocator thinks
+that
+
+        (set! %r1 v1)
+        (set! %r1 v2)
+        ... use %r1, sometimesexpecting v1 and sometimess v2 ...
+
+looks fine, and it may optimize away the first assignment. [Note:
+Optimized-away assignments are one of the most confusing potential
+results of register-use mistakes.]
+
+At the point where the register allocator runs, a Scheme program has
+been simplified to a sequence of assignment forms and expression
+forms, where the latter are either value-producing and sit on the
+right-hand side of an assignment or they are effectful and sit by
+themselves. The register allocator sees the first assignment to a
+variable/register as the beginning of its live range and the last
+reference as the end of its live range. In some cases, an instruction
+is written with "dummy" arguments just to expose the fact that it
+needs those arguments to stay live; for example, a jump instruction
+that implements a function-call return conceptually needs to consume
+the result-value registers (because those values need to stay live
+throgh the jump), even though the machine-level jump instruction
+doens't refer to the result values. The `kill` dummy instruction can
+be used with `set!` to indicate that a variable is trashed, but the
+`kill` is discarded after register allocation. It's also possible for
+an insstruction to produce results in multiple registers. So, besides
+using dummy arguments and `kill`, an instruction form can have a
+`info-kill*-live*` record attached to it, which lists the `kill*`
+variables that the expression effectively assigns and the `live*`
+variables that the expression effectively references. (Note: a `set!`
+form cannot itself have a `info-kill*-live*` record attached to it,
+because the info slot for `set!` be an `info-live` record that records
+computed live-variable information.)
+
+As a first pass, the register allocator can look at an intermediate
+instruction sequence and determine that there are too many live
+variables, so some of them need to be spilled. The register allocator
+does that before consulting the backend. So, some of the variables in
+the intermediate form will stay as `uvar`s, and some will get
+converted to a frame reference of them form SFP[pos]. When the backend
+is then asked to select an instruction for an operation that cosumes
+some variables and delivers a result to some destination variable, it
+may not be able to work with one or more of the arguments or
+destination in SFP[pos] form; in that case, it will create an
+unspillable and assign the SFP[pos] value to the unspillable, then use
+the unspillable in a generated instruction sequence. Of course,
+introducing unspillables may mean that some of the remaining `uvar`s`
+to no longer fit in registers after all; when that happens, the
+register allocator will discard the tentative instruction selection
+and try again after spilling for `uvar`s (which will then create even
+more unspillables locally, but those will have short lifetimes, so
+register allocation will eventually succeed). Long story short, the
+backend can assume that a `uvar` wil be replaced later by a register.
+
+When reading the compiler's implementation, `make-tmp` in most passes
+creates a `uvar` (that may eventually be spilled to a stack-frame
+slot). A `make-tmp` in the instruction-selection pass, however, makes
+an unspillable. In earlies passes of the compiler, new temporaries
+must be bound with a `let` form (i.e., a `let` in the intermediate
+repressentation) before they can be used; in later passes, a `set!`
+initializes a temporary.
+
+In all but the very earliest passes, an `mref` form represents a
+memory reference. Typically, a memory reference consistents of a
+variable and an offset. The general form is two variables and an
+offset, all of which are added to obtain an address, because many
+machine support indexed memory references of that form. The `%zero`
+pseudo-register is used as the second variable in an general `mref`
+when only one variable is needed. A variable or memory reference also
+has a type, 'uptr or 'fp, in the same way as a register. So, a
+variable of a given type may be allocated to a register of that type,
+or it may be spilled to a frame location and then referenced through
+an `%sfp`-based `mref` using that type. In early passes of the
+compiler, `mref`s can be nested and have computed pieces (such as
+calulating the offset), but a later pass will introduce temporaries to
+flatten `mref`s into just variable/register and immediate-integer
+components.
+
+A backend may introduce an unspillable to hold an `mref` value for
+various reasons: because the relevant instruction suports only one
+register plus an offset instead of two registers, because the offset
+is too big, because the offset does not have a required alignment, and
+so on.
+
+Instruction Selection: Compiler <-> Backend
+-------------------------------------------
+
+For each primitive that the compiler will reference via `inline`,
+there must be a `declare-primitive` in "np-language.ss". Each
+primitive is either an `effect`, a `value` that must be used on the
+right-hand side of a `set!` or a `pred` that must be used immediately
+in the test position of an `if` --- where `set!` and `if` here refer
+to forms in the input intermediate language of the
+instruction-selection compiler pass (see `L15c` in "np-languages.ss").
+Most primitives potentially correspond to a single machine
+instruction, but any of them can expand to any number of instructions.
+
+The `declare-primitive` form binds the name formed by adding a `%`
+prefix. So, for example,
+
+  (declare-primitive logand value #t)
+
+binds `%logand`. The `(%inline name ,arg ...)` macro expands to
+`(inline ,null-info ,%name ,arg ...)` macro, so that's why you don't
+usually see the `%` written out.
+
+The backend implementation of a prrimitive is a function that takes as
+many arguments as the `inline` form, plus an additional initial
+argument for the destination in the case of a `value` primitive on the
+right-hand side of a `set!`. The result of the primitive function is a
+list of instructions, where an instruction is either a `set!` or `asm`
+form in the output intermediate representation of the
+instruction-selection pass (see `L15d` in "np-languages.ss"). The
+`asm` form in the output language has a function that represents the
+instruction; that function again takes the arguments of the `asm`
+form, plus an extra leading argument for the destiination if it's on
+the right-hand side of a `set!` (plus an argument before that for the
+machine-code sequence following the instruction, and it returns an
+extended machine-code sequence; that is, a machine-code sequence is
+built end-to-start).
+
+An instruction procedure typically has a name prefixed with `asm-`.
+So, for example, the `%logand` primitive's implementation in the
+backend may produces a result that includes a reference to an
+`asm-logand` instruction procedure. Or maybe the machine instruction
+for logical "and" has a variant that sets condition codes and one that
+doesn't, and they're both useful, so `asm-logand` actually takes a
+curried bboolean to pick; in thatt case, `%logand` returns an
+instruction with `(asm-logand #f)`, which produces a function that
+takes the destination and `asm` arguments. Whether an argument to
+`asm-logand` is suitable for currying or inclusion as an `asm`
+argument depends on whether it makes sense in the `asm` grammar and
+whether it needs to be exposed for register allocation.
+
+The compiler may refer to some instructions directly. Of particular
+importance are `asm-move` and `asm-fpmove`, which are eventually used
+for `set!` forms after the instruction-selection pass. That is, the
+output of instruction selection still uses `set!`, and then those are
+converted to memory and register-moving instructions later. The
+instruction-selecton pass must ensure that any surving `set!`s are
+simple enough, though, to map to instructions without further register
+allocation. In other words, the backend instruction selector should
+only return `set!`s as instructions when they are simple enough, and
+it should generate code to simplify the ones that don't start out
+simple enough. To give the backend control over `set!`s in the *input*
+of instruction selection, those are send to the backend as `%move` and
+`%fpmove` primitives (which may simply turn back into `set!s` using
+the output language, or they may get simplified). When the compiler
+generates additional `set!`s after instruction selection, it generates
+only cnstrainted forms, where target or source `mref`s have a single
+register and a small, aligned offset.
+
+To organize all of this work, a backend implementation like
+"x86_64.ss" or "arm64.ss" must be organized into three parts, which
+are implemented by three S-expressions:
+
+ * `define-registers`
+
+ * a module that implements primitives (that convert to instructions),
+   installing them with `primitive-handler-set!`
+
+ * a module that implements instructions (that convert to machine
+   code), a.k.a. the "assembler", defining the instructions as
+   functions
+
+That last module must also implement a few things that apply earlier
+than assembling (or even instruction selection), notably including
+`asm-foreign-call` and `asm-foreign-callable`. For more on those two,
+see "Foreign Function ABI" below.
+
+To summarize the interface between the compiler and backend is:
+
+ primitive : L15c.Triv ... -> (listof L15d.Effect)
+
+ instruction : (listof code) L16.Triv ... -> (listof code)
+
+A `code` is mostly bytes to be emitted, but it also contains
+relocation entries and human-readable forms that are printed when
+assembly printing is enabled. The `aop-cons*` helper macro (in
+"cpnanopass.ss") is like `cons*`, but it skips its first argument if
+human-readable forms aren't being kept.
+
+Instruction Selection: Backend Structure
+----------------------------------------
+
+To further organize the work of instruction selection and assembly,
+all of the current backends use a particular internal structure:
+
+ * primitives are defined through a `define-instruction` form that
+   helps with pattern matching and automatic conversion/simplification
+   of arguments; and
+
+ * instructions are defined as functions that use an `emit` form,
+   which in turn dispatches to function that represent actual
+   machine-level operations, where the functions for machine-level
+   operations typically have names ending in `-op`.
+
+Consider the "arm64.ss" definition fo `%logand`, which should accept a
+destination (here called "z") and two arguments:
+
+  (define-instruction value (logand)
+    [(op (z ur) (x ur) (y funkymask))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))]
+    [(op (z ur) (x funkymask) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,y ,x))]
+    [(op (z ur) (x ur) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))])
+
+The A64 instruction set supports a logical "and" on either two
+registers or a register and an immediate, but the immediate value has
+to be representable with a funky encoding. The pattern forms above
+require that the destination is always a register/variable, and either
+of the arguments can be a literal that fits into the funky encoding or
+a register/variable. The `define-instruction` macro is itself
+implemented in "arm64.ss", so it can support specialized patterns like
+`funkymask`.
+
+If a call to this `%logand` function is triggered by a form
+
+  `(set! ,info (mref ,var1 ,%zero 8) ,var2 ,7)
+
+then the code generated by `define-instruction` will notice that the
+first argument is not a register/variable, while 7 does encode as a
+mask, so it will arrange to produce the same value as
+
+   (let ([u (make-tmp 'u)])
+      (list
+        (%logand u var2 7)
+        `(set! ,(make-live-info) (mref ,var1 ,%zero 8) ,u)))
+
+Then, the first case of `%logand` will match, and the result will be
+the same as
+
+   (let ([u (make-tmp 'u)])
+      (list
+        `(set! ,(make-live-info) ,u (asm,(asm-logand #f) ,var2 ,7)
+        `(set! ,(make-live-info) (mref ,var1 ,%zero 8) ,u))))
+
+If the offset 8 were instead a very large number, then auto-conversion
+would have to generate an `add` into a second temporary variable.
+Otherwise, `asm-move` would not be able to deal with the generated
+`set!` to move `u` into the destination. The implementation of
+`define-instruction` uses a `mem->mem` helper function to simplify
+`mref`s. In the "arm32.ss" backend, there's an additional `fpmem`
+pattern and `fpmem->fpmem` helper, because the constraints on memory
+references for floating-point operations are different than than the
+constraints on memory references to load an integer/pointer.
+
+Note that `%logand` generates a use of the same `(asm-logand #f)`
+instruction for the register--register and the register--immediate
+cases. A more explicit distinction could be made in the output of
+instruction selection, but delaying the choice is anologous to how
+assembly languages often use the same mnemonic for related
+instructions. The `asm-move` and `asm-fpmove` must accomodate
+register--memory, memory--register, and register--register cases,
+because `set!` forms after instruction selection can have those
+variants.
+
+The `asm-logand` instruction for "arm64.ss" is implemented as
+
+   (lambda (set-cc?)
+     (lambda (code* dest src0 src1)
+       (Trivit (dest src0 src1)
+          (record-case src1
+            [(imm) (n) (emit andi set-cc? dest src0 n code*)]
+            [else (emit and set-cc? and src0 src1 code*)]))))
+
+The `set-cc?` argument coresponds to the `#f` in `(asm-logand #f)`.
+The inner lambda reprsents the instruction --- that is, it's the
+function in an `asm` form. The function takes `code*` first, which is
+a list of machine codes for all instructions after the `asm-logand`.
+The `dest` argument corresponds to the result register, and `src0` and
+`src1` are the two arguments.
+
+The `Trivit` form is a bridge between intermediate languages. It takes
+variables that are boudn already and it rebinds them for the body of
+the `Trivit` form. Each rebinding translate the argument from an `L16`
+`Triv` record to a list that starts 'reg, 'disp, 'index, 'literal, or
+'literal@. (Beware of missing this step, and beware of backends that
+sometimes intentionally skip this step because the original is known
+to be, say, a register.)
+
+The `emit` form is defined in the "arm64.ss" backend and others, and
+it's just a kind of function call that cooperates with `define-op`
+declarations. For example, `(define-op andi logical-op arg1 ...)`
+binds `andi-op`, and `(emit andi arg2 ...)` turns into `(logical-op
+'and arg1 ... arg2 ...)`; that is, `andi-op` first receives the symbol
+'andi, then arguments listed at `define-op`, then arguments listed at
+`emit`. The last argument is conventionally `code*`, which is the code
+list to be extended with new code at its beginning (because the
+machine-code list is built end to start). The bounce from `andi-op` to
+`logicial-op` is because many instructions follow a similar encoding,
+such as different bitwise-logicial operations like `and` and `or`.
+Meanwhile, `logical-op` uses an `emit-code` form, which is also in
+"arm64.ss" and other backends, that calls `aop-cons` with a suitable
+human-readable addition.
+
+All of that could be done with just plain functions, but the macros
+help with boilerplate and arrange some helpful compile-time checking.
+
+Foreign Function ABI
+--------------------
+
+Support for foreign procedures and callables in Chez Scheme boils down
+to foriegn calls and callable stubs for the backend. A backend's
+`asm-foreign-call` and `asm-forieng-callbable` function receives an
+`info-foreign` record, which describes the argument and result types
+in relatively primitive forms:
+
+ * double
+ * float
+ * [signed] integer of {8,16,32,64} bits
+ * generic pointer or scheme-object (to treat as a generic pointer)
+ * a "&" form, which is a pointer on the Scheme side and by-value on
+   the C side, and can be a struct/union; layout info is reported
+   by `$ftd-...` helpers
+
+If the result type is a "&" type, then the function expects an extra
+first argument on the Scheme side. That extra argument is reflected by
+an extra pointer type at the statr of the argument list, but the "&"
+type is also left for the result type as an indication about that
+first argument. In other words, the result type is effectively
+duplicated in the result (matching the C view) and an argument
+(mathing the Scheme view) --- so, overall, the given type matches
+neither the C nor Scheme view, but either view can be reconstructed.
+
+The compiler creates wrappers to take care of further conversion
+to/from these primitive shapes.
+
+The `asm-foreign-call` function returns 5 values:
+
+ * allocate : -> L13.Effect
+
+   Any needed setup, such as allocating C stack space for arguments.
+
+ * c-args : (listof (uvar/reg -> L13.Effect))
+
+   Generate code to convert each argument. The generated code will be
+   in reverse order, with the first argument last, because that tends
+   to improve register allocation.
+
+   If the result type is "&", then `c-arg`s must include a function to
+   accept the pointer that receives the function result (i.e., the
+   length of `c-args` should match the length of the agument-type list
+   in the given `info-foreign`). The pointer may need to be stashed
+   somewhere by the generated code for use after the function returns.
+
+   The use of the src variable for an argument depends on its type:
+
+     - double or float: an 'fp-typed variable
+     - integer or pointer: a 'uptr-typed variable that has the integer
+     - "&": a 'uptr-typed variable that has a pointer to the argument
+
+ * c-call : uvar/reg boolean -> L13.Effect
+
+   Generate code to call the C function whose address is in the given
+   register. The boolean if #t if the call can assume that the C
+   function is not a varargs function on platformss where varargs
+   support is the default.
+
+ * c-result : uvar/reg -> L13.Effect
+
+   Similar to the conversions in `c-args`, but for the result, so the
+   given argument is a destination variable. This function will not be
+   used if the foreign call's result type is void. If the result if a
+   floating-point value, the provided destination variable has type
+   'fp.
+
+ * allocate : -> L13.Effect
+
+   Any needd teardown, such as deallocating C stack space.
+
+The `asm-foreign-callable` function returns 4 values:
+
+ * c-init : -> L13.Effect
+
+   Anything that needs to be done just before transitioning into
+   Scheme, such as saving preserved registers that call be used within
+   the callable stub.
+
+ * c-args : (listof (uvar/reg -> L13.Effect))
+
+   Similar to the `asm-foreign-call` result case, but each function
+   should fill a destination variable form platform-specific argument
+   registers and stack locations.
+
+   If the result type is "&", then `c-arg`s must include a function to
+   produce a pointer that receives the function result. Space for this
+   pointer may needed to be allocated (probably on the C stack),
+   possibly in a way that can be found on return.
+
+   The use of the destination variable is different than for the
+   `asm-foreign-call` in the case of floating-point arguments:
+
+     - double or float: pointer to a flonum to be filled with the value
+     - integer or pointer: a 'uptr-typed variable to receive the value
+     - "&": a 'uptr-typed variable to receive the pointer
+
+ * c-result : (uvar/reg -> L13.Effect) or (-> L13.Effect)
+
+   Similar to the `asm-foreign-call` arrgument cases, but for a
+   floating-point result, the given result register holds pointer to a
+   flonum. Also, if the function result is a "&" or void type, then
+   `c-result` takes no argument (because the destination pointer was
+   already produced or there's no result).
+
+ * c-return : (-> L13.Effect)
+
+   Generate the code for a C return, including any teardown needed to
+   balance `c-init`.
diff --git a/src/ChezScheme/c/Mf-tarm32le b/src/ChezScheme/c/Mf-tarm32le
new file mode 100644
index 0000000000..c5960916df
--- /dev/null
+++ b/src/ChezScheme/c/Mf-tarm32le
@@ -0,0 +1,46 @@
+# Mf-arm32le
+# Copyright 1984-2017 Cisco Systems, Inc.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = tarm32le
+Cpu = ARMV6
+
+mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid
+C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS}
+o = o
+mdsrc = arm32le.c
+mdobj = arm32le.o
+
+.SUFFIXES:
+.SUFFIXES: .c .o
+
+.c.o:
+	$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
+
+include Mf-base
+
+${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
+	${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
+
+${KernelLib}: ${kernelobj}
+	${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
+
+${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
+	$C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
+
+../zlib/configure.log:
+	(cd ../zlib; ./configure)
+
+../lz4/lib/liblz4.a: ${LZ4Sources}
+	(cd ../lz4/lib; ${MAKE} liblz4.a)
diff --git a/src/ChezScheme/c/Mf-tarm64le b/src/ChezScheme/c/Mf-tarm64le
new file mode 100644
index 0000000000..b68d887c95
--- /dev/null
+++ b/src/ChezScheme/c/Mf-tarm64le
@@ -0,0 +1,46 @@
+# Mf-arm64le
+# Copyright 1984-2017 Cisco Systems, Inc.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = tarm64le
+Cpu = AARCH64
+
+mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid
+C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS}
+o = o
+mdsrc = arm32le.c
+mdobj = arm32le.o
+
+.SUFFIXES:
+.SUFFIXES: .c .o
+
+.c.o:
+	$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c
+
+include Mf-base
+
+${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
+	${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
+
+${KernelLib}: ${kernelobj}
+	${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
+
+${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
+	$C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
+
+../zlib/configure.log:
+	(cd ../zlib; ./configure)
+
+../lz4/lib/liblz4.a: ${LZ4Sources}
+	(cd ../lz4/lib; ${MAKE} liblz4.a)
diff --git a/src/ChezScheme/c/Mf-ti3osx b/src/ChezScheme/c/Mf-ti3osx
index 254f2757c2..26a3fb2655 100644
--- a/src/ChezScheme/c/Mf-ti3osx
+++ b/src/ChezScheme/c/Mf-ti3osx
@@ -17,7 +17,7 @@ m = ti3osx
 Cpu = I386
 
 mdclib = -liconv -lm ${ncursesLib}
-C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
+C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -g -O2 -msse2 -I/opt/X11/include/ ${CFLAGS}
 o = o
 mdsrc = i3le.c
 mdobj = i3le.o
diff --git a/src/ChezScheme/c/alloc.c b/src/ChezScheme/c/alloc.c
index f79c9f5b99..e6d25f40b8 100644
--- a/src/ChezScheme/c/alloc.c
+++ b/src/ChezScheme/c/alloc.c
@@ -147,7 +147,7 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; {
 
   g = gmin;
   while (g <= gmax) {
-    n += S_G.phantom_sizes[g];
+    n += S_G.bytesof[g][countof_phantom];
     for (s = smin; s <= smax; s++) {
      /* add in bytes previously recorded */
       n += S_G.bytes_of_space[s][g];
@@ -168,11 +168,15 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; {
   return Sunsigned(n);
 }
 
+ptr S_bytes_finalized() {
+  return Sunsigned(S_G.bytes_finalized);
+}
+
 static void maybe_fire_collector() {
   ISPC s;
   uptr bytes, fudge;
 
-  bytes = S_G.phantom_sizes[0];
+  bytes = S_G.bytesof[0][countof_phantom];
 
   for (s = 0; s <= max_real_space; s += 1) {
    /* bytes already accounted for */
@@ -304,10 +308,19 @@ void S_dirty_set(ptr *loc, ptr x) {
   *loc = x;
   if (!Sfixnump(x)) {
     seginfo *si = SegInfo(addr_get_segment(loc));
-    IGEN from_g = si->generation;
-    if (from_g != 0) {
-      si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
-      mark_segment_dirty(si, from_g);
+    if (si->use_marks) {
+      /* GC must be in progress */
+      if (!IMMEDIATE(x)) {
+        seginfo *t_si = SegInfo(ptr_get_segment(x));
+        if (t_si->generation < si->generation)
+          S_error_abort("wrong-way pointer installed during GC");
+      }
+    } else {
+      IGEN from_g = si->generation;
+      if (from_g != 0) {
+        si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
+        mark_segment_dirty(si, from_g);
+      }
     }
   }
 }
@@ -431,6 +444,49 @@ ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) {
   return x;
 }
 
+ptr S_list_bits_ref(p) ptr p; {
+  seginfo *si = SegInfo(ptr_get_segment(p));
+
+  if (si->list_bits) {
+    int bit_pos = (segment_bitmap_index(p) & 0x7);
+    return FIX((si->list_bits[segment_bitmap_byte(p)] >> bit_pos) & list_bits_mask);
+  } else
+    return FIX(0);
+}
+
+void S_list_bits_set(p, bits) ptr p; iptr bits; {
+  seginfo *si = SegInfo(ptr_get_segment(p));
+
+  /* This function includes potential races when writing list bits.
+     If a race loses bits, that's ok, as long as it's unlikely. */
+
+  if (!si->list_bits) {
+    ptr list_bits;
+
+    if (si->generation == 0) {
+      ptr tc = get_thread_context();
+      thread_find_room(tc, typemod, ptr_align(segment_bitmap_bytes), list_bits);
+    } else {
+      tc_mutex_acquire()
+
+      find_room(space_data, si->generation, typemod, ptr_align(segment_bitmap_bytes), list_bits);
+      tc_mutex_release()
+    }
+
+    memset(list_bits, 0, segment_bitmap_bytes);
+
+    /* FIXME: A write fence is needed here to make sure `list_bits` is
+       zeroed for everyone who sees it. On x86, TSO takes care of that
+       ordering already. */
+
+    /* beware: racy write here */
+    si->list_bits = list_bits;
+  }
+
+  /* beware: racy read+write here */
+  si->list_bits[segment_bitmap_byte(p)] |= segment_bitmap_bits(p, bits);
+}
+
 /* S_cons_in is always called with mutex */
 ptr S_cons_in(s, g, car, cdr) ISPC s; IGEN g; ptr car, cdr; {
     ptr p;
@@ -451,16 +507,38 @@ ptr Scons(car, cdr) ptr car, cdr; {
     return p;
 }
 
-ptr Sbox(ref) ptr ref; {
+/* S_ephemeron_cons_in is always called with mutex */
+ptr S_ephemeron_cons_in(gen, car, cdr) IGEN gen; ptr car, cdr; {
+  ptr p;
+
+  find_room(space_ephemeron, gen, type_pair, size_ephemeron, p);
+  INITCAR(p) = car;
+  INITCDR(p) = cdr;
+  EPHEMERONPREVREF(p) = NULL;
+  EPHEMERONNEXT(p) = NULL;
+
+  return p;
+}
+
+ptr S_box2(ref, immobile) ptr ref; IBOOL immobile; {
     ptr tc = get_thread_context();
     ptr p;
 
-    thread_find_room(tc, type_typed_object, size_box, p);
+    if (immobile) {
+      tc_mutex_acquire()
+      find_room(space_immobile_impure, 0, type_typed_object, size_box, p);
+      tc_mutex_release()
+    } else
+      thread_find_room(tc, type_typed_object, size_box, p);
     BOXTYPE(p) = type_box;
     INITBOXREF(p) = ref;
     return p;
 }
 
+ptr Sbox(ref) ptr ref; {
+    return S_box2(ref, 0);
+}
+
 ptr S_symbol(name) ptr name; {
     ptr tc = get_thread_context();
     ptr p;
@@ -553,6 +631,10 @@ ptr S_fxvector(n) iptr n; {
 }
 
 ptr S_bytevector(n) iptr n; {
+  return S_bytevector2(n, 0);
+}
+
+ptr S_bytevector2(n, immobile) iptr n; IBOOL immobile; {
     ptr tc;
     ptr p; iptr d;
 
@@ -564,7 +646,12 @@ ptr S_bytevector(n) iptr n; {
     tc = get_thread_context();
 
     d = size_bytevector(n);
-    thread_find_room(tc, type_typed_object, d, p);
+    if (immobile) {
+      tc_mutex_acquire()
+      find_room(space_immobile_data, 0, type_typed_object, d, p);
+      tc_mutex_release()
+    } else
+      thread_find_room(tc, type_typed_object, d, p);
     BYTEVECTOR_TYPE(p) = (n << bytevector_length_offset) | type_bytevector;
     return p;
 }
@@ -917,7 +1004,8 @@ void S_phantom_bytevector_adjust(ph, new_sz) ptr ph; uptr new_sz; {
   si = SegInfo(ptr_get_segment(ph));
   g = si->generation;
 
-  S_G.phantom_sizes[g] += (new_sz - old_sz);
+  S_G.bytesof[g][countof_phantom] += (new_sz - old_sz);
+  S_adjustmembytes(new_sz - old_sz);
   PHANTOMLEN(ph) = new_sz;
 
   tc_mutex_release()
diff --git a/src/ChezScheme/c/externs.h b/src/ChezScheme/c/externs.h
index 79c2302305..2a67b3d906 100644
--- a/src/ChezScheme/c/externs.h
+++ b/src/ChezScheme/c/externs.h
@@ -64,13 +64,17 @@ extern void S_protect PROTO((ptr *p));
 extern void S_reset_scheme_stack PROTO((ptr tc, iptr n));
 extern void S_reset_allocation_pointer PROTO((ptr tc));
 extern ptr S_compute_bytes_allocated PROTO((ptr xg, ptr xs));
+extern ptr S_bytes_finalized PROTO(());
 extern ptr S_find_more_room PROTO((ISPC s, IGEN g, iptr n, ptr old));
 extern void S_dirty_set PROTO((ptr *loc, ptr x));
 extern void S_scan_dirty PROTO((ptr **p, ptr **endp));
 extern void S_scan_remembered_set PROTO((void));
 extern void S_get_more_room PROTO((void));
 extern ptr S_get_more_room_help PROTO((ptr tc, uptr ap, uptr type, uptr size));
+extern ptr S_list_bits_ref PROTO((ptr p));
+extern void S_list_bits_set PROTO((ptr p, iptr bits));
 extern ptr S_cons_in PROTO((ISPC s, IGEN g, ptr car, ptr cdr));
+extern ptr S_ephemeron_cons_in PROTO((IGEN g, ptr car, ptr cdr));
 extern ptr S_symbol PROTO((ptr name));
 extern ptr S_rational PROTO((ptr n, ptr d));
 extern ptr S_tlc PROTO((ptr keyval, ptr tconc, ptr next));
@@ -78,6 +82,7 @@ extern ptr S_vector_in PROTO((ISPC s, IGEN g, iptr n));
 extern ptr S_vector PROTO((iptr n));
 extern ptr S_fxvector PROTO((iptr n));
 extern ptr S_bytevector PROTO((iptr n));
+extern ptr S_bytevector2 PROTO((iptr n, IBOOL immobile));
 extern ptr S_null_immutable_vector PROTO((void));
 extern ptr S_null_immutable_fxvector PROTO((void));
 extern ptr S_null_immutable_bytevector PROTO((void));
@@ -96,6 +101,7 @@ extern ptr S_bignum PROTO((ptr tc, iptr n, IBOOL sign));
 extern ptr S_code PROTO((ptr tc, iptr type, iptr n));
 extern ptr S_relocation_table PROTO((iptr n));
 extern ptr S_weak_cons PROTO((ptr car, ptr cdr));
+extern ptr S_box2 PROTO((ptr ref, IBOOL immobile));
 extern ptr S_phantom_bytevector PROTO((uptr sz));
 extern void S_phantom_bytevector_adjust PROTO((ptr ph, uptr new_sz));
 
@@ -146,6 +152,9 @@ extern void S_set_maxgen PROTO((IGEN g));
 extern IGEN S_maxgen PROTO((void));
 extern void S_set_minfreegen PROTO((IGEN g));
 extern IGEN S_minfreegen PROTO((void));
+extern void S_set_minmarkgen PROTO((IGEN g));
+extern IGEN S_minmarkgen PROTO((void));
+extern ptr S_locked_objects PROTO((void));
 #ifndef WIN32
 extern void S_register_child_process PROTO((INT child));
 #endif /* WIN32 */
@@ -155,10 +164,11 @@ extern ptr S_object_counts PROTO((void));
 extern IBOOL S_enable_object_backreferences PROTO((void));
 extern void S_set_enable_object_backreferences PROTO((IBOOL eoc));
 extern ptr S_object_backreferences PROTO((void));
-extern ptr S_locked_objects PROTO((void));
+extern void S_immobilize_object PROTO((ptr v));
+extern void S_mobilize_object PROTO((ptr v));
 extern ptr S_unregister_guardian PROTO((ptr tconc));
 extern void S_compact_heap PROTO((void));
-extern void S_check_heap PROTO((IBOOL aftergc));
+extern void S_check_heap PROTO((IBOOL aftergc, IGEN target_gen));
 
 /* gc-ocd.c */
 extern ptr S_gc_ocd PROTO((ptr tc, IGEN mcg, IGEN tg, ptr count_roots));
@@ -313,6 +323,8 @@ extern void S_bignum_mask_test PROTO((void));
 extern ptr S_lookup_library_entry PROTO((iptr n, IBOOL errorp));
 extern ptr S_lookup_c_entry PROTO((iptr i));
 extern void S_prim_init PROTO((void));
+extern void S_install_c_entry PROTO((iptr i, ptr x));
+extern void S_check_c_entry_vector PROTO((void));
 
 /* prim5.c */
 extern ptr S_strerror PROTO((INT errnum));
@@ -370,6 +382,7 @@ extern void S_free_chunks PROTO((void));
 extern uptr S_curmembytes PROTO((void));
 extern uptr S_maxmembytes PROTO((void));
 extern void S_resetmaxmembytes PROTO((void));
+extern void S_adjustmembytes PROTO((iptr amt));
 extern void S_move_to_chunk_list PROTO((chunkinfo *chunk, chunkinfo **pchunk_list));
 
 /* stats.c */
diff --git a/src/ChezScheme/c/fasl.c b/src/ChezScheme/c/fasl.c
index a82e852213..02e162f14e 100644
--- a/src/ChezScheme/c/fasl.c
+++ b/src/ChezScheme/c/fasl.c
@@ -235,6 +235,10 @@ static uptr arm32_get_abs PROTO((void *address));
 static void arm32_set_jump PROTO((void *address, uptr item, IBOOL callp));
 static uptr arm32_get_jump PROTO((void *address));
 #endif /* ARMV6 */
+#ifdef AARCH64
+static void arm64_set_abs PROTO((void *address, uptr item));
+static uptr arm64_get_abs PROTO((void *address));
+#endif /* AARCH64 */
 #ifdef PPC32
 static void ppc32_set_abs PROTO((void *address, uptr item));
 static uptr ppc32_get_abs PROTO((void *address));
@@ -843,7 +847,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
                 break;
               case eq_hashtable_subtype_ephemeron:
               default:
-                keyval = S_cons_in(space_ephemeron, 0, FIX(0), FIX(0));
+                keyval = S_ephemeron_cons_in(0, FIX(0), FIX(0));
                 break;
               }
               faslin(tc, &INITCAR(keyval), t, pstrbuf, f);
@@ -966,7 +970,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
             faslin(tc, &INITCDR(*x), t, pstrbuf, f);
             return;
         case fasl_type_ephemeron:
-            *x = S_cons_in(space_ephemeron, 0, FIX(0), FIX(0));
+            *x = S_ephemeron_cons_in(0, FIX(0), FIX(0));
             faslin(tc, &INITCAR(*x), t, pstrbuf, f);
             faslin(tc, &INITCDR(*x), t, pstrbuf, f);
             return;
@@ -1297,6 +1301,13 @@ void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; p
             arm32_set_jump(address, item, 1);
             break;
 #endif /* ARMV6 */
+#ifdef AARCH64
+        case reloc_arm64_abs:
+        case reloc_arm64_jump:
+        case reloc_arm64_call:
+            arm64_set_abs(address, item);
+            break;
+#endif /* AARCH64 */
 #ifdef PPC32
         case reloc_ppc32_abs:
             ppc32_set_abs(address, item);
@@ -1375,6 +1386,13 @@ ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; {
             item = arm32_get_jump(address);
             break;
 #endif /* ARMV6 */
+#ifdef AARCH64
+        case reloc_arm64_abs:
+        case reloc_arm64_jump:
+        case reloc_arm64_call:
+            item = arm64_get_abs(address);
+            break;
+#endif /* AARCH64 */
 #ifdef PPC32
         case reloc_ppc32_abs:
             item = ppc32_get_abs(address);
@@ -1482,6 +1500,28 @@ static uptr arm32_get_jump(void *address) {
 }
 #endif /* ARMV6 */
 
+#ifdef AARCH64
+
+/* Address pieces in a movz,movk,movk,movk sequence are at its 5-20 */
+#define ADDRESS_BITS_SHIFT 5
+#define ADDRESS_BITS_MASK  ((U32)0x1fffe0)
+
+static void arm64_set_abs(void *address, uptr item) {
+  ((U32 *)address)[0] = ((((U32 *)address)[0] & ~ADDRESS_BITS_MASK) | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT));
+  ((U32 *)address)[1] = ((((U32 *)address)[1] & ~ADDRESS_BITS_MASK) | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT));
+  ((U32 *)address)[2] = ((((U32 *)address)[2] & ~ADDRESS_BITS_MASK) | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT));
+  ((U32 *)address)[3] = ((((U32 *)address)[3] & ~ADDRESS_BITS_MASK) | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT));
+}
+
+static uptr arm64_get_abs(void *address) {
+  return ((uptr)((((U32 *)address)[0] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT)
+          | ((uptr)((((U32 *)address)[1] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 16)
+          | ((uptr)((((U32 *)address)[2] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 32)
+          | ((uptr)((((U32 *)address)[3] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 48));
+}
+
+#endif /* AARCH64 */
+
 #ifdef PPC32
 
 #define UPDATE_ADDIS(item, instr) (((instr) & ~0xFFFF) | (((item) >> 16) & 0xFFFF))
diff --git a/src/ChezScheme/c/gc.c b/src/ChezScheme/c/gc.c
index 1e14812abe..3a627f8a21 100644
--- a/src/ChezScheme/c/gc.c
+++ b/src/ChezScheme/c/gc.c
@@ -20,22 +20,118 @@
 #include <sys/wait.h>
 #endif /* WIN32 */
 #include "popcount.h"
+#include <assert.h>
+
+/* 
+   GC Implementation
+   -----------------
+
+   The copying, sweeping, and marking operations that depend on
+   object's shape are mostly implemented in "mkgc.ss". That script
+   generates "gc-ocd.inc" (for modes where object counting and
+   backpointers are disabled) and "gc-oce.inc". The rest of the
+   implementation here can still depend on representatoin details,
+   though, especially for pairs, weak pairs, and ephemerons.
+
+   GC Copying versus Marking
+   -------------------------
+
+   Generations range from 0 to `S_G.max_nonstatic_generation` plus a
+   static generation. After an object moves to the static generation,
+   it doesn't move anymore. (In the case of code objects, relocations
+   may be discarded when the code object moves into a static
+   generation.)
+
+   For the most part, collecting generations 0 through mgc (= max
+   copied generation) to tg (= target generation) means copying
+   objects from old segments into fresh segments at generation tg.
+   Note that tg is either the same as or one larger than mgc.
+
+   But objects might be marked [and swept] instead of copied [and
+   swept] as triggered by two possibilities: one or more objects on
+   the source segment are immobile (subsumes locked) or mgc == tg and
+   the object is on a segment that hasn't been disovered as sparse by
+   a precious marking (non-copying) pass. Segments with marked objects
+   are promoted to generation tg.
+
+   As a special case, locking on `space_new` does not mark all objects
+   on that segment, because dirty-write handling cannot deal with
+   `space_new`; only locked objects stay on the old segment in that
+   case, and they have to be marked by looking at a list of locked
+   objects.
+
+   During a collection, the `old_space` flag is set on a segment if
+   objects aree being copied out of it or marked on it; that is,
+   `old_space` is set if the segment starts out in one of the
+   generations 0 through mgc. If a segment is being marked instead of
+   copied, the `use_marks` bit is also set; note that the bit will not
+   be set for a `space_new` segment, and locked objects in that space
+   will be specially marked.
+
+   Marking an object means setting a bit in `marked_mask`, which is
+   allocated as needed. Any segments that ends up with a non-NULL
+   `marked_mask` is promoted to tg at the end of collection. If a
+   marked object spans multiple segments, then `masked_mask` is
+   created across all of the segments. It's possible for a segment to
+   end up with `marked_mask` even though `use_marks` was not set: an
+   marked object spanned into the segment, or it's `space_new` segment
+   with locked objects; in that case, other objects will be copied out
+   of the segment, because `use_marks` is how relocation decides
+   whether to copy or mark.
+
+   If an object is copied, then its first word is set to
+   `forward_marker` and its second word is set to the new address.
+   Obviously, that doesn't happen if an object is marked. So, to test
+   whether an object has been reached:
+
+   * the object must be in an `old_space` segment, otherwise it counts
+     as reached because it's in a generation older than mcg;
+
+   * the object either starts with `forward_marker` or its mark bit is
+     set (and those arer mutually exclusive).
+
+   Besides the one bit at the start of an object, extra bits for the
+   object content may be set as well. Those extra bits tell the
+   dirty-object sweeper which words in a previously marked page should
+   be swept and which should be skipped, so the extra bits are only
+   needed for impure objects in certain kinds of spaces. Only every
+   alternate word needs to be marked that way, so half of the mark
+   bits are usually irrelevant; the exception is that flonums can be
+   between normal object-start positions, so those mark bits can
+   matter, at least if we're preserving `eq?` on flonums (but the bits
+   are not relevant to dirty-object sweeping, since flonums don't have
+   pointer fields).
+
+   It's ok to sweep an object multiple times (but to be be avoided if
+   possible).
+
+   Pending Ephemerons and Guardians
+   --------------------------------
+
+   Ephemerons and guardians act as a kind of "and": an object stays
+   reachable only if some other object (besdies the the
+   ephemeron/guardian itself) is reachable or not. Instead of
+   rechecking all guardians and ephemerons constantly, the collector
+   queues pending guardians and ephemerons on the ssegment where the
+   relevant object lives. If any object on that segment is discovered
+   to be reachable (i.e., copied or marked), the guardian/ephemeron is
+   put into a list of things to check again.
+
+*/
 
-#define enable_object_counts do_not_use_enable_object_counts_in_this_file_use_ifdef_ENABLE_OBJECT_COUNTS_instead
 
 /* locally defined functions */
-static uptr list_length PROTO((ptr ls));
-static ptr copy_list PROTO((ptr ls, IGEN tg));
-static ptr dosort PROTO((ptr ls, uptr n));
-static ptr domerge PROTO((ptr l1, ptr l2));
 static ptr copy PROTO((ptr pp, seginfo *si));
+static void mark_object PROTO((ptr pp, seginfo *si));
 static void sweep PROTO((ptr tc, ptr p));
 static void sweep_in_old PROTO((ptr tc, ptr p));
 static IBOOL object_directly_refers_to_self PROTO((ptr p));
 static ptr copy_stack PROTO((ptr old, iptr *length, iptr clength));
-static void resweep_weak_pairs PROTO((IGEN g));
+static void resweep_weak_pairs PROTO((IGEN g, seginfo *oldweakspacesegments));
 static void forward_or_bwp PROTO((ptr *pp, ptr p));
 static void sweep_generation PROTO((ptr tc, IGEN g));
+static void sweep_from_stack PROTO((ptr tc));
+static void enlarge_sweep_stack PROTO(());
 static uptr size_object PROTO((ptr p));
 static iptr sweep_typed_object PROTO((ptr tc, ptr p));
 static void sweep_symbol PROTO((ptr p));
@@ -49,23 +145,25 @@ static IGEN sweep_dirty_symbol PROTO((ptr x, IGEN tg, IGEN youngest));
 static void sweep_code_object PROTO((ptr tc, ptr co));
 static void record_dirty_segment PROTO((IGEN from_g, IGEN to_g, seginfo *si));
 static void sweep_dirty PROTO((void));
-static IGEN sweep_dirty_intersecting PROTO((ptr lst, ptr *pp, ptr *ppend, IGEN tg, IGEN youngest));
-static IGEN sweep_dirty_bytes PROTO((ptr *pp, ptr *ppend, ptr *pu, ptr *puend, IGEN tg, IGEN youngest));
 static void resweep_dirty_weak_pairs PROTO((void));
+static void mark_typemod_data_object PROTO((ptr p, uptr len, seginfo *si));
 static void add_pending_guardian PROTO((ptr gdn, ptr tconc));
 static void add_trigger_guardians_to_recheck PROTO((ptr ls));
 static void add_ephemeron_to_pending PROTO((ptr p));
-static void add_trigger_ephemerons_to_repending PROTO((ptr p));
+static void add_trigger_ephemerons_to_pending PROTO((ptr p));
 static void check_triggers PROTO((seginfo *si));
-static void check_ephemeron PROTO((ptr pe, int add_to_trigger));
+static void check_ephemeron PROTO((ptr pe));
 static void check_pending_ephemerons PROTO(());
 static int check_dirty_ephemeron PROTO((ptr pe, int tg, int youngest));
-static void clear_trigger_ephemerons PROTO(());
-static void sanitize_locked_segment PROTO((seginfo *si));
+static void finish_pending_ephemerons PROTO((seginfo *si));
+static void init_fully_marked_mask();
+static void copy_and_clear_list_bits(seginfo *oldspacesegments, IGEN tg);
 
 #ifdef ENABLE_OBJECT_COUNTS
 static uptr total_size_so_far();
+static uptr list_length PROTO((ptr ls));
 #endif
+static uptr target_generation_space_so_far();
 
 #ifdef ENABLE_MEASURE
 static void init_measure(IGEN min_gen, IGEN max_gen);
@@ -82,8 +180,6 @@ static void check_ephemeron_measure(ptr pe);
 static void check_pending_measure_ephemerons();
 #endif
 
-#define OLDSPACE(x) (SPACE(x) & space_old)
-
 /* #define DEBUG */
 
 /* initialized and used each gc cycle.  any others should be defined in globals.h */
@@ -99,11 +195,15 @@ static ptr recheck_guardians_ls;
 #ifdef ENABLE_OBJECT_COUNTS
 static int measure_all_enabled;
 static uptr count_root_bytes;
-# define COUNTING_OR(e) 1
-#else
-# define COUNTING_OR(e) e
 #endif
 
+static ptr *sweep_stack_start, *sweep_stack, *sweep_stack_limit;
+static octet *fully_marked_mask;
+
+#define push_sweep(p) { \
+  if (sweep_stack == sweep_stack_limit) enlarge_sweep_stack(); \
+  *(sweep_stack++) = p; }
+
 #ifdef ENABLE_MEASURE
 static uptr measure_total; /* updated by `measure` */
 static IGEN min_measure_generation, max_measure_generation;
@@ -137,6 +237,19 @@ static ptr sweep_from;
 # define ADD_BACKREFERENCE_FROM(p, from_p)
 #endif
 
+#if ptr_alignment == 2
+# define record_full_marked_mask 0x55
+# define record_high_marked_bit  0x40
+# define mask_bits_to_list_bits_mask(m) ((m) | ((m) << 1))
+#elif ptr_alignment == 1
+# define record_full_marked_mask 0xFF
+# define record_high_marked_bit  0x80
+# define mask_bits_to_list_bits_mask(m) (m)
+#endif
+
+#define segment_sufficiently_compact_bytes ((bytes_per_segment * 3) / 4)
+#define chunk_sufficiently_compact(nsegs) ((nsegs) >> 2)
+  
 /* Values for a guardian entry's `pending` field when it's added to a
    seginfo's pending list: */
 enum {
@@ -144,46 +257,38 @@ enum {
   GUARDIAN_PENDING_FINAL
 };
 
-static ptr copy_list(ptr ls, IGEN tg) {
-  ptr ls2 = Snil;
-  for (; ls != Snil; ls = Scdr(ls))
-    ls2 = S_cons_in(space_impure, tg, Scar(ls), ls2);
-  return ls2;
-}
-
-#define CARLT(x, y) (Scar(x) < Scar(y))
-mkmergesort(dosort, domerge, ptr, Snil, CARLT, INITCDR)
-
+#ifdef ENABLE_OBJECT_COUNTS
 uptr list_length(ptr ls) {
   uptr i = 0;
   while (ls != Snil) { ls = Scdr(ls); i += 1; }
   return i;
 }
+#endif
+
+#define init_mask(dest, tg, init) {                                     \
+    find_room(space_data, tg, typemod, ptr_align(segment_bitmap_bytes), dest); \
+    memset(dest, init, segment_bitmap_bytes);                           \
+  }
+
+#define marked(si, p) (si->marked_mask && (si->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))
+
+static void init_fully_marked_mask() {
+  init_mask(fully_marked_mask, target_generation, 0xFF);
+}
 
 #ifdef PRESERVE_FLONUM_EQ
 
 static void flonum_set_forwarded(ptr p, seginfo *si) {
-  if (!si->forwarded_flonums) {
-    ptr ff;
-    find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), ff);
-    memset(ff, 0, segment_bitmap_bytes);
-    si->forwarded_flonums = ff;
-  }
-  {
-    uptr byte = segment_bitmap_byte(p);
-    uptr bit = segment_bitmap_bit(p);
-    si->forwarded_flonums[byte] |= bit;
-  }
+  if (!si->forwarded_flonums)
+    init_mask(si->forwarded_flonums, 0, 0);
+  si->forwarded_flonums[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);
 }
 
 static int flonum_is_forwarded_p(ptr p, seginfo *si) {
   if (!si->forwarded_flonums)
     return 0;
-  else {
-    uptr delta = (uptr)UNTYPE(p, type_flonum) - (uptr)build_ptr(si->number, 0);
-    delta >>= log2_ptr_bytes;
-    return si->forwarded_flonums[delta >> 3] & (1 << (delta & 0x7));
-  }
+  else
+    return si->forwarded_flonums[segment_bitmap_byte(p)] & segment_bitmap_bit(p);
 }
 
 # define FLONUM_FWDADDRESS(p) *(ptr*)(UNTYPE(p, type_flonum))
@@ -195,6 +300,14 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) {
 # define GET_FWDADDRESS(p) FWDADDRESS(p)
 #endif
 
+#ifdef ENABLE_OBJECT_COUNTS
+# define ELSE_MEASURE_NONOLDSPACE(p) \
+  else if (measure_all_enabled)      \
+    push_measure(p);
+#else
+# define ELSE_MEASURE_NONOLDSPACE(p) /* empty */
+#endif
+
 #define relocate(ppp) {\
     ptr PP;\
     PP = *ppp;\
@@ -209,7 +322,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) {
 #define relocate_dirty(ppp,tg,youngest) {\
   ptr PP = *ppp; seginfo *SI;\
   if (!IMMEDIATE(PP) && (SI = MaybeSegInfo(ptr_get_segment(PP))) != NULL) {\
-    if (SI->space & space_old) {\
+    if (SI->old_space) {\
       relocate_help_help(ppp, PP, SI)\
       youngest = tg;\
     } else {\
@@ -223,18 +336,35 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) {
 
 #define relocate_help(ppp, pp) {\
   seginfo *SI; \
-  if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL && COUNTING_OR(SI->space & space_old)) \
-    relocate_help_help(ppp, pp, SI)\
+  if (!IMMEDIATE(pp) && (SI = MaybeSegInfo(ptr_get_segment(pp))) != NULL) {  \
+    if (SI->old_space)                \
+      relocate_help_help(ppp, pp, SI) \
+    ELSE_MEASURE_NONOLDSPACE(pp)      \
+  }                                   \
 }
 
-#define relocate_help_help(ppp, pp, si) {       \
-  if (FORWARDEDP(pp, si)) \
-    *ppp = GET_FWDADDRESS(pp); \
-  else\
-    *ppp = copy(pp, si);\
+#define relocate_help_help(ppp, pp, si) {     \
+  if (FORWARDEDP(pp, si))                     \
+    *ppp = GET_FWDADDRESS(pp);                \
+  else if (!marked(si, pp))                   \
+    mark_or_copy(*ppp, pp, si);               \
 }
 
-#define locked(si, p) (si->locked_mask && (si->locked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))
+#define relocate_code(pp, si) {               \
+  if (FWDMARKER(pp) == forward_marker)        \
+    pp = GET_FWDADDRESS(pp);                  \
+  else if (si->old_space) {                   \
+    if (!marked(si, pp))                      \
+      mark_or_copy(pp, pp, si);               \
+  } ELSE_MEASURE_NONOLDSPACE(pp)              \
+}
+
+#define mark_or_copy(dest, p, si) {           \
+  if (si->use_marks)                          \
+    mark_object(p, si);                       \
+  else                                        \
+    dest = copy(p, si);                       \
+}
 
 #ifdef ENABLE_OBJECT_COUNTS
 # define is_counting_root(si, p) (si->counting_mask && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))
@@ -249,7 +379,7 @@ FORCEINLINE void check_triggers(seginfo *si) {
      ephemerons). */
   if (si->has_triggers) {
     if (si->trigger_ephemerons) {
-      add_trigger_ephemerons_to_repending(si->trigger_ephemerons);
+      add_trigger_ephemerons_to_pending(si->trigger_ephemerons);
       si->trigger_ephemerons = NULL;
     }
     if (si->trigger_guardians) {
@@ -287,16 +417,38 @@ static void sweep_in_old(ptr tc, ptr p) {
   sweep(tc, p);
 }
 
+static void sweep_dirty_object_if_space_new(ptr p, IGEN tg) {
+  seginfo *si = SegInfo(ptr_get_segment(p));
+  if (si->space == space_new)
+    (void)sweep_dirty_object(p, tg, 0);
+}
+
 static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; {
   iptr n, m; ptr new;
+  seginfo *si = SegInfo(ptr_get_segment(old));
 
-  /* Don't copy non-oldspace stacks, since we may be sweeping a locked
+  /* Don't copy non-oldspace stacks, since we may be sweeping a
      continuation that is older than target_generation.  Doing so would
      be a waste of work anyway. */
-  if (!OLDSPACE(old)) return old;
+  if (!si->old_space) return old;
+
+  n = *length;
+    
+  if (si->use_marks) {
+    if (!marked(si, old)) {
+      mark_typemod_data_object(old, n, si);
+    
+#ifdef ENABLE_OBJECT_COUNTS
+      S_G.countof[target_generation][countof_stack] += 1;
+      S_G.bytesof[target_generation][countof_stack] += n;
+#endif
+    }
+
+    return old;
+  }
 
   /* reduce headroom created for excessively large frames (typically resulting from apply with long lists) */
-  if ((n = *length) != clength && n > default_stack_size && n > (m = clength + one_shot_headroom)) {
+  if (n != clength && n > default_stack_size && n > (m = clength + one_shot_headroom)) {
     *length = n = m;
   }
 
@@ -305,6 +457,7 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; {
   S_G.countof[target_generation][countof_stack] += 1;
   S_G.bytesof[target_generation][countof_stack] += n;
 #endif /* ENABLE_OBJECT_COUNTS */
+
   find_room(space_data, target_generation, typemod, n, new);
   n = ptr_align(clength);
  /* warning: stack may have been left non-double-aligned by split_and_resize */
@@ -323,7 +476,7 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; {
     next = GUARDIANNEXT(ls); \
  \
     if (FILTER(si, obj)) { \
-      if (!(si->space & space_old) || locked(si, obj)) { \
+      if (!si->old_space || marked(si, obj)) { \
         INITGUARDIANNEXT(ls) = pend_hold_ls; \
         pend_hold_ls = ls; \
       } else if (FORWARDEDP(obj, si)) { \
@@ -334,7 +487,7 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; {
         seginfo *t_si; \
         tconc = GUARDIANTCONC(ls); \
         t_si = SegInfo(ptr_get_segment(tconc)); \
-        if (!(t_si->space & space_old) || locked(t_si, tconc)) { \
+        if (!t_si->old_space || marked(t_si, tconc)) { \
           INITGUARDIANNEXT(ls) = final_ls; \
           final_ls = ls; \
         } else if (FWDMARKER(tconc) == forward_marker) { \
@@ -357,9 +510,10 @@ typedef struct count_root_t {
 
 ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     IGEN g; ISPC s;
-    seginfo *oldspacesegments, *si, *nextsi;
-    ptr ls, younger_locked_objects;
+    seginfo *oldspacesegments, *oldweakspacesegments, *si, *nextsi;
+    ptr ls;
     bucket_pointer_list *buckets_to_rebuild;
+    uptr pre_finalization_size, pre_phantom_bytes;
 #ifdef ENABLE_OBJECT_COUNTS
     ptr count_roots_counts = Snil;
     iptr count_roots_len;
@@ -382,7 +536,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     }
 
    /* perform after ScanDirty */
-    if (S_checkheap) S_check_heap(0);
+    if (S_checkheap) S_check_heap(0, mcg);
 
 #ifdef DEBUG
 (void)printf("mcg = %x;  go? ", mcg); (void)fflush(stdout); (void)getc(stdin);
@@ -391,6 +545,9 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     target_generation = tg;
     max_copied_generation = mcg;
 
+    sweep_stack_start = sweep_stack = sweep_stack_limit = NULL;
+    fully_marked_mask = NULL;
+
   /* set up generations to be copied */
     for (s = 0; s <= max_real_space; s++)
         for (g = 0; g <= mcg; g++) {
@@ -401,28 +558,50 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
             S_G.bytes_of_space[s][g] = 0;
         }
 
-  /* reset phantom size in generations to be copied */
+  /* reset phantom size in generations to be copied, even if counting is not otherwise enabled */
+    pre_phantom_bytes = 0;
     for (g = 0; g <= mcg; g++) {
-      S_G.phantom_sizes[g] = 0;
+      pre_phantom_bytes += S_G.bytesof[g][countof_phantom];
+      S_G.bytesof[g][countof_phantom] = 0;
     }
+    pre_phantom_bytes += S_G.bytesof[tg][countof_phantom];
 
   /* set up target generation sweep_loc and orig_next_loc pointers */
     for (s = 0; s <= max_real_space; s++)
       orig_next_loc[s] = sweep_loc[s] = S_G.next_loc[s][tg];
 
-  /* mark segments from which objects are to be copied */
-    oldspacesegments = (seginfo *)NULL;
+  /* mark segments from which objects are to be copied or marked */
+    oldspacesegments = oldweakspacesegments = (seginfo *)NULL;
     for (s = 0; s <= max_real_space; s += 1) {
       for (g = 0; g <= mcg; g += 1) {
+        IBOOL maybe_mark = ((tg == S_G.min_mark_gen) && (g == tg));
         for (si = S_G.occupied_segments[s][g]; si != NULL; si = nextsi) {
           nextsi = si->next;
           si->next = oldspacesegments;
           oldspacesegments = si;
-          si->space = s | space_old; /* NB: implicitly clearing space_locked */
+          si->old_space = 1;
+          if (si->must_mark
+              || (maybe_mark
+                  && (!si->marked_mask
+                      || (si->marked_count >= segment_sufficiently_compact_bytes))
+                  && (si->chunk->nused_segs >= chunk_sufficiently_compact(si->chunk->segs)))) {
+            if (s != space_new) /* only lock-based marking is allowed on space_new */
+              si->use_marks = 1;
+            /* update generation now, so that any updated dirty references 
+               will record the correct new generation; also used for a check in S_dirty_set */
+            si->generation = tg;
+          }
+          si->marked_mask = NULL; /* clear old mark bits, if any */
+          si->marked_count = 0;
+          si->min_dirty_byte = 0; /* prevent registering as dirty while GCing */
         }
         S_G.occupied_segments[s][g] = NULL;
       }
-    }
+      if (s == space_weakpair) {
+        /* prefix of oldweakspacesegments is for weak pairs */
+        oldweakspacesegments = oldspacesegments;
+      }
+    }          
 
 #ifdef ENABLE_OBJECT_COUNTS
    /* clear object counts & bytes for copied generations; bump timestamp */
@@ -446,8 +625,23 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
       S_G.gcbackreference[g] = Snil;
    }
 
-   SET_BACKREFERENCE(Sfalse) /* #f => root or locked */
+   SET_BACKREFERENCE(Sfalse) /* #f => root */
 
+    /* Set mark bit for any locked object in `space_new`. Don't sweep until
+       after handling counting roots. Note that the segment won't have
+       `use_marks` set, so non-locked objects will be copied out. */
+     for (g = 0; g <= mcg; g += 1) {
+       for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
+         ptr p = Scar(ls);
+         seginfo *si = SegInfo(ptr_get_segment(p));
+         if (si->space == space_new) {
+           if (!si->marked_mask)
+             init_mask(si->marked_mask, tg, 0);
+           si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);
+         }
+       }
+     }
+   
 #ifdef ENABLE_OBJECT_COUNTS
   /* set flag on count_roots objects so they get copied to space_count_root */
      if (count_roots_ls != Sfalse) {
@@ -471,8 +665,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
            si->counting_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);
 
            count_roots[i].p = p;
-           count_roots[i].weak = (((ls_si->space & ~(space_old|space_locked)) == space_weakpair)
-                                  || ((ls_si->space & ~(space_old|space_locked)) == space_ephemeron));
+           count_roots[i].weak = ((ls_si->space == space_weakpair)
+                                  || (ls_si->space == space_ephemeron));
          }
        }
      } else {
@@ -480,32 +674,6 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
        count_roots = NULL;
      }
 #endif
-     
-    /* pre-collection handling of locked objects. */
-
-     /* set up locked-object masks */
-     younger_locked_objects = Snil;
-     for (si = oldspacesegments; si != NULL; si = si->next) {
-       if (si->locked_objects != Snil) {
-         find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->locked_mask);
-         memset(si->locked_mask, 0, segment_bitmap_bytes);
-
-         ls = copy_list(si->locked_objects, tg);
-         si->locked_objects = ls;
-         
-         while (ls != Snil) {
-           ptr p = Scar(ls);
-           uptr byte = segment_bitmap_byte(p);
-           uptr bit = segment_bitmap_bit(p);
-           if (!(si->locked_mask[byte] & bit)) {
-             si->locked_mask[byte] |= bit;
-             younger_locked_objects = S_cons_in(space_new, 0, p, younger_locked_objects);
-           }
-           ls = Scdr(ls);
-         }
-       }
-       si->unlocked_objects = Snil;
-     }
 
 #ifdef ENABLE_OBJECT_COUNTS
   /* sweep count_roots in order and accumulate counts */
@@ -527,12 +695,11 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
            si->counting_mask[segment_bitmap_byte(p)] -= segment_bitmap_bit(p);
 
-           if (!(si->space & space_old) || FORWARDEDP(p, si) || locked(si, p)
+           if (!si->old_space || FORWARDEDP(p, si) || marked(si, p)
                || !count_roots[i].weak) {
              /* reached or older; sweep transitively */
              relocate(&p)
-             if ((si->space & ~(space_old|space_locked)) != space_ephemeron) /* not ok to resweep ephemeron */
-               sweep(tc, p);
+             sweep(tc, p);
              ADD_BACKREFERENCE(p)
              sweep_generation(tc, tg);
 # ifdef ENABLE_MEASURE
@@ -573,12 +740,45 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
      }
 #endif
 
-   /* sweep younger locked objects */
-     for (ls = younger_locked_objects; ls != Snil; ls = Scdr(ls)) {
-       ptr x = Scar(ls);
-       sweep(tc, x);
-       ADD_BACKREFERENCE(x)
-      }
+  /* sweep older locked and unlocked objects that are on `space_new` segments,
+     because we can't find dirty writes there */
+    for (g = mcg + 1; g <= static_generation; INCRGEN(g)) {
+      for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls))
+        sweep_dirty_object_if_space_new(Scar(ls), tg);
+      for (ls = S_G.unlocked_objects[g]; ls != Snil; ls = Scdr(ls))
+        sweep_dirty_object_if_space_new(Scar(ls), tg);
+    }
+
+    /* Gather and mark all younger locked objects.
+       Any object on a `space_new` segment is already marked, but still
+       needs to be swept. */
+     {
+       ptr locked_objects = ((tg > mcg) ? S_G.locked_objects[tg] : Snil);
+       for (g = 0; g <= mcg; g += 1) {
+         for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
+           ptr p = Scar(ls);
+           seginfo *si = SegInfo(ptr_get_segment(p));
+           if (si->space == space_new) {
+             /* Retract the mark bit and mark properly, so anything that needs
+                to happen with marking will happen. */
+             if (!marked(si, p))
+               S_error_abort("space_new locked object should have a mark bit set");
+             si->marked_mask[segment_bitmap_byte(p)] -= segment_bitmap_bit(p);
+             mark_object(p, si);
+           }
+           /* non-`space_new` objects will be swept via new pair */
+           locked_objects = S_cons_in(space_impure, tg, p, locked_objects);
+#ifdef ENABLE_OBJECT_COUNTS
+           S_G.countof[tg][countof_pair] += 1;
+           S_G.countof[tg][countof_locked] += 1;
+           S_G.bytesof[target_generation][countof_locked] += size_object(p);
+#endif /* ENABLE_OBJECT_COUNTS */
+         }
+         S_G.locked_objects[g] = Snil;
+         S_G.unlocked_objects[g] = Snil;
+       }
+       S_G.locked_objects[tg] = locked_objects;
+     }
 
   /* sweep non-oldspace threads, since any thread may have an active stack */
     for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
@@ -616,8 +816,11 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
         }
         if (FWDMARKER(sym) != forward_marker &&
             /* coordinate with alloc.c */
-            (SYMVAL(sym) != sunbound || SYMPLIST(sym) != Snil || SYMSPLIST(sym) != Snil))
-          (void)copy(sym, SegInfo(ptr_get_segment(sym)));
+            (SYMVAL(sym) != sunbound || SYMPLIST(sym) != Snil || SYMSPLIST(sym) != Snil)) {
+          seginfo *sym_si = SegInfo(ptr_get_segment(sym));
+          if (!marked(sym_si, sym))
+            mark_or_copy(sym, sym, sym_si);
+        }
       }
       S_G.buckets_of_generation[g] = NULL;
     }
@@ -633,6 +836,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
     sweep_generation(tc, tg);
 
+    pre_finalization_size = target_generation_space_so_far();
+
   /* handle guardians */
     {   ptr hold_ls, pend_hold_ls, final_ls, pend_final_ls, maybe_final_ordered_ls;
         ptr obj, rep, tconc, next;
@@ -670,10 +875,10 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
         }
 
        /* invariants after partition_guardians:
-        * for entry in pend_hold_ls, obj is !OLDSPACE or locked
-        * for entry in final_ls, obj is OLDSPACE and !locked
-        * for entry in final_ls, tconc is !OLDSPACE or locked
-        * for entry in pend_final_ls, obj and tconc are OLDSPACE and !locked
+        * for entry in pend_hold_ls, obj is !OLDSPACE
+        * for entry in final_ls, obj is OLDSPACE
+        * for entry in final_ls, tconc is !OLDSPACE
+        * for entry in pend_final_ls, obj and tconc are OLDSPACE
         */
 
         hold_ls = S_G.guardians[tg];
@@ -707,7 +912,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
                      representative can't itself be a tconc, so we
                      won't discover any new tconcs at that point. */
                   ptr obj = GUARDIANOBJ(ls);
-                  if (FORWARDEDP(obj, SegInfo(ptr_get_segment(obj)))) {
+                  seginfo *o_si = SegInfo(ptr_get_segment(obj));
+                  if (FORWARDEDP(obj, o_si) || marked(o_si, obj)) {
                     /* Object is reachable, so we might as well move
                        this one to the hold list --- via pend_hold_ls, which
                        leads to a copy to move to hold_ls */
@@ -715,7 +921,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
                     pend_hold_ls = ls;
                   } else {
                     seginfo *si;
-                    if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && (si->space & space_old) && !locked(si, rep)) {
+                    if (!IMMEDIATE(rep) && (si = MaybeSegInfo(ptr_get_segment(rep))) != NULL && si->old_space) {
                       PUSH_BACKREFERENCE(rep)
                       sweep_in_old(tc, rep);
                       POP_BACKREFERENCE()
@@ -730,11 +936,11 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
                   WITH_TOP_BACKREFERENCE(tconc, relocate(&rep));
 
                   old_end = Scdr(tconc);
-                  new_end = S_cons_in(space_impure, 0, FIX(0), FIX(0));
+                  /* allocate new_end in tg, in case `tconc` is on a marked segment */
+                  new_end = S_cons_in(space_impure, tg, FIX(0), FIX(0));
 #ifdef ENABLE_OBJECT_COUNTS
                   S_G.countof[tg][countof_pair] += 1;
 #endif /* ENABLE_OBJECT_COUNTS */
-                  
                   SETCAR(old_end,rep);
                   SETCDR(old_end,new_end);
                   SETCDR(tconc,new_end);
@@ -753,7 +959,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
                     t_si = SegInfo(ptr_get_segment(tconc));
 
-                    if ((t_si->space & space_old) && !locked(t_si, tconc)) {
+                    if (t_si->old_space && !marked(t_si, tconc)) {
                         if (FWDMARKER(tconc) == forward_marker)
                             tconc = FWDADDRESS(tconc);
                         else {
@@ -791,8 +997,9 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
               ls = maybe_final_ordered_ls; maybe_final_ordered_ls = Snil;
               for (; ls != Snil; ls = next) {
                 ptr obj = GUARDIANOBJ(ls);
+                seginfo *o_si = SegInfo(ptr_get_segment(obj));
                 next = GUARDIANNEXT(ls);
-                if (FORWARDEDP(obj, SegInfo(ptr_get_segment(obj)))) {
+                if (FORWARDEDP(obj, o_si) || marked(o_si, obj)) {
                   /* Will defintely move to hold_ls, but the entry
                      must be copied to move from pend_hold_ls to
                      hold_ls: */
@@ -822,8 +1029,8 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
             }
             
           /* move each entry in pend_final_ls into one of:
-           *   final_ls         if tconc forwarded
-           *   pend_final_ls    if tconc not forwarded
+           *   final_ls         if tconc forwarded or marked
+           *   pend_final_ls    if tconc not forwarded or marked
            * where the output pend_final_ls coresponds to pending in a segment */
             ls = pend_final_ls; pend_final_ls = Snil;
             for ( ; ls != Snil; ls = next) {
@@ -834,8 +1041,14 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
                     INITGUARDIANNEXT(ls) = final_ls;
                     final_ls = ls;
                 } else {
+                  seginfo *t_si = SegInfo(ptr_get_segment(tconc));
+                  if (marked(t_si, tconc)) {
+                    INITGUARDIANNEXT(ls) = final_ls;
+                    final_ls = ls;
+                  } else {
                     INITGUARDIANPENDING(ls) = FIX(GUARDIAN_PENDING_FINAL);
                     add_pending_guardian(ls, tconc);
+                  }
                 }
             }
         }
@@ -843,20 +1056,15 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
         S_G.guardians[tg] = hold_ls;
     }
 
+    S_G.bytes_finalized = target_generation_space_so_far() - pre_finalization_size;
+    S_adjustmembytes(S_G.bytesof[tg][countof_phantom] - pre_phantom_bytes);
+
   /* handle weak pairs */
     resweep_dirty_weak_pairs();
-    resweep_weak_pairs(tg);
+    resweep_weak_pairs(tg, oldweakspacesegments);
 
    /* still-pending ephemerons all go to bwp */
-    clear_trigger_ephemerons();
-
-   /* forward car fields of locked oldspace weak pairs */
-    for (ls = younger_locked_objects; ls != Snil; ls = Scdr(ls)) {
-      ptr x = Scar(ls);
-      if (Spairp(x) && (SPACE(x) & ~(space_old|space_locked)) == space_weakpair) {
-        forward_or_bwp(&INITCAR(x), Scar(x));
-      }
-    }
+    finish_pending_ephemerons(oldspacesegments);
 
    /* post-gc oblist handling.  rebuild old buckets in the target generation, pruning unforwarded symbols */
     { bucket_list *bl, *blnext; bucket *b, *bnext; bucket_pointer_list *bpl; bucket **pb;
@@ -868,7 +1076,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
           bnext = (bucket *)((uptr)(b->next) - 1);
           sym = b->sym;
           si = SegInfo(ptr_get_segment(sym));
-          if (locked(si, sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) {
+          if (marked(si, sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) {
             find_room(space_data, tg, typemod, sizeof(bucket), b);
 #ifdef ENABLE_OBJECT_COUNTS
             S_G.countof[tg][countof_oblist] += 1;
@@ -898,11 +1106,13 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
   /* rebuild rtds_with_counts lists, dropping otherwise inaccessible rtds */
     { IGEN g; ptr ls, p, newls = tg == mcg ? Snil : S_G.rtds_with_counts[tg]; seginfo *si;
+      int count = 0;
       for (g = 0; g <= mcg; g += 1) {
         for (ls = S_G.rtds_with_counts[g], S_G.rtds_with_counts[g] = Snil; ls != Snil; ls = Scdr(ls)) {
+          count++;
           p = Scar(ls);
           si = SegInfo(ptr_get_segment(p));
-          if (!(si->space & space_old) || locked(si, p)) {
+          if (!si->old_space || marked(si, p)) {
             newls = S_cons_in(space_impure, tg, p, newls);
             S_G.countof[tg][countof_pair] += 1;
           } else if (FWDMARKER(p) == forward_marker) {
@@ -938,50 +1148,32 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     }
 #endif /* WIN32 */
 
-   /* post-collection handling of locked objects.  This must come after
-      any use of relocate. */
-    for (ls = younger_locked_objects; ls != Snil; ls = Scdr(ls)) {
-        ptr x = Scar(ls);
-        ptr a1, a2; uptr seg; uptr n;
-
-        /* promote the segment(s) containing x to the target generation.
-           reset the space_old bit to prevent the segments from being
-           reclaimed; sanitize the segments to support sweeping by
-           sweep_dirty (since the segments may contain a mix of objects,
-           many of which have been discarded). */
-        n = size_object(x);
-#ifdef ENABLE_OBJECT_COUNTS
-        S_G.countof[target_generation][countof_locked] += 1;
-        S_G.bytesof[target_generation][countof_locked] += n;
-#endif /* ENABLE_OBJECT_COUNTS */
+    copy_and_clear_list_bits(oldspacesegments, tg);
 
-        a1 = UNTYPE_ANY(x);
-        a2 = (ptr)((uptr)a1 + n - 1);
-        for (seg = addr_get_segment(a1); seg <= addr_get_segment(a2); seg += 1) {
-          seginfo *si = SegInfo(seg);
-          if (!(si->space  & space_locked)) {
-            si->generation = tg;
-            si->space = (si->space & ~space_old) | space_locked;
-            sanitize_locked_segment(si);
-          }
-          si->locked_mask = NULL; /* really only need to clear the first one */
-        }
-    }
-
-  /* move old space segments to empty space */
+  /* move copied old space segments to empty space, and promote
+     marked old space segments to the target generation */
     for (si = oldspacesegments; si != NULL; si = nextsi) {
       nextsi = si->next;
-      s = si->space;
-      if (s & space_locked) {
-        /* note: the oldspace bit is cleared above for locked objects */
-        s &= ~space_locked;
-        g = si->generation;
-        if (g == static_generation) S_G.number_of_nonstatic_segments -= 1;
-        si->next = S_G.occupied_segments[s][g];
-        S_G.occupied_segments[s][g] = si;
-        si->trigger_ephemerons = NULL;
+      si->old_space = 0;
+      si->use_marks = 0;
+      if (si->marked_mask != NULL) {
+        si->min_dirty_byte = 0xff;
+        if (si->space != space_data) {
+          int d;
+          for (d = 0; d < cards_per_segment; d += sizeof(ptr)) {
+            iptr *dp = (iptr *)(si->dirty_bytes + d);
+            /* fill sizeof(iptr) bytes at a time with 0xff */
+            *dp = -1;
+          }
+        }
+        si->generation = tg;
+        if (tg == static_generation) S_G.number_of_nonstatic_segments -= 1;
+        s = si->space;
+        si->next = S_G.occupied_segments[s][tg];
+        S_G.occupied_segments[s][tg] = si;
+        S_G.bytes_of_space[s][tg] += si->marked_count;
+        si->trigger_guardians = NULL;
 #ifdef PRESERVE_FLONUM_EQ
-        /* any flonums forwarded won't be reference anymore */
         si->forwarded_flonums = NULL;
 #endif
       } else {
@@ -1012,7 +1204,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
 
     S_flush_instruction_cache(tc);
 
-    if (S_checkheap) S_check_heap(1);
+    if (S_checkheap) S_check_heap(1, mcg);
 
    /* post-collection rehashing of tlcs.
       must come after any use of relocate.
@@ -1069,6 +1261,9 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
     /* tell profile_release_counters to look for bwp'd counters at least through tg */
     if (S_G.prcgeneration < tg) S_G.prcgeneration = tg;
 
+    if (sweep_stack_start != sweep_stack)
+      S_error_abort("gc: sweep stack ended non-empty");
+
     if (count_roots_ls != Sfalse) {
 #ifdef ENABLE_OBJECT_COUNTS
       return count_roots_counts;
@@ -1093,20 +1288,47 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) {
         while (pp != nl);\
     *slp = (ptr)pp;
 
-static void resweep_weak_pairs(g) IGEN g; {
+static void resweep_weak_pairs(g, oldweakspacesegments) IGEN g; seginfo *oldweakspacesegments; {
     ptr *slp, *nlp; ptr *pp, p, *nl;
+    seginfo *si;
 
     sweep_loc[space_weakpair] = S_G.first_loc[space_weakpair][g];
     sweep_space(space_weakpair, {
         forward_or_bwp(pp, p);
         pp += 2;
     })
+
+   for (si = oldweakspacesegments; si != NULL; si = si->next) {
+     if (si->space != space_weakpair)
+       break;
+     if (si->marked_mask) {
+       uptr i;
+       for (i = 0; i < segment_bitmap_bytes; i++) {
+         int mask = si->marked_mask[i];
+         if (mask != 0) {
+           /* Assuming 4 pairs per 8 words */
+           pp = (ptr *)build_ptr(si->number, (i << (log2_ptr_bytes+3)));
+           if (mask & 0x1)
+             forward_or_bwp(pp, *pp);
+           pp += 2;
+           if (mask & 0x4)
+             forward_or_bwp(pp, *pp);
+           pp += 2;
+           if (mask & 0x10)
+             forward_or_bwp(pp, *pp);
+           pp += 2;
+           if (mask & 0x40)
+             forward_or_bwp(pp, *pp);
+         }
+       }
+     }
+   }
 }
 
 static void forward_or_bwp(pp, p) ptr *pp; ptr p; {
   seginfo *si;
  /* adapted from relocate */
-  if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(si, p)) {
+  if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space && !marked(si, p)) {
     if (FORWARDEDP(p, si)) {
       *pp = GET_FWDADDRESS(p);
     } else {
@@ -1120,6 +1342,9 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; {
   
   do {
     change = 0;
+
+    sweep_from_stack(tc);
+    
     sweep_space(space_impure, {
         SET_BACKREFERENCE(TYPE((ptr)pp, type_pair)) /* only pairs put here in backreference mode */
         relocate_help(pp, p)
@@ -1212,6 +1437,27 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; {
   } while (change);
 }
 
+void enlarge_sweep_stack() {
+  uptr sz = ptr_bytes * (sweep_stack_limit - sweep_stack_start);
+  uptr new_sz = 2 * ((sz == 0) ? 256 : sz);
+  ptr new_sweep_stack;
+  find_room(space_data, 0, typemod, ptr_align(new_sz), new_sweep_stack);
+  if (sz != 0)
+    memcpy(new_sweep_stack, sweep_stack_start, sz);
+  sweep_stack_start = (ptr *)new_sweep_stack;
+  sweep_stack_limit = (ptr *)((uptr)new_sweep_stack + new_sz);
+  sweep_stack = (ptr *)((uptr)new_sweep_stack + sz);
+}
+
+void sweep_from_stack(tc) ptr tc; {
+  if (sweep_stack > sweep_stack_start) {
+    change = 1;
+  
+    while (sweep_stack > sweep_stack_start)
+      sweep(tc, *(--sweep_stack));
+  }
+}
+
 static iptr sweep_typed_object(tc, p) ptr tc; ptr p; {
   ptr tf = TYPEFIELD(p);
 
@@ -1252,43 +1498,6 @@ static void record_dirty_segment(IGEN from_g, IGEN to_g, seginfo *si) {
   }
 }
 
-#define SIMPLE_DIRTY_SPACE_P(s) (((s) == space_weakpair) || ((s) == space_ephemeron) || ((s) == space_symbol) || ((s) == space_port))
-
-static void sanitize_locked_segment(seginfo *si) {
-  /* If `si` is for weak pairs, ephemeron pairs, or other things that
-     are guaranteed to stay on a single segment, make the segment safe
-     for handling by `sweep_dirty`, where memory not occupied by
-     objects in `si->locked_objects` is "zeroed" out in a way that it
-     can be traversed. This is merely convenient and efficient for
-     some kinds of segments, but it's required for weak and ephemeron
-     pairs. */
-  ISPC s = si->space & ~space_locked;
-
-  if (SIMPLE_DIRTY_SPACE_P(s)) {
-    ptr ls;
-    ptr *pp, *ppend;
-
-    /* Sort locked objects */
-    si->locked_objects = ls = dosort(si->locked_objects, list_length(si->locked_objects));
-
-    pp = build_ptr(si->number, 0);
-    ppend = (ptr *)((uptr)pp + bytes_per_segment);
-
-    /* Zero out unused memory */
-    while (pp < ppend) {
-      if ((ls != Snil) && (pp == UNTYPE_ANY(Scar(ls)))) {
-        ptr a = Scar(ls);
-        pp = (ptr *)((uptr)pp + size_object(Scar(ls)));
-        while ((ls != Snil) && (Scar(ls) == a))
-          ls = Scdr(ls);
-      } else {
-        *pp = FIX(0);
-        pp++;
-      }
-    }
-  }
-}
-
 static void sweep_dirty(void) {
   IGEN tg, mcg, youngest, min_youngest;
   ptr *pp, *ppend, *nl;
@@ -1296,7 +1505,6 @@ static void sweep_dirty(void) {
   ISPC s;
   IGEN from_g, to_g;
   seginfo *dirty_si, *nextsi;
-  IBOOL check_locked;
 
   PUSH_BACKREFERENCE(Snil) /* '() => from unspecified old object */
 
@@ -1324,15 +1532,9 @@ static void sweep_dirty(void) {
         /* reset min dirty byte so we can detect if byte is set while card is swept */
         dirty_si->min_dirty_byte = 0xff;
 
-        check_locked = 0;
-        if (s & space_locked) {
-          s &= ~space_locked;
-          if (!SIMPLE_DIRTY_SPACE_P(s)) {
-            /* Only consider cards that intersect with
-               `locked_objects`, `unlocked_objects`, or a
-               segment-spanning object from a preceding page */
-            check_locked = 1;
-          }
+        if (dirty_si->space == space_new) {
+          /* Must be a space that has only locked objects, which we sweeep every time */
+          continue;
         }
 
         min_youngest = 0xff;
@@ -1366,46 +1568,23 @@ static void sweep_dirty(void) {
                 /* assume we won't find any wrong-way pointers */
                 youngest = 0xff;
 
-                if (check_locked) {
-                  /* Look only at bytes that intersect with a locked or unlocked object */
-                  ptr backp;
-                  seginfo *prev_si;
-
-                  youngest = sweep_dirty_intersecting(dirty_si->locked_objects, pp, ppend, tg, youngest);
-                  youngest = sweep_dirty_intersecting(dirty_si->unlocked_objects, pp, ppend, tg, youngest);
-
-                  /* Look for previous segment that might have locked objects running into this one */
-                  backp = (ptr)((uptr)build_ptr(seg, 0) - ptr_bytes);
-                  while (1) {
-                    ISPC s2;
-                    prev_si = MaybeSegInfo(ptr_get_segment(backp));
-                    if (!prev_si) break;
-                    s2 = prev_si->space;
-                    if (!(s2 & space_locked)) break;
-                    s2 &= ~space_locked;
-                    if (SIMPLE_DIRTY_SPACE_P(s2)) break;
-                    if ((prev_si->locked_objects != Snil) || (prev_si->unlocked_objects != Snil)) {
-                      youngest = sweep_dirty_intersecting(prev_si->locked_objects, pp, ppend, tg, youngest);
-                      youngest = sweep_dirty_intersecting(prev_si->unlocked_objects, pp, ppend, tg, youngest);
-                      break;
-                    } else {
-                      backp = (ptr)(((uptr)backp) - bytes_per_segment);
-                    }
-                  }
-                } else if ((s == space_impure)
-                           || (s == space_impure_typed_object) || (s == space_count_impure)
-                           || (s == space_closure)) {
+                if ((s == space_impure) || (s == space_immobile_impure)
+                    || (s == space_impure_typed_object) || (s == space_count_impure)
+                    || (s == space_closure)) {
                   while (pp < ppend && *pp != forward_marker) {
                     /* handle two pointers at a time */
-                    relocate_dirty(pp,tg,youngest)
-                    pp += 1;
-                    relocate_dirty(pp,tg,youngest)
-                    pp += 1;
+                    if (!dirty_si->marked_mask || marked(dirty_si, pp)) {
+                      relocate_dirty(pp,tg,youngest)
+                      pp += 1;
+                      relocate_dirty(pp,tg,youngest)
+                      pp += 1;
+                    } else
+                      pp += 2;
                   }
                 } else if (s == space_symbol) {
                   /* old symbols cannot overlap segment boundaries
                      since any object that spans multiple
-                     generations begins at the start of a segment,
+                     segments begins at the start of a segment,
                      and symbols are much smaller (we assume)
                      than the segment size. */
                   pp = (ptr *)build_ptr(seg,0) +
@@ -1416,14 +1595,15 @@ static void sweep_dirty(void) {
                   while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a symbol.  no harm. */
                     ptr p = TYPE((ptr)pp, type_symbol);
 
-                    youngest = sweep_dirty_symbol(p, tg, youngest);
+                    if (!dirty_si->marked_mask || marked(dirty_si, p))
+                      youngest = sweep_dirty_symbol(p, tg, youngest);
 
                     pp += size_symbol / sizeof(ptr);
                   }
                 } else if (s == space_port) {
                   /* old ports cannot overlap segment boundaries
                      since any object that spans multiple
-                     generations begins at the start of a segment,
+                     segments begins at the start of a segment,
                      and ports are much smaller (we assume)
                      than the segment size. */
                   pp = (ptr *)build_ptr(seg,0) +
@@ -1434,67 +1614,160 @@ static void sweep_dirty(void) {
                   while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a port.  no harm. */
                     ptr p = TYPE((ptr)pp, type_typed_object);
 
-                    youngest = sweep_dirty_port(p, tg, youngest);
+                    if (!dirty_si->marked_mask || marked(dirty_si, p))
+                      youngest = sweep_dirty_port(p, tg, youngest);
 
                     pp += size_port / sizeof(ptr);
                   }
                 } else if (s == space_impure_record) { /* abandon hope all ye who enter here */
-                  uptr j; ptr p, pnext; seginfo *si;
-
-                  /* synchronize on first record that overlaps the dirty
-                     area, then relocate any mutable pointers in that
-                     record and those that follow within the dirty area. */
-
-                  /* find first segment of group of like segments */
-                  j = seg - 1;
-                  while ((si = MaybeSegInfo(j)) != NULL &&
-                      si->space == s &&
-                      si->generation == from_g)
-                    j -= 1;
-                  j += 1;
-
-                  /* now find first record in segment seg */
-                  /* we count on following fact: if an object spans two
-                     or more segments, then he starts at the beginning
-                     of a segment */
-                  for (;;) {
-                    p = TYPE(build_ptr(j,0),type_typed_object);
-                    pnext = (ptr)((iptr)p +
-                        size_record_inst(UNFIX(RECORDDESCSIZE(
-                              RECORDINSTTYPE(p)))));
-                    if (ptr_get_segment(pnext) >= seg) break;
-                    j = ptr_get_segment(pnext) + 1;
-                  }
+                  ptr p;
+                  if (dirty_si->marked_mask) {
+                    /* To get to the start of a record, move backward as long as bytes
+                       are marked and segment space+generation+marked is the same. */
+                    uptr byte = segment_bitmap_byte(pp);
+                    uptr bit = segment_bitmap_bit(pp);
+                    uptr at_seg = seg;
+                    seginfo *si = dirty_si;
+
+                    while (si->marked_mask[byte] & (bit >> ptr_alignment))
+                      bit >>= ptr_alignment;
+                    if (bit == 1) {
+                      /* try previous byte(s) */
+                      while (1) {
+                        if (byte == 0) {
+                          seginfo *prev_si = MaybeSegInfo(at_seg-1);
+                          if (prev_si
+                              && (prev_si->space == si->space)
+                              && (prev_si->generation == si->generation)
+                              && prev_si->marked_mask
+                              /* object can only continue from the previous segment
+                                 if that segment is fully marked (including last words) */
+                              && (prev_si->marked_mask[segment_bitmap_bytes-1] == record_full_marked_mask)) {
+                            /* maybe the object continues from the previous segment, although
+                               we don't really know... */
+                            at_seg -= 1;
+                            si = prev_si;
+                            byte = segment_bitmap_bytes-1;
+                          } else {
+                            /* object does not continue from the previous segment */
+                            break;
+                          }
+                        } else {
+                          if (si->marked_mask[byte-1] == record_full_marked_mask) {
+                            /* next byte is full, so keep looking */
+                            byte--;
+                          } else if (si->marked_mask[byte-1] & record_high_marked_bit) {
+                            /* next byte continues, but is not full, so we can start
+                               there */
+                            if (at_seg != seg) {
+                              /* in fact, we can start at the beginning of the
+                                 next segment, because that segment's
+                                 first object cannot start on this segment */
+                              at_seg++;
+                              byte = 0;
+                              si = SegInfo(at_seg);
+                            } else {
+                              byte--;
+                              bit = record_high_marked_bit;
+                              /* find bit contiguous with highest bit */
+                              while (si->marked_mask[byte] & (bit >> ptr_alignment))
+                                bit >>= ptr_alignment;
+                            }
+                            break;
+                          } else {
+                            /* next byte is empty, so don't go there */
+                            break;
+                          }
+                        }
+                      }
+                    }
 
-                  /* now find first within dirty area */
-                  while ((ptr *)UNTYPE(pnext, type_typed_object) <= pp) {
-                    p = pnext;
-                    pnext = (ptr)((iptr)p +
-                        size_record_inst(UNFIX(RECORDDESCSIZE(
-                              RECORDINSTTYPE(p)))));
-                  }
+                    /* `bit` and `byte` refer to a non-0 mark bit that must be
+                       the start of an object */
+                    p = build_ptr(at_seg, (byte << (log2_ptr_bytes+3)));
+                    while (bit > ptr_alignment) {
+                      p = (ptr)((uptr)p + byte_alignment);
+                      bit >>= ptr_alignment;
+                    }
+                    p = TYPE(p, type_typed_object);
+
+                    /* now sweep, but watch out for unmarked holes in the dirty region */
+                    while ((ptr *)UNTYPE(p, type_typed_object) < ppend) {
+                      seginfo *si = SegInfo(ptr_get_segment(p));
+                      if (!marked(si, p)) {
+                        /* skip unmarked words */
+                        p = (ptr)((uptr)p + byte_alignment);
+                      } else {
+                        /* quit on end of segment */
+                        if (FWDMARKER(p) == forward_marker) break;
+
+                        youngest = sweep_dirty_record(p, tg, youngest);
+                        p = (ptr)((iptr)p +
+                            size_record_inst(UNFIX(RECORDDESCSIZE(
+                                  RECORDINSTTYPE(p)))));
+                      }
+                    }
+                  } else {
+                    uptr j; ptr pnext; seginfo *si;
+
+                    /* synchronize on first record that overlaps the dirty
+                       area, then relocate any mutable pointers in that
+                       record and those that follow within the dirty area. */
+
+                    /* find first segment of group of like segments */
+                    j = seg - 1;
+                    while ((si = MaybeSegInfo(j)) != NULL &&
+                           si->space == s &&
+                           si->generation == from_g &&
+                           !si->marked_mask)
+                      j -= 1;
+                    j += 1;
+
+                    /* now find first record in segment seg */
+                    /* we count on following fact: if an object spans two
+                       or more segments, then it starts at the beginning
+                       of a segment */
+                    for (;;) {
+                      p = TYPE(build_ptr(j,0),type_typed_object);
+                      pnext = (ptr)((iptr)p +
+                                    size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p)))));
+                      if (ptr_get_segment(pnext) >= seg) break;
+                      j = ptr_get_segment(pnext) + 1;
+                    }
 
-                  /* now sweep */
-                  while ((ptr *)UNTYPE(p, type_typed_object) < ppend) {
-                    /* quit on end of segment */
+                    /* now find first within dirty area */
+                    while ((ptr *)UNTYPE(pnext, type_typed_object) <= pp) {
+                      p = pnext;
+                      pnext = (ptr)((iptr)p +
+                                    size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p)))));
+                    }
+
+                    /* now sweep */
+                    while ((ptr *)UNTYPE(p, type_typed_object) < ppend) {
+                      /* quit on end of segment */
                     if (FWDMARKER(p) == forward_marker) break;
 
-                    youngest = sweep_dirty_record(p, tg, youngest);
-                    p = (ptr)((iptr)p +
-                        size_record_inst(UNFIX(RECORDDESCSIZE(
-                              RECORDINSTTYPE(p)))));
+                      youngest = sweep_dirty_record(p, tg, youngest);
+                      p = (ptr)((iptr)p +
+                          size_record_inst(UNFIX(RECORDDESCSIZE(
+                                RECORDINSTTYPE(p)))));
+                    }
                   }
                 } else if (s == space_weakpair) {
                   while (pp < ppend && *pp != forward_marker) {
                     /* skip car field and handle cdr field */
-                    pp += 1;
-                    relocate_dirty(pp, tg, youngest)
-                    pp += 1;
+                    if (!dirty_si->marked_mask || marked(dirty_si, pp)) {
+                      pp += 1;
+                      relocate_dirty(pp, tg, youngest)
+                      pp += 1;
+                    } else
+                      pp += 2;
                   }
                 } else if (s == space_ephemeron) {
                   while (pp < ppend && *pp != forward_marker) {
                     ptr p = TYPE((ptr)pp, type_pair);
-                    youngest = check_dirty_ephemeron(p, tg, youngest);
+                    if (!dirty_si->marked_mask || marked(dirty_si, p))
+                      youngest = check_dirty_ephemeron(p, tg, youngest);
                     pp += size_ephemeron / sizeof(ptr);
                   }
                 } else {
@@ -1524,83 +1797,6 @@ static void sweep_dirty(void) {
   POP_BACKREFERENCE()
 }
 
-IGEN sweep_dirty_intersecting(ptr lst, ptr *pp, ptr *ppend, IGEN tg, IGEN youngest)
-{
-  ptr p, *pu, *puend;
-
-  for (; lst != Snil; lst = Scdr(lst)) {
-    p = (ptr *)Scar(lst);
-
-    pu = (ptr*)UNTYPE_ANY(p);
-    puend = (ptr*)((uptr)pu + size_object(p));
-
-    if (((pu >= pp) && (pu < ppend))
-        || ((puend >= pp) && (puend < ppend))
-        || ((pu <= pp) && (puend >= ppend))) {
-      /* Overlaps, so sweep */
-      ITYPE t = TYPEBITS(p);
-
-      if (t == type_pair) {
-        youngest = sweep_dirty_bytes(pp, ppend, pu, puend, tg, youngest);
-      } else if (t == type_closure) {
-        ptr code;
-
-        code = CLOSCODE(p);
-        if (CODETYPE(code) & (code_flag_mutable_closure << code_flags_offset)) {
-          youngest = sweep_dirty_bytes(pp, ppend, pu, puend, tg, youngest);
-        }
-      } else if (t == type_symbol) {
-        youngest = sweep_dirty_symbol(p, tg, youngest);
-      } else if (t == type_flonum) {
-        /* nothing to sweep */
-      } else {
-        ptr tf = TYPEFIELD(p);
-        if (TYPEP(tf, mask_vector, type_vector)
-            || TYPEP(tf, mask_stencil_vector, type_stencil_vector)
-            || TYPEP(tf, mask_box, type_box)
-            || ((iptr)tf == type_tlc)) {
-          /* impure objects */
-          youngest = sweep_dirty_bytes(pp, ppend, pu, puend, tg, youngest);
-        } else if (TYPEP(tf, mask_string, type_string)
-                   || TYPEP(tf, mask_bytevector, type_bytevector)
-                   || TYPEP(tf, mask_fxvector, type_fxvector)) {
-          /* nothing to sweep */;
-        } else if (TYPEP(tf, mask_record, type_record)) {
-          youngest = sweep_dirty_record(p, tg, youngest);
-        } else if (((iptr)tf == type_ratnum)
-                   || ((iptr)tf == type_exactnum)
-                   || TYPEP(tf, mask_bignum, type_bignum)) {
-          /* immutable */
-        } else if (TYPEP(tf, mask_port, type_port)) {
-          youngest = sweep_dirty_port(p, tg, youngest);
-        } else if (TYPEP(tf, mask_code, type_code)) {
-          /* immutable */
-        } else if (((iptr)tf == type_rtd_counts)
-                   || ((iptr)tf == type_phantom)) {
-          /* nothing to sweep */;
-        } else {
-          S_error_abort("sweep_dirty_intersection(gc): unexpected type");
-        }
-      }
-    }
-  }
-
-  return youngest;
-}
-
-IGEN sweep_dirty_bytes(ptr *pp, ptr *ppend, ptr *pu, ptr *puend, IGEN tg, IGEN youngest)
-{
-  if (pu < pp) pu = pp;
-  if (puend > ppend) puend = ppend;
-
-  while (pu < puend) {
-    relocate_dirty(pu,tg,youngest)
-    pu += 1;
-  }
-
-  return youngest;
-}
-
 static void resweep_dirty_weak_pairs() {
   weakseginfo *ls;
   ptr *pp, *ppend, *nl, p;
@@ -1637,8 +1833,8 @@ static void resweep_dirty_weak_pairs() {
 
               /* handle car field */
               if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
-                if (si->space & space_old) {
-                  if (locked(si, p)) {
+                if (si->old_space) {
+                  if (marked(si, p)) {
                     youngest = tg;
                   } else if (FORWARDEDP(p, si)) {
                     *pp = FWDADDRESS(p);
@@ -1691,17 +1887,28 @@ static void add_trigger_guardians_to_recheck(ptr ls)
 static ptr pending_ephemerons = NULL;
 /* Ephemerons that we haven't looked at, chained through `next`. */
 
-static ptr trigger_ephemerons = NULL;
-/* Ephemerons that we've checked and added to segment triggers,
-   chained through `next`. Ephemerons attached to a segment are
-   chained through `trigger-next`. A #t in `trigger-next` means that
-   the ephemeron has been processed, so we don't need to remove it
-   from the trigger list in a segment. */
+static void ephemeron_remove(ptr pe) {
+  ptr next = EPHEMERONNEXT(pe);
+  *((ptr *)EPHEMERONPREVREF(pe)) = next;
+  if (next)
+    EPHEMERONPREVREF(next) = EPHEMERONPREVREF(pe);
+  EPHEMERONPREVREF(pe) = NULL;
+  EPHEMERONNEXT(pe) = NULL;
+}
 
-static ptr repending_ephemerons = NULL;
-/* Ephemerons in `trigger_ephemerons` that we need to inspect again,
-   removed from the triggering segment and chained here through
-   `trigger-next`. */
+static void ephemeron_add(ptr *first, ptr pe) {
+  ptr last_pe = pe, next_pe = EPHEMERONNEXT(pe), next;
+  while (next_pe != NULL) {
+    last_pe = next_pe;
+    next_pe = EPHEMERONNEXT(next_pe);
+  }
+  next = *first;
+  *first = pe;
+  EPHEMERONPREVREF(pe) = (ptr)first;
+  EPHEMERONNEXT(last_pe) = next;
+  if (next)
+    EPHEMERONPREVREF(next) = &EPHEMERONNEXT(last_pe);
+}
 
 static void add_ephemeron_to_pending(ptr pe) {
   /* We could call check_ephemeron directly here, but the indirection
@@ -1709,41 +1916,33 @@ static void add_ephemeron_to_pending(ptr pe) {
      of times that we have to trigger re-checking, especially since
      check_pending_pehemerons() is run only after all other sweep
      opportunities are exhausted. */
-  EPHEMERONNEXT(pe) = pending_ephemerons;
-  pending_ephemerons = pe;
+  if (EPHEMERONPREVREF(pe)) ephemeron_remove(pe);
+  ephemeron_add(&pending_ephemerons, pe);
 }
 
-static void add_trigger_ephemerons_to_repending(ptr pe) {
-  ptr last_pe = pe, next_pe = EPHEMERONTRIGGERNEXT(pe);
-  while (next_pe != NULL) {
-    last_pe = next_pe;
-    next_pe = EPHEMERONTRIGGERNEXT(next_pe);
-  }
-  EPHEMERONTRIGGERNEXT(last_pe) = repending_ephemerons;
-  repending_ephemerons = pe;
+static void add_trigger_ephemerons_to_pending(ptr pe) {
+  ephemeron_add(&pending_ephemerons, pe);
 }
 
-static void check_ephemeron(ptr pe, int add_to_trigger) {
+static void check_ephemeron(ptr pe) {
   ptr p;
   seginfo *si;
   PUSH_BACKREFERENCE(pe);
 
+  EPHEMERONNEXT(pe) = NULL;
+  EPHEMERONPREVREF(pe) = NULL;
+
   p = Scar(pe);
-  if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space & space_old && !locked(si, p)) {
-    if (FORWARDEDP(p, si)) {
+  if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) {
+    if (marked(si, p)) {
+      relocate(&INITCDR(pe))
+    } else if (FORWARDEDP(p, si)) {
       INITCAR(pe) = FWDADDRESS(p);
       relocate(&INITCDR(pe))
-      if (!add_to_trigger)
-        EPHEMERONTRIGGERNEXT(pe) = Strue; /* in trigger list, #t means "done" */
     } else {
       /* Not reached, so far; install as trigger */
-      EPHEMERONTRIGGERNEXT(pe) = si->trigger_ephemerons;
-      si->trigger_ephemerons = pe;
+      ephemeron_add(&si->trigger_ephemerons, pe);
       si->has_triggers = 1;
-      if (add_to_trigger) {
-        EPHEMERONNEXT(pe) = trigger_ephemerons;
-        trigger_ephemerons = pe;
-      }
     }
   } else {
     relocate(&INITCDR(pe))
@@ -1759,15 +1958,7 @@ static void check_pending_ephemerons() {
   pending_ephemerons = NULL;
   while (pe != NULL) {
     next_pe = EPHEMERONNEXT(pe);
-    check_ephemeron(pe, 1);
-    pe = next_pe;
-  }
-
-  pe = repending_ephemerons;
-  repending_ephemerons = NULL;
-  while (pe != NULL) {
-    next_pe = EPHEMERONTRIGGERNEXT(pe);
-    check_ephemeron(pe, 0);
+    check_ephemeron(pe);
     pe = next_pe;
   }
 }
@@ -1783,14 +1974,18 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) {
  
   p = Scar(pe);
   if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL) {
-    if (si->space & space_old && !locked(si, p)) {
-      if (FORWARDEDP(p, si)) {
+    if (si->old_space) {
+      if (marked(si, p)) {
+        relocate(&INITCDR(pe))
+        youngest = tg;
+      } else if (FORWARDEDP(p, si)) {
         INITCAR(pe) = GET_FWDADDRESS(p);
         relocate(&INITCDR(pe))
         youngest = tg;
       } else {
         /* Not reached, so far; add to pending list */
         add_ephemeron_to_pending(pe);
+
         /* Make the consistent (but pessimistic w.r.t. to wrong-way
            pointers) assumption that the key will stay live and move
            to the target generation. That assumption covers the value
@@ -1815,23 +2010,24 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) {
   return youngest;
 }
 
-static void clear_trigger_ephemerons() {
-  ptr pe;
-
+static void finish_pending_ephemerons(seginfo *si) {
+  /* Any ephemeron still in a trigger list is an ephemeron
+     whose key was not reached. */
   if (pending_ephemerons != NULL)
     S_error_abort("clear_trigger_ephemerons(gc): non-empty pending list");
 
-  pe = trigger_ephemerons;
-  trigger_ephemerons = NULL;
-  while (pe != NULL) {
-    if (EPHEMERONTRIGGERNEXT(pe) == Strue) {
-      /* The ephemeron was triggered and retains its key and value */
-    } else {
-      /* Key never became reachable, so clear key and value */
-      INITCAR(pe) = Sbwp_object;
-      INITCDR(pe) = Sbwp_object;
+  for (; si != NULL; si = si->next) {
+    if (si->trigger_ephemerons) {
+      ptr pe, next_pe;
+      for (pe = si->trigger_ephemerons; pe != NULL; pe = next_pe) {
+        INITCAR(pe) = Sbwp_object;
+        INITCDR(pe) = Sbwp_object;
+        next_pe = EPHEMERONNEXT(pe);
+        EPHEMERONPREVREF(pe) = NULL;
+        EPHEMERONNEXT(pe) = NULL;
+      }
+      si->trigger_ephemerons = NULL;
     }
-    pe = EPHEMERONNEXT(pe);
   }
 }
 
@@ -1848,13 +2044,92 @@ static uptr total_size_so_far() {
       if (bytes == 0) bytes = S_G.countof[g][i] * S_G.countof_size[i];
       total += bytes;
     }
-    total += S_G.phantom_sizes[g];
   }
 
   return total - count_root_bytes;
 }
 #endif
 
+static uptr target_generation_space_so_far() {
+  IGEN g = target_generation;
+  ISPC s;
+  uptr sz = S_G.bytesof[g][countof_phantom];
+
+  for (s = 0; s <= max_real_space; s++) {
+    sz += S_G.bytes_of_space[s][g];
+    if (S_G.next_loc[s][g] != FIX(0))
+      sz += (char *)S_G.next_loc[s][g] - (char *)S_G.base_loc[s][g];
+  }
+
+  return sz;
+}
+
+void copy_and_clear_list_bits(seginfo *oldspacesegments, IGEN tg) {
+  seginfo *si;
+  int i;
+
+  /* Update bits that are used by `list-assuming-immutable?`. */
+
+  for (si = oldspacesegments; si != NULL; si = si->next) {
+    if (si->list_bits) {
+      if ((si->generation == 0) && !si->marked_mask) {
+        /* drop generation-0 bits, because probably the relevant pairs
+           were short-lived, and it's ok to recompute them if needed */
+      } else {
+        if (si->marked_mask) {
+          /* Besides marking or copying `si->list_bits`, clear bits
+             where there's no corresponding mark bit, so we don't try to
+             check forwarding in a future GC */
+          seginfo *bits_si = SegInfo(ptr_get_segment((ptr)si->list_bits));
+        
+          if (bits_si->old_space) {
+            if (bits_si->use_marks) {
+              if (!bits_si->marked_mask)
+                init_mask(bits_si->marked_mask, tg, 0);
+              bits_si->marked_mask[segment_bitmap_byte((ptr)si->list_bits)] |= segment_bitmap_bit((ptr)si->list_bits);
+            } else {
+              octet *copied_bits;
+              find_room(space_data, tg, typemod, ptr_align(segment_bitmap_bytes), copied_bits);
+              memcpy_aligned(copied_bits, si->list_bits, segment_bitmap_bytes);
+              si->list_bits = copied_bits;
+            }
+          }
+
+          for (i = 0; i < segment_bitmap_bytes; i++) {
+            int m = si->marked_mask[i];
+            si->list_bits[i] &= mask_bits_to_list_bits_mask(m);
+          }
+        }
+
+        if (si->use_marks) {
+          /* No forwarding possible from this segment */
+        } else {
+          /* For forwarded pointers, copy over list bits */
+          for (i = 0; i < segment_bitmap_bytes; i++) {
+            if (si->list_bits[i]) {
+              int bitpos;
+              for (bitpos = 0; bitpos < 8; bitpos += ptr_alignment) {
+                int bits = si->list_bits[i] & (list_bits_mask << bitpos);
+                if (bits != 0) {
+                  ptr p = build_ptr(si->number, ((i << (log2_ptr_bytes+3)) + (bitpos << log2_ptr_bytes)));
+                  if (FWDMARKER(p) == forward_marker) {
+                    ptr new_p = FWDADDRESS(p);
+                    seginfo *new_si = SegInfo(ptr_get_segment(new_p));
+                    if (!new_si->list_bits)
+                      init_mask(new_si->list_bits, tg, 0);
+                    bits >>= bitpos;
+                    new_si->list_bits[segment_bitmap_byte(new_p)] |= segment_bitmap_bits(new_p, bits);
+                  }
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+}
+
 /* **************************************** */
 
 #ifdef ENABLE_MEASURE
@@ -1878,8 +2153,14 @@ static void finish_measure() {
   ptr ls;
 
   for (ls = measured_seginfos; ls != Snil; ls = Scdr(ls)) {
+    ptr pe, next_pe;
     seginfo *si = (seginfo *)Scar(ls);
     si->measured_mask = NULL;
+    for (pe = si->trigger_ephemerons; pe != NULL; pe = next_pe) {
+      next_pe = EPHEMERONNEXT(pe);
+      EPHEMERONPREVREF(pe) = NULL;
+      EPHEMERONNEXT(pe) = NULL;
+    }
     si->trigger_ephemerons = NULL;
   }
 
@@ -1887,14 +2168,11 @@ static void finish_measure() {
 }
 
 static void init_counting_mask(seginfo *si) {
-  find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->counting_mask);
-  memset(si->counting_mask, 0, segment_bitmap_bytes);
+  init_mask(si->counting_mask, 0, 0);
 }
 
 static void init_measure_mask(seginfo *si) {
-  find_room(space_data, 0, typemod, ptr_align(segment_bitmap_bytes), si->measured_mask);
-  memset(si->measured_mask, 0, segment_bitmap_bytes);
-  
+  init_mask(si->measured_mask, 0, 0);
   measured_seginfos = S_cons_in(space_new, 0, (ptr)si, measured_seginfos);
 }
 
@@ -1914,12 +2192,10 @@ static void push_measure(ptr p)
   if (!si)
     return;
 
-  if (si->space & space_old) {
+  if (si->old_space) {
     /* We must be in a GC--measure fusion, so switch back to GC */
-    if (!locked(si, p)) {
-      relocate(&p)
-      return;
-    }
+    relocate_help_help(&p, p, si)
+    return;
   }
 
   if (si->generation > max_measure_generation)
@@ -1960,43 +2236,49 @@ static void push_measure(ptr p)
 
 static void measure_add_stack_size(ptr stack, uptr size) {
   seginfo *si = SegInfo(ptr_get_segment(stack));
-  if (!(si->space & space_old)
+  if (!(si->old_space)
       && (si->generation <= max_measure_generation)
       && (si->generation >= min_measure_generation))
     measure_total += size;
 }
 
 static void add_ephemeron_to_pending_measure(ptr pe) {
-  EPHEMERONNEXT(pe) = pending_measure_ephemerons;
-  pending_measure_ephemerons = pe;
+  /* If we're in hybrid mode and the key in `pe` is in the
+     old space, then we need to use the regular pending list
+     instead of the measure-specific one */
+  seginfo *si;
+  ptr p = Scar(pe);
+
+  if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space)
+    add_ephemeron_to_pending(pe);
+  else {
+    if (EPHEMERONPREVREF(pe))
+      S_error_abort("add_ephemeron_to_pending_measure: ephemeron is in some list");
+    ephemeron_add(&pending_measure_ephemerons, pe);
+  }
 }
 
 static void add_trigger_ephemerons_to_pending_measure(ptr pe) {
-  ptr last_pe = pe, next_pe = EPHEMERONNEXT(pe);
-
-  while (next_pe != NULL) {
-    last_pe = next_pe;
-    next_pe = EPHEMERONNEXT(next_pe);
-  }
-  EPHEMERONNEXT(last_pe) = pending_measure_ephemerons;
-  pending_measure_ephemerons = pe;
+  ephemeron_add(&pending_measure_ephemerons, pe);
 }
 
 static void check_ephemeron_measure(ptr pe) {
   ptr p;
   seginfo *si;
 
+  EPHEMERONPREVREF(pe) = NULL;
+  EPHEMERONNEXT(pe) = NULL;
+
   p = Scar(pe);
   if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL
       && (si->generation <= max_measure_generation)
       && (si->generation >= min_measure_generation)
-      && (!(si->space & space_old) || !FORWARDEDP(p, si))
+      && (!(si->old_space) || !FORWARDEDP(p, si))
       && (measure_unreached(si, p)
           || (si->counting_mask
               && (si->counting_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))))) {
     /* Not reached, so far; install as trigger */
-    EPHEMERONNEXT(pe) = si->trigger_ephemerons;
-    si->trigger_ephemerons = pe;
+    ephemeron_add(&si->trigger_ephemerons, pe);
     if (!si->measured_mask)
       init_measure_mask(si); /* so triggers are cleared at end */
     return;
diff --git a/src/ChezScheme/c/gcwrapper.c b/src/ChezScheme/c/gcwrapper.c
index ed3852bd0b..bbd4f4ea02 100644
--- a/src/ChezScheme/c/gcwrapper.c
+++ b/src/ChezScheme/c/gcwrapper.c
@@ -17,13 +17,12 @@
 #include "system.h"
 
 /* locally defined functions */
-static IBOOL memqp PROTO((ptr x, ptr ls));
-static IBOOL remove_first_nomorep PROTO((ptr x, ptr *pls, IBOOL look));
 static void segment_tell PROTO((uptr seg));
 static void check_heap_dirty_msg PROTO((char *msg, ptr *x));
 static IBOOL dirty_listedp PROTO((seginfo *x, IGEN from_g, IGEN to_g));
 static void check_dirty_space PROTO((ISPC s));
 static void check_dirty PROTO((void));
+static void check_locked_object PROTO((ptr p, IBOOL locked, IGEN g, IBOOL aftergc, IGEN mcg));
 
 static IBOOL checkheap_noisy;
 
@@ -50,11 +49,14 @@ void S_gc_init() {
 
   for (g = 0; g <= static_generation; g++) {
     S_G.guardians[g] = Snil;
+    S_G.locked_objects[g] = Snil;
+    S_G.unlocked_objects[g] = Snil;
   }
   S_G.max_nonstatic_generation = 
     S_G.new_max_nonstatic_generation = 
       S_G.min_free_gen = 
-        S_G.new_min_free_gen = default_max_nonstatic_generation;
+        S_G.new_min_free_gen =
+          S_G.min_mark_gen = default_max_nonstatic_generation;
 
   for (g = 0; g <= static_generation; g += 1) {
     for (i = 0; i < countof_types; i += 1) {
@@ -133,6 +135,8 @@ void S_gc_init() {
     S_G.countof_size[countof_stencil_vector] = 0;
   INITVECTIT(S_G.countof_names, countof_record) = S_intern((const unsigned char *)"record");
     S_G.countof_size[countof_record] = 0;
+  INITVECTIT(S_G.countof_names, countof_phantom) = S_intern((const unsigned char *)"phantom");
+    S_G.countof_size[countof_phantom] = 0;
   for (i = 0; i < countof_types; i += 1) {
     if (Svector_ref(S_G.countof_names, i) == FIX(0)) {
       fprintf(stderr, "uninitialized countof_name at index %d\n", i);
@@ -167,6 +171,60 @@ void S_set_minfreegen(IGEN g) {
   }
 }
 
+IGEN S_minmarkgen(void) {
+  return S_G.min_mark_gen;
+}
+
+void S_set_minmarkgen(IGEN g) {
+  S_G.min_mark_gen = g;
+}
+
+void S_immobilize_object(x) ptr x; {
+  seginfo *si;
+
+  if (IMMEDIATE(x))
+    si = NULL;
+  else
+    si = MaybeSegInfo(ptr_get_segment(x));
+ 
+  if ((si != NULL) && (si->generation != static_generation)) {
+    tc_mutex_acquire()
+
+    /* Try a little to to support cancellation of segment-level
+     * immobilzation --- but we don't try too hard */
+    if (si->must_mark < MUST_MARK_INFINITY)
+      si->must_mark++;
+
+    /* Note: for `space_new`, `must_mark` doesn't really mean all
+       objects must be marked; only those in the locked list must be
+       marked. Non-locked objects on `space_new` cannot be immobilized. */
+
+    tc_mutex_release()
+  }
+}
+
+void S_mobilize_object(x) ptr x; {
+  seginfo *si;
+
+  if (IMMEDIATE(x))
+    si = NULL;
+  else
+    si = MaybeSegInfo(ptr_get_segment(x));
+
+  if ((si != NULL) && (si->generation != static_generation)) {
+    tc_mutex_acquire()
+
+    if (si->must_mark == 0)
+      S_error_abort("S_mobilize_object(): object was definitely not immobilzed");
+
+    /* See S_immobilize_object() about this vague try at canceling immobilation: */
+    if (si->must_mark < MUST_MARK_INFINITY)
+      --si->must_mark;
+  
+    tc_mutex_release()
+  }
+}
+
 static IBOOL memqp(x, ls) ptr x, ls; {
   for (;;) {
     if (ls == Snil) return 0;
@@ -202,7 +260,7 @@ IBOOL Slocked_objectp(x) ptr x; {
   tc_mutex_acquire()
 
   ans = 0;
-  for (ls = si->locked_objects; ls != Snil; ls = Scdr(ls)) {
+  for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
     if (x == Scar(ls)) {
       ans = 1;
       break;
@@ -215,18 +273,14 @@ IBOOL Slocked_objectp(x) ptr x; {
 }
 
 ptr S_locked_objects(void) {
-  IGEN g; ptr ans; ptr ls; ISPC s; seginfo *si;
+  IGEN g; ptr ans; ptr ls;
 
   tc_mutex_acquire()
 
   ans = Snil;
   for (g = 0; g <= static_generation; INCRGEN(g)) {
-    for (s = 0; s <= max_real_space; s += 1) {
-      for (si = S_G.occupied_segments[s][g]; si != NULL; si = si->next) {
-        for (ls = si->locked_objects; ls != Snil; ls = Scdr(ls)) {
-          ans = Scons(Scar(ls), ans);
-        }
-      }
+    for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
+      ans = Scons(Scar(ls), ans);
     }
   }
 
@@ -238,43 +292,44 @@ ptr S_locked_objects(void) {
 void Slock_object(x) ptr x; {
   seginfo *si; IGEN g;
 
-  tc_mutex_acquire()
-
  /* weed out pointers that won't be relocated */
   if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
+    tc_mutex_acquire()
     S_pants_down += 1;
+    /* immobilize */
+    if (si->must_mark < MUST_MARK_INFINITY)
+      si->must_mark++;
    /* add x to locked list. remove from unlocked list */
-    si->locked_objects = S_cons_in((g == 0 ? space_new : space_impure), g, x, si->locked_objects);
+    S_G.locked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.locked_objects[g]);
     if (S_G.enable_object_counts) {
       if (g != 0) S_G.countof[g][countof_pair] += 1;
     }
-    if (si->space & space_locked)
-      (void)remove_first_nomorep(x, &si->unlocked_objects, 0);
+    (void)remove_first_nomorep(x, &S_G.unlocked_objects[g], 0);
     S_pants_down -= 1;
+    tc_mutex_release()
   }
-
-  tc_mutex_release()
 }
 
 void Sunlock_object(x) ptr x; {
   seginfo *si; IGEN g;
 
-  tc_mutex_acquire()
-
   if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
+    tc_mutex_acquire()
     S_pants_down += 1;
+    /* mobilize, if we haven't lost track */
+    if (si->must_mark < MUST_MARK_INFINITY)
+      --si->must_mark;
    /* remove first occurrence of x from locked list. if there are no
       others, add x to unlocked list */
-    if (remove_first_nomorep(x, &si->locked_objects, si->space & space_locked)) {
-      si->unlocked_objects = S_cons_in((g == 0 ? space_new : space_impure), g, x, si->unlocked_objects);
+    if (remove_first_nomorep(x, &S_G.locked_objects[g], (si->space == space_new) && (si->generation > 0))) {
+      S_G.unlocked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.unlocked_objects[g]);
       if (S_G.enable_object_counts) {
         if (g != 0) S_G.countof[g][countof_pair] += 1;
       }
     }
     S_pants_down -= 1;
+    tc_mutex_release()
   }
-
-  tc_mutex_release()
 }
 
 ptr s_help_unregister_guardian(ptr *pls, ptr tconc, ptr result) {
@@ -406,13 +461,20 @@ ptr S_object_backreferences(void) {
   return ls;
 }
 
+seginfo *S_ptr_seginfo(ptr p) {
+  return MaybeSegInfo(ptr_get_segment(p)); 
+}
+
 /* Scompact_heap().  Compact into as few O/S chunks as possible and
  * move objects into static generation
  */
 void Scompact_heap() {
   ptr tc = get_thread_context();
+  IBOOL eoc = S_G.enable_object_counts;
   S_pants_down += 1;
+  S_G.enable_object_counts = 1;
   S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, Sfalse);
+  S_G.enable_object_counts = eoc;
   S_pants_down -= 1;
 }
 
@@ -443,13 +505,14 @@ static void segment_tell(seg) uptr seg; {
   } else {
     printf(" generation=%d", si->generation);
     s = si->space;
-    s1 = si->space & ~(space_old|space_locked);
+    s1 = si->space;
     if (s1 < 0 || s1 > max_space)
       printf(" space-bogus (%d)", s);
     else {
       printf(" space-%s", spacename[s1]);
-      if (s & space_old) printf(" oldspace");
-      if (s & space_locked) printf(" locked");
+      if (si->old_space) printf(" oldspace");
+      if (si->must_mark) printf(" mustmark");
+      if (si->marked_mask) printf(" marked");
     }
     printf("\n");
   }
@@ -474,7 +537,7 @@ static void check_heap_dirty_msg(msg, x) char *msg; ptr *x; {
     printf("to   "); segment_tell(addr_get_segment(*x));
 }
 
-void S_check_heap(aftergc) IBOOL aftergc; {
+void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; {
   uptr seg; INT d; ISPC s; IGEN g; IDIRTYBYTE dirty; IBOOL found_eos; IGEN pg;
   ptr p, *pp1, *pp2, *nl;
   iptr i;
@@ -513,6 +576,10 @@ void S_check_heap(aftergc) IBOOL aftergc; {
     seginfo *si;
     for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) {
       for (si = S_G.occupied_segments[s][g]; si != NULL; si = si->next) {
+        if (si->generation != g) {
+          S_checkheap_errors += 1;
+          printf("!!! segment in wrong occupied_segments list\n");
+        }
         nonstatic_segments += 1;
       }
     }
@@ -559,13 +626,18 @@ void S_check_heap(aftergc) IBOOL aftergc; {
         s = si->space;
         g = si->generation;
 
+        if (si->use_marks)
+          printf("!!! use_marks set on generation %d segment %#tx\n", g, (ptrdiff_t)seg);
+
         if (s == space_new) {
-          if (g != 0) {
+          if (g != 0 && !si->marked_mask) {
             S_checkheap_errors += 1;
             printf("!!! unexpected generation %d segment %#tx in space_new\n", g, (ptrdiff_t)seg);
           }
-        } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair /* || s == space_ephemeron */) {
-          /* out of date: doesn't handle space_port, space_continuation, space_code, space_pure_typed_object, space_impure_record */
+        } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair || s == space_ephemeron
+                   || s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure) {
+          /* doesn't handle: space_port, space_continuation, space_code, space_pure_typed_object,
+                             space_impure_record, or impure_typed_object */
           nl = (ptr *)S_G.next_loc[s][g];
 
           /* check for dangling references */
@@ -573,23 +645,52 @@ void S_check_heap(aftergc) IBOOL aftergc; {
           pp2 = (ptr *)build_ptr(seg + 1, 0);
           if (pp1 <= nl && nl < pp2) pp2 = nl;
 
-          while (pp1 != pp2) {
-            seginfo *psi; ISPC ps;
-            p = *pp1;
-            if (p == forward_marker) break;
-            if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && ((ps = psi->space) & space_old || ps == space_empty)) {
-              S_checkheap_errors += 1;
-              printf("!!! dangling reference at %#tx to %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)p);
-              printf("from: "); segment_tell(seg);
-              printf("to:   "); segment_tell(ptr_get_segment(p));
-            }
-            pp1 += 1;
+          while (pp1 < pp2) {
+            if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(pp1)] & segment_bitmap_bit(pp1))) {
+              int a;
+              for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) {
+#define         in_ephemeron_pair_part(pp1, seg) ((((uptr)(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair)
+                if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) {
+                  /* skip non-pair part of ephemeron */
+                } else {
+                  p = *pp1;
+                  if (p == forward_marker) {
+                    pp1 = pp2; /* break out of outer loop */
+                    break;
+                  } else if (!IMMEDIATE(p)) {
+                    seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
+                    if (psi != NULL) {
+                      if ((psi->space == space_empty)
+                          || psi->old_space
+                          || (psi->marked_mask && !(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p)))) {
+                        S_checkheap_errors += 1;
+                        printf("!!! dangling reference at %#tx to %#tx%s\n", (ptrdiff_t)pp1, (ptrdiff_t)p, (aftergc ? " after gc" : ""));
+                        printf("from: "); segment_tell(seg);
+                        printf("to:   "); segment_tell(ptr_get_segment(p));
+                        {
+                          ptr l;
+                          for (l = S_G.locked_objects[psi->generation]; l != Snil; l = Scdr(l))
+                            if (Scar(l) == p)
+                              printf(" in locked\n");
+                          for (l = S_G.unlocked_objects[psi->generation]; l != Snil; l = Scdr(l))
+                            if (Scar(l) == p)
+                              printf(" in unlocked\n");
+                        }
+                      }
+                    }
+                  }
+                }
+                pp1 += 1;
+              }
+            } else
+              pp1 += ptr_alignment;
           }
 
           /* verify that dirty bits are set appropriately */
           /* out of date: doesn't handle space_impure_record, space_port, and maybe others */
           /* also doesn't check the SYMCODE for symbols */
-          if (s == space_impure || s == space_symbol || s == space_weakpair /* || s == space_ephemeron */) {
+          if (s == space_impure || s == space_symbol || s == space_weakpair || s == space_ephemeron
+              || s == space_immobile_impure || s == space_closure) {
             found_eos = 0;
             pp2 = pp1 = build_ptr(seg, 0);
             for (d = 0; d < cards_per_segment; d += 1) {
@@ -614,40 +715,58 @@ void S_check_heap(aftergc) IBOOL aftergc; {
 #endif
 
               dirty = 0xff;
-              while (pp1 != pp2) {
-                seginfo *psi;
-                p = *pp1;
-
-                if (p == forward_marker) {
-                  found_eos = 1;
-                  break;
-                }
-                if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && (pg = psi->generation) < g) {
-                  if (pg < dirty) dirty = pg;
-                  if (si->dirty_bytes[d] > pg) {
-                    S_checkheap_errors += 1;
-                    check_heap_dirty_msg("!!! INVALID", pp1);
+              while (pp1 < pp2) {
+                if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(pp1)] & segment_bitmap_bit(pp1))) {
+                  int a;
+                  for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) {
+                    if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) {
+                      /* skip non-pair part of ephemeron */
+                    } else {
+                      p = *pp1;
+                      
+                      if (p == forward_marker) {
+                        found_eos = 1;
+                        pp1 = pp2;
+                        break;
+                      } else if (!IMMEDIATE(p)) {
+                        seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
+                        if ((psi != NULL) && ((pg = psi->generation) < g)) {
+                          if (pg < dirty) dirty = pg;
+                          if (si->dirty_bytes[d] > pg) {
+                            S_checkheap_errors += 1;
+                            check_heap_dirty_msg("!!! INVALID", pp1);
+                          } else if (checkheap_noisy)
+                            check_heap_dirty_msg("... ", pp1);
+                        }
+                      }
+                    }
+                    pp1 += 1;
                   }
-                  else if (checkheap_noisy)
-                    check_heap_dirty_msg("... ", pp1);
+                } else {
+                  pp1 += ptr_alignment;
                 }
-                pp1 += 1;
               }
+              
               if (checkheap_noisy && si->dirty_bytes[d] < dirty) {
                 /* sweep_dirty won't sweep, and update dirty byte, for
                    cards with dirty pointers to segments older than the
                    maximum copyied generation, so we can get legitimate
                    conservative dirty bytes even after gc */
                 printf("... Conservative dirty byte %x (%x) %sfor segment %#tx card %d ",
-                    si->dirty_bytes[d], dirty,
-                    (aftergc ? "after gc " : ""),
-                    (ptrdiff_t)seg, d);
+                       si->dirty_bytes[d], dirty,
+                       (aftergc ? "after gc " : ""),
+                       (ptrdiff_t)seg, d);
                 segment_tell(seg);
               }
             }
           }
         }
-        if (aftergc && s != space_empty && !(s & space_locked) && (g == 0 || (s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron && s != space_impure_record))) {
+        if (aftergc
+            && (s != space_empty)
+            && (g == 0
+                || (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron
+                    && s != space_impure_record && s != space_impure_typed_object
+                    && s != space_immobile_impure && s != space_count_impure && s != space_closure))) {
           for (d = 0; d < cards_per_segment; d += 1) {
             if (si->dirty_bytes[d] != 0xff) {
               S_checkheap_errors += 1;
@@ -661,6 +780,21 @@ void S_check_heap(aftergc) IBOOL aftergc; {
       chunk = chunk->next;
     }
   }
+
+  {
+    for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) {
+      ptr l;
+      for (l = S_G.locked_objects[g]; l != Snil; l = Scdr(l))
+        check_locked_object(Scar(l), 1, g, aftergc, mcg);
+      for (l = S_G.unlocked_objects[g]; l != Snil; l = Scdr(l))
+        check_locked_object(Scar(l), 0, g, aftergc, mcg);
+    }
+  }
+
+  if (S_checkheap_errors) {
+    printf("heap check failed%s\n", (aftergc ? " after gc" : ""));
+    exit(1);
+  }
 }
 
 static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g) {
@@ -677,7 +811,6 @@ static void check_dirty_space(ISPC s) {
 
   for (from_g = 0; from_g <= static_generation; from_g += 1) {
     for (si = S_G.occupied_segments[s][from_g]; si != NULL; si = si->next) {
-      if (si->space & space_locked) continue;
       min_to_g = 0xff;
       for (d = 0; d < cards_per_segment; d += 1) {
         to_g = si->dirty_bytes[d];
@@ -717,7 +850,7 @@ static void check_dirty() {
         }
       } else {
         while (si != NULL) {
-          ISPC s = si->space & ~space_locked;
+          ISPC s = si->space;
           IGEN g = si->generation;
           IGEN mingval = si->min_dirty_byte;
           if (g != from_g) {
@@ -728,7 +861,9 @@ static void check_dirty() {
             S_checkheap_errors += 1;
             printf("!!! (check_dirty): dirty byte = %d for segment %#tx in %d -> %d dirty list\n", mingval, (ptrdiff_t)(si->number), from_g, to_g);
           }
-          if (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_impure_record && s != space_weakpair && s != space_ephemeron) {
+          if (s != space_new && s != space_impure && s != space_symbol && s != space_port
+              && s != space_impure_record && s != space_impure_typed_object && s != space_immobile_impure 
+              && s != space_weakpair && s != space_ephemeron) {
             S_checkheap_errors += 1;
             printf("!!! (check_dirty): unexpected space %d for dirty segment %#tx\n", s, (ptrdiff_t)(si->number));
           }
@@ -744,10 +879,40 @@ static void check_dirty() {
   check_dirty_space(space_impure_record);
   check_dirty_space(space_weakpair);
   check_dirty_space(space_ephemeron);
+  check_dirty_space(space_immobile_impure);
 
   fflush(stdout);
 }
 
+static void check_locked_object(ptr p, IBOOL locked, IGEN g, IBOOL aftergc, IGEN mcg)
+{
+  const char *what = (locked ? "locked" : "unlocked");
+  seginfo *psi = MaybeSegInfo(ptr_get_segment(p));
+  if (!psi) {
+    S_checkheap_errors += 1;
+    printf("!!! generation %d %s object has no segment: %p\n", g, what, p);
+  } else {
+    if (psi->generation != g) {
+      S_checkheap_errors += 1;
+      printf("!!! generation %d %s object in generation %d segment: %p\n", g, what, psi->generation, p);
+    }
+    if (!psi->must_mark && locked) {
+      S_checkheap_errors += 1;
+      printf("!!! generation %d %s object not on must-mark page: %p\n", g, what, p);
+    }
+    if (!psi->marked_mask) {
+      if (aftergc && (psi->generation <= mcg)) {
+        S_checkheap_errors += 1;
+        printf("!!! %s object not in marked segment: %p\n", what, p);
+        printf(" in: "); segment_tell(psi->number);
+      }
+    } else if (!(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) {
+      S_checkheap_errors += 1;
+      printf("!!! generation %d %s object not marked: %p\n", g, what, p);
+    }
+  }
+}
+
 void S_fixup_counts(ptr counts) {
   IGEN g; U64 timestamp;
 
@@ -795,6 +960,8 @@ ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) {
       }
     }
     S_G.guardians[new_g] = S_G.guardians[old_g]; S_G.guardians[old_g] = Snil;
+    S_G.locked_objects[new_g] = S_G.locked_objects[old_g]; S_G.locked_objects[old_g] = Snil;
+    S_G.unlocked_objects[new_g] = S_G.unlocked_objects[old_g]; S_G.unlocked_objects[old_g] = Snil;
     S_G.buckets_of_generation[new_g] = S_G.buckets_of_generation[old_g]; S_G.buckets_of_generation[old_g] = NULL;
     if (S_G.enable_object_counts) {
       INT i; ptr ls;
@@ -877,7 +1044,6 @@ ptr S_do_gc(IGEN mcg, IGEN tg, ptr count_roots) {
   return result;
 }
 
-
 ptr S_gc(ptr tc, IGEN mcg, IGEN tg, ptr count_roots) {
   if (tg == static_generation
       || S_G.enable_object_counts || S_G.enable_object_backreferences
diff --git a/src/ChezScheme/c/globals.h b/src/ChezScheme/c/globals.h
index 92cfe40875..0da2669888 100644
--- a/src/ChezScheme/c/globals.h
+++ b/src/ChezScheme/c/globals.h
@@ -123,10 +123,13 @@ EXTERN struct S_G_struct {
 
   /* gc.c */
     ptr guardians[static_generation+1];
+    ptr locked_objects[static_generation+1];
+    ptr unlocked_objects[static_generation+1];
     IGEN min_free_gen;
     IGEN new_min_free_gen;
     IGEN max_nonstatic_generation;
     IGEN new_max_nonstatic_generation;
+    IGEN min_mark_gen;
     uptr countof[static_generation+1][countof_types];
     uptr bytesof[static_generation+1][countof_types];
     uptr gctimestamp[static_generation+1];
@@ -135,8 +138,8 @@ EXTERN struct S_G_struct {
     ptr static_id;
     ptr countof_names;
     ptr gcbackreference[static_generation+1];
-    uptr phantom_sizes[static_generation+1];
     IGEN prcgeneration;
+    uptr bytes_finalized;
 
   /* intern.c */
     iptr oblist_length;
diff --git a/src/ChezScheme/c/number.c b/src/ChezScheme/c/number.c
index 402959d827..52cd171d44 100644
--- a/src/ChezScheme/c/number.c
+++ b/src/ChezScheme/c/number.c
@@ -25,7 +25,7 @@
 #include "system.h"
 
 /* locally defined functions */
-         static ptr copy_normalize PROTO((ptr tc, const bigit *p, iptr len, IBOOL sign, IBOOL clear_w));
+static ptr copy_normalize PROTO((ptr tc, const bigit *p, iptr len, IBOOL sign));
 static IBOOL abs_big_lt PROTO((ptr x, ptr y, iptr xl, iptr yl));
 static IBOOL abs_big_eq PROTO((ptr x, ptr y, iptr xl, iptr yl));
 static ptr big_negate PROTO((ptr tc, ptr x));
@@ -164,7 +164,7 @@ ptr S_normalize_bignum(ptr x) {
   return x;
 }
 
-static ptr copy_normalize(tc, p, len, sign, clear_w) ptr tc; const bigit *p; iptr len; IBOOL sign, clear_w; {
+static ptr copy_normalize(tc, p, len, sign) ptr tc; const bigit *p; iptr len; IBOOL sign; {
   bigit *p1; uptr n; ptr b;
 
   for (;;) {
@@ -199,10 +199,6 @@ static ptr copy_normalize(tc, p, len, sign, clear_w) ptr tc; const bigit *p; ipt
 
   b = S_bignum(tc, len, sign);
   for (p1 = &BIGIT(b, 0); len--;) *p1++ = *p++;
-
-  if (clear_w)
-    W(tc) = FIX(0);
-
   return b;
 }
 
@@ -516,7 +512,7 @@ addition/subtraction
 */
 
 static ptr big_negate(tc, x) ptr tc, x; {
-  return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x),0);
+  return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x));
 }
 
 ptr S_big_negate(x) ptr x; {
@@ -542,7 +538,7 @@ static ptr big_add_pos(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
 
   *zp = k;
 
-  return copy_normalize(tc, zp,xl+1,sign, 1);
+  return copy_normalize(tc, zp,xl+1,sign);
 }
 
 /* assumptions: x >= y */
@@ -562,7 +558,7 @@ static ptr big_add_neg(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
   for (; i-- > 0; )
     *zp-- = *xp--;
 
-  return copy_normalize(tc, zp+1,xl,sign, 1);
+  return copy_normalize(tc, zp+1,xl,sign);
 }
 
 static ptr big_add(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL xs, ys; {
@@ -652,7 +648,7 @@ static ptr big_mul(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign
       *zpa = k;
     }
 
-  return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign, 1);
+  return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign);
 }
 
 /* SHORTRANGE is -floor(sqrt(most_positive_fixnum))..floor(sqrt(most_positive_fixnum)).
@@ -778,10 +774,8 @@ static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs,
   for (i = xl, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i-- > 0; )
     EDIV(k, *xp++, s, zp++, &k)
 
-  if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs, 0);
-  if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs, 0);
-
-  W(tc) = FIX(0);
+  if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs);
+  if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs);
 }
 
 static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
@@ -807,7 +801,7 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
     PREPARE_BIGNUM(tc, W(tc),m)
     p = &BIGIT(W(tc),0);
     for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(xp, yp, yl);
-    *q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs, 1);
+    *q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs);
   }
 
   if (r != (ptr *)NULL) {
@@ -815,11 +809,8 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
     if (d != 0) {
       for (i = yl, p = xp, k = 0; i-- > 0; p++) ERSH(d,p,&k)
     }
-    *r = copy_normalize(tc, xp, yl, rs, 0);
+    *r = copy_normalize(tc, xp, yl, rs);
   }
-
-  U(tc) = FIX(0);
-  V(tc) = FIX(0);
 }
 
 static INT normalize(xp, yp, xl, yl) bigit *xp, *yp; iptr xl, yl; {
@@ -919,7 +910,6 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
   iptr i;
   INT shft, asc;
   bigit *p, *xp, *yp, k, b;
-  ptr ret;
 
  /* Copy x to scratch bignum, with a leading zero */
   PREPARE_BIGNUM(tc, U(tc),xl+1)
@@ -982,19 +972,14 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
     if (asc != 0) {
       for (i = xl, p = xp, k = 0; i-- > 0; p++) ERSH(asc,p,&k)
     }
-    return copy_normalize(tc, xp,xl,0, 0);
+    return copy_normalize(tc, xp,xl,0);
   } else {
     bigit d, r;
 
     d = *yp;
     for (r = 0; xl-- > 0; xp++) EDIV(r, *xp, d, xp, &r)
-    ret = uptr_gcd((uptr)(d>>asc), (uptr)(r>>asc));
+    return uptr_gcd((uptr)(d>>asc), (uptr)(r>>asc));
   }
-
-  U(tc) = FIX(0);
-  V(tc) = FIX(0);
-
-  return ret;
 }
 
 ptr S_gcd(x, y) ptr x, y; {
@@ -1099,7 +1084,6 @@ double S_random_double(m1, m2, m3, m4, scale) U32 m1, m2, m3, m4; double scale;
 static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) {
   iptr i;
   bigit *xp, *zp, k;
-  double ret;
 
   PREPARE_BIGNUM(tc, W(tc),enough+1)
 
@@ -1113,17 +1097,12 @@ static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) {
  /* then see if there's a bit set somewhere beyond */
   while (k == 0 && i++ < xl) k = *xp++;
 
-  ret = floatify_normalize(&BIGIT(W(tc),0), xl*bigit_bits, sign, k != 0);
-
-  W(tc) = FIX(0);
-
-  return ret;
+  return floatify_normalize(&BIGIT(W(tc),0), xl*bigit_bits, sign, k != 0);
 }
 
 static double big_floatify(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign; {
   iptr i, ul;
   bigit *p, *xp, *yp, k;
-  double ret;
 
  /* copy x to U(tc), scaling with added zero bigits as necessary */
   ul = xl < yl + enough-1 ? yl + enough-1 : xl;
@@ -1148,13 +1127,7 @@ static double big_floatify(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IB
   k = 0;
   for (i = ul + 1, xp = &BIGIT(U(tc),ul); k == 0 && i-- > 0; xp--) k = *xp;
 
-  ret = floatify_normalize(&BIGIT(W(tc),0), (xl-yl+1)*bigit_bits, sign, k != 0);
-
-  W(tc) = FIX(0);
-  U(tc) = FIX(0);
-  V(tc) = FIX(0);
-
-  return ret;
+  return floatify_normalize(&BIGIT(W(tc),0), (xl-yl+1)*bigit_bits, sign, k != 0);
 }
 
 /* come in with exactly 'enough' bigits */
@@ -1374,7 +1347,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
       }
     }
 
-    return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign, 1);
+    return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign);
   } else { /* shift to the left */
     iptr xlplus, newxl;
 
@@ -1400,7 +1373,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
     }
     *--p1 = k;
 
-    return copy_normalize(tc, p1, newxl, sign, 1);
+    return copy_normalize(tc, p1, newxl, sign);
   }
 }
 
@@ -1496,7 +1469,7 @@ ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) {
     for (i = wl; i > 0; i -= 1, p1 += 1) ERSH(start,p1,&k)
   }
 
-  return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0, 1);
+  return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0);
 }
 
 /* logical operations simulate two's complement operations using the
@@ -1562,7 +1535,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
       PREPARE_BIGNUM(tc, W(tc),yl);
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
       for (i = yl; i > 0; i -= 1) *--zp = *--xp & *--yp;
-      return copy_normalize(tc, zp, yl, 0, 1);
+      return copy_normalize(tc, zp, yl, 0);
     } else {
       bigit yb;
 
@@ -1577,7 +1550,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
      /* yb must be 0, since high-order bigit >= 1.  effectively, this
         means ~t2 would be all 1's from here on out. */
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(tc, zp, xl, 0, 1);
+      return copy_normalize(tc, zp, xl, 0);
     }
   } else {
     if (ys == 0) {
@@ -1591,7 +1564,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         xb = t2 > t1;
         *--zp = *--yp & ~t2;
       }
-      return copy_normalize(tc, zp, yl, 0, 1);
+      return copy_normalize(tc, zp, yl, 0);
     } else {
       bigit xb, yb, k;
 
@@ -1614,8 +1587,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-
-      return copy_normalize(tc, zp, xl+1, 1, 1);
+      return copy_normalize(tc, zp, xl+1, 1);
     }
   }
 }
@@ -1726,7 +1698,7 @@ static ptr big_logbitp(n, x, xl, xs) ptr x; iptr n, xl; IBOOL xs; {
     if (i < 0) return Sfalse;
 
     n = n % bigit_bits;
-    return Sboolean(BIGIT(x,i) & ((U32)1 << n));
+    return Sboolean(BIGIT(x,i) & ((bigit)1 << n));
   } else {
     bigit xb;
 
@@ -1736,7 +1708,7 @@ static ptr big_logbitp(n, x, xl, xs) ptr x; iptr n, xl; IBOOL xs; {
     xp = &BIGIT(x,xl); xb = 1;
     for (i = xl; ; i -= 1) {
       bigit t1 = *--xp, t2 = t1 - xb;
-      if (n < bigit_bits) return Sboolean(~t2 & ((U32)1 << n));
+      if (n < bigit_bits) return Sboolean(~t2 & (1 << n));
       xb = t2 > t1;
       n -= bigit_bits;
     }
@@ -1790,7 +1762,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
       }
       *--zp = *--xp & ~(1 << n);
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(tc, zp,xl,0, 1);
+      return copy_normalize(tc, zp,xl,0);
     }
   } else {
     bigit xb, k, x1, x2, z1, z2;
@@ -1816,7 +1788,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
       *--zp = z2;
     }
     *--zp = k;
-    return copy_normalize(tc, zp, zl, 1, 1);
+    return copy_normalize(tc, zp, zl, 1);
   }
 }
 
@@ -1859,9 +1831,9 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
       *--zp = x1;
       n -= bigit_bits;
     }
-    *--zp = x1 | ((U32)1 << n);
+    *--zp = x1 | ((bigit)1 << n);
     for (; i > 0; i -= 1) *--zp = *--xp;
-    return copy_normalize(tc, zp, zl, 0, 1);
+    return copy_normalize(tc, zp, zl, 0);
   } else if (yl > xl) {
    /* we'd just be setting a bit that's already (virtually) set */
     return origx;
@@ -1890,7 +1862,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
       *--zp = z2;
     }
     *--zp = k;
-    return copy_normalize(tc, zp, zl, 1, 1);
+    return copy_normalize(tc, zp, zl, 1);
   }
 }
 
@@ -1941,7 +1913,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
       for (i = yl; i > 0; i -= 1) *--zp = *--xp | *--yp;
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(tc, zp, xl, 0, 1);
+      return copy_normalize(tc, zp, xl, 0);
     } else {
       bigit yb, k;
 
@@ -1956,7 +1928,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(tc, zp, yl+1, 1, 1);
+      return copy_normalize(tc, zp, yl+1, 1);
     }
   } else {
     if (ys == 0) {
@@ -1980,7 +1952,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(tc, zp, xl+1, 1, 1);
+      return copy_normalize(tc, zp, xl+1, 1);
     } else {
       bigit xb, yb, k;
 
@@ -1996,7 +1968,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(tc, zp, yl+1, 1, 1);
+      return copy_normalize(tc, zp, yl+1, 1);
     }
   }
 }
@@ -2048,7 +2020,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
       xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
       for (i = yl; i > 0; i -= 1) *--zp = *--xp ^ *--yp;
       for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
-      return copy_normalize(tc, zp, xl, 0, 1);
+      return copy_normalize(tc, zp, xl, 0);
     } else {
       bigit yb, k;
 
@@ -2069,7 +2041,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(tc, zp, xl+1, 1, 1);
+      return copy_normalize(tc, zp, xl+1, 1);
     }
   } else {
     if (ys == 0) {
@@ -2093,7 +2065,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         *--zp = z2;
       }
       *--zp = k;
-      return copy_normalize(tc, zp, xl+1, 1, 1);
+      return copy_normalize(tc, zp, xl+1, 1);
     } else {
       bigit xb, yb;
 
@@ -2111,7 +2083,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
         x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
         *--zp = x2;
       }
-      return copy_normalize(tc, zp, xl, 0, 1);
+      return copy_normalize(tc, zp, xl, 0);
     }
   }
 }
diff --git a/src/ChezScheme/c/ppc32.c b/src/ChezScheme/c/ppc32.c
index 803740ccd3..6607771e84 100644
--- a/src/ChezScheme/c/ppc32.c
+++ b/src/ChezScheme/c/ppc32.c
@@ -40,7 +40,7 @@ void S_doflush(uptr start, uptr end) {
 #endif
 
   start &= ~(l1_max_cache_line_size - 1);
-  end = (end + l1_max_cache_line_size) & ~(l1_max_cache_line_size - 1);
+  end = (end + l1_max_cache_line_size - 1) & ~(l1_max_cache_line_size - 1);
 
   for(i = start; i < end; i += l1_dcache_line_size) {
     __asm__ __volatile__ ("dcbst 0, %0" :: "r" (i));
diff --git a/src/ChezScheme/c/prim.c b/src/ChezScheme/c/prim.c
index 8904a3605d..b5440173aa 100644
--- a/src/ChezScheme/c/prim.c
+++ b/src/ChezScheme/c/prim.c
@@ -20,7 +20,6 @@
 static void install_library_entry PROTO((ptr n, ptr x));
 static void scheme_install_library_entry PROTO((void));
 static void create_library_entry_vector PROTO((void));
-static void install_c_entry PROTO((iptr i, ptr x));
 static void create_c_entry_vector PROTO((void));
 static void s_instantiate_code_object PROTO((void));
 static void s_link_code_object PROTO((ptr co, ptr objs));
@@ -85,7 +84,7 @@ ptr int2ptr(iptr f)
 #define proc2ptr(x) (ptr)(iptr)(x)
 #endif /* HPUX */
 
-static void install_c_entry(i, x) iptr i; ptr x; {
+void S_install_c_entry(i, x) iptr i; ptr x; {
     if (i < 0 || i >= c_entry_vector_size)
         S_error1("install_c_entry", "invalid index ~s", FIX(i));
     if (Svector_ref(S_G.c_entry_vector, i) != Sfalse)
@@ -116,41 +115,46 @@ static void create_c_entry_vector() {
     for (i = 0; i < c_entry_vector_size; i++)
         INITVECTIT(S_G.c_entry_vector, i) = Sfalse;
 
-    install_c_entry(CENTRY_thread_context, proc2ptr(S_G.thread_context));
-    install_c_entry(CENTRY_get_thread_context, proc2ptr(s_get_thread_context));
-    install_c_entry(CENTRY_handle_apply_overflood, proc2ptr(S_handle_apply_overflood));
-    install_c_entry(CENTRY_handle_docall_error, proc2ptr(S_handle_docall_error));
-    install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow));
-    install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood));
-    install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol));
-    install_c_entry(CENTRY_thread_list, (ptr)&S_threads);
-    install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize));
+    S_install_c_entry(CENTRY_thread_context, proc2ptr(S_G.thread_context));
+    S_install_c_entry(CENTRY_get_thread_context, proc2ptr(s_get_thread_context));
+    S_install_c_entry(CENTRY_handle_apply_overflood, proc2ptr(S_handle_apply_overflood));
+    S_install_c_entry(CENTRY_handle_docall_error, proc2ptr(S_handle_docall_error));
+    S_install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow));
+    S_install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood));
+    S_install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol));
+    S_install_c_entry(CENTRY_thread_list, (ptr)&S_threads);
+    S_install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize));
 #ifdef PTHREADS
-    install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond);
-    install_c_entry(CENTRY_raw_collect_thread0_cond, (ptr)&S_collect_thread0_cond);
-    install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex);
-    install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
-    install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));
-    install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread));
+    S_install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond);
+    S_install_c_entry(CENTRY_raw_collect_thread0_cond, (ptr)&S_collect_thread0_cond);
+    S_install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex);
+    S_install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
+    S_install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));
+    S_install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread));
 #endif /* PTHREADS */
-    install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
-    install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
-    install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error));
-    install_c_entry(CENTRY_handle_event_detour, proc2ptr(S_handle_event_detour));
-    install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry));
-    install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry));
-    install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room));
-    install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set));
-    install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object));
-    install_c_entry(CENTRY_Sreturn, proc2ptr(S_return));
-    install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
-    install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
-    install_c_entry(CENTRY_segment_info, proc2ptr(S_segment_info));
-    install_c_entry(CENTRY_bignum_mask_test, proc2ptr(S_bignum_mask_test));
+    S_install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
+    S_install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
+    S_install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error));
+    S_install_c_entry(CENTRY_handle_event_detour, proc2ptr(S_handle_event_detour));
+    S_install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry));
+    S_install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry));
+    S_install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room));
+    S_install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set));
+    S_install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object));
+    S_install_c_entry(CENTRY_Sreturn, proc2ptr(S_return));
+    S_install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
+    S_install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
+    S_install_c_entry(CENTRY_segment_info, proc2ptr(S_segment_info));
+    S_install_c_entry(CENTRY_bignum_mask_test, proc2ptr(S_bignum_mask_test));
+}
+
+void S_check_c_entry_vector() {
+    INT i;
 
     for (i = 0; i < c_entry_vector_size; i++) {
 #ifndef PTHREADS
-      if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex
+      if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_collect_thread0_cond
+          || i == CENTRY_raw_tc_mutex
           || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread
           || i == CENTRY_unactivate_thread)
         continue;
@@ -170,6 +174,7 @@ void S_prim_init() {
 
     Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp);
     Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated);
+    Sforeign_symbol("(cs)bytes_finalized", (void *)S_bytes_finalized);
     Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes);
     Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes);
     Sforeign_symbol("(cs)resetmaxmembytes", (void *)S_resetmaxmembytes);
@@ -188,6 +193,8 @@ void S_prim_init() {
     Sforeign_symbol("(cs)maxgen", (void *)S_maxgen);
     Sforeign_symbol("(cs)set_maxgen", (void *)S_set_maxgen);
     Sforeign_symbol("(cs)minfreegen", (void *)S_minfreegen);
+    Sforeign_symbol("(cs)set_minmarkgen", (void *)S_set_minmarkgen);
+    Sforeign_symbol("(cs)minmarkgen", (void *)S_minmarkgen);
     Sforeign_symbol("(cs)set_minfreegen", (void *)S_set_minfreegen);
     Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
     Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
@@ -197,6 +204,8 @@ void S_prim_init() {
     Sforeign_symbol("(cs)enable_object_backreferences", (void *)S_enable_object_backreferences);
     Sforeign_symbol("(cs)set_enable_object_backreferences", (void *)S_set_enable_object_backreferences);
     Sforeign_symbol("(cs)object_backreferences", (void *)S_object_backreferences);
+    Sforeign_symbol("(cs)list_bits_ref", (void *)S_list_bits_ref);
+    Sforeign_symbol("(cs)list_bits_set", (void *)S_list_bits_set);
 }
 
 static void s_instantiate_code_object() {
@@ -215,6 +224,8 @@ static void s_instantiate_code_object() {
     new = S_code(tc, CODETYPE(old), CODELEN(old));
     tc_mutex_release()
 
+    S_immobilize_object(new);
+
     oldreloc = CODERELOC(old);
     size = RELOCSIZE(oldreloc);
     newreloc = S_relocation_table(size);
diff --git a/src/ChezScheme/c/prim5.c b/src/ChezScheme/c/prim5.c
index 2b8213386a..0bcfe5d004 100644
--- a/src/ChezScheme/c/prim5.c
+++ b/src/ChezScheme/c/prim5.c
@@ -35,6 +35,9 @@ static ptr s_fltofx PROTO((ptr x));
 static ptr s_weak_pairp PROTO((ptr p));
 static ptr s_ephemeron_cons PROTO((ptr car, ptr cdr));
 static ptr s_ephemeron_pairp PROTO((ptr p));
+static ptr s_box_immobile PROTO((ptr p));
+static ptr s_make_immobile_vector PROTO((uptr len, ptr fill));
+static ptr s_make_immobile_bytevector PROTO((uptr len));
 static ptr s_oblist PROTO((void));
 static ptr s_bigoddp PROTO((ptr n));
 static ptr s_float PROTO((ptr x));
@@ -176,24 +179,55 @@ static ptr s_fltofx(x) ptr x; {
 
 static ptr s_weak_pairp(p) ptr p; {
   seginfo *si;
-  return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~space_locked) == space_weakpair ? Strue : Sfalse;
+  return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space == space_weakpair ? Strue : Sfalse;
 }
 
 static ptr s_ephemeron_cons(car, cdr) ptr car, cdr; {
   ptr p;
 
   tc_mutex_acquire()
-  find_room(space_ephemeron, 0, type_pair, size_ephemeron, p);
+  p = S_ephemeron_cons_in(0, car, cdr);
   tc_mutex_release()
-  INITCAR(p) = car;
-  INITCDR(p) = cdr;
 
   return p;
 }
 
 static ptr s_ephemeron_pairp(p) ptr p; {
   seginfo *si;
-  return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~space_locked) == space_ephemeron ? Strue : Sfalse;
+  return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->space == space_ephemeron ? Strue : Sfalse;
+}
+
+static ptr s_box_immobile(p) ptr p; {
+  ptr b = S_box2(p, 1);
+  S_immobilize_object(b);
+  return b;
+}
+
+static ptr s_make_immobile_bytevector(uptr len) {
+  ptr b = S_bytevector2(len, 1);
+  S_immobilize_object(b);
+  return b;
+}
+
+static ptr s_make_immobile_vector(uptr len, ptr fill) {
+  ptr v;
+  uptr i;
+
+  tc_mutex_acquire()
+  v = S_vector_in(space_immobile_impure, 0, len);
+  tc_mutex_release()
+
+  S_immobilize_object(v);
+  
+  for (i = 0; i < len; i++)
+    INITVECTIT(v, i) = fill;
+
+  if (!(len & 0x1)) {
+    /* pad, since we're not going to copy on a GC */
+    INITVECTIT(v, len) = FIX(0);
+  }
+
+  return v;
 }
 
 static ptr s_oblist() {
@@ -508,7 +542,7 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) {
 
     fprintf(out, "\nMap of occupied segments:\n");
     for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) {
-      seginfo *si; ISPC real_s;
+      seginfo *si;
 
       chunk = Scar(ls);
 
@@ -545,11 +579,9 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) {
         }
 
         si = &chunk->sis[i];
-        real_s = si->space;
-        s = real_s & ~(space_locked | space_old);
+        s = si->space;
         if (s < 0 || s > max_space) s = space_bogus;
-        spaceline[segwidth+segsprinted] =
-          real_s & (space_locked | space_old) ? toupper(spacechar[s]) : spacechar[s];
+        spaceline[segwidth+segsprinted] = spacechar[s];
 
         g = si->generation;
         genline[segwidth+segsprinted] =
@@ -1265,7 +1297,7 @@ static void c_exit(UNUSED I32 status) {
 #else /* defined(__STDC__) || defined(USE_ANSI_PROTOTYPES) */
 extern double sin(), cos(), tan(), asin(), acos(), atan(), atan2();
 extern double sinh(), cosh(), tanh(), exp(), log(), pow(), sqrt();
-extern double floor(), ceil(), HYPOT();
+extern double floor(), ceil(), round(), trunc(), HYPOT();
 #ifdef ARCHYPERBOLIC
 extern double asinh(), acosh(), atanh();
 #endif /* ARCHHYPERBOLIC */
@@ -1280,6 +1312,9 @@ static double s_exp(x) double x; { return exp(x); }
 static double s_log PROTO((double x));
 static double s_log(x) double x; { return log(x); }
 
+static double s_log2 PROTO((double x, double y));
+static double s_log2(x, y) double x, y; { return log(x) / log(y); }
+
 static double s_pow PROTO((double x, double y));
 #if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb)
 #include <ieeefp.h>
@@ -1344,6 +1379,12 @@ static double s_floor(x) double x; { return floor(x); }
 static double s_ceil PROTO((double x));
 static double s_ceil(x) double x; { return ceil(x); }
 
+static double s_round PROTO((double x));
+static double s_round(x) double x; { return rint(x); }
+
+static double s_trunc PROTO((double x));
+static double s_trunc(x) double x; { return trunc(x); }
+
 static double s_hypot PROTO((double x, double y));
 static double s_hypot(x, y) double x, y; { return HYPOT(x, y); }
 
@@ -1414,12 +1455,12 @@ static s_thread_rv_t s_backdoor_thread_start(p) void *p; {
   display("backdoor thread started\n")
   (void) Sactivate_thread();
   display("thread activated\n")
-  Scall0((ptr)p);
+  Scall0((ptr)Sunbox(p));
   (void) Sdeactivate_thread();
   display("thread deactivated\n")
   (void) Sactivate_thread();
   display("thread reeactivated\n")
-  Scall0((ptr)p);
+  Scall0((ptr)Sunbox(p));
   Sdestroy_thread();
   display("thread destroyed\n")
   s_thread_return;
@@ -1509,6 +1550,8 @@ void S_dump_tc(ptr tc) {
   fflush(stdout);
 }
 
+#define proc2ptr(x) (ptr)(iptr)(x)
+
 void S_prim5_init() {
     if (!S_boot_time) return;
 
@@ -1535,6 +1578,9 @@ void S_prim5_init() {
     Sforeign_symbol("(cs)s_weak_pairp", (void *)s_weak_pairp);
     Sforeign_symbol("(cs)s_ephemeron_cons", (void *)s_ephemeron_cons);
     Sforeign_symbol("(cs)s_ephemeron_pairp", (void *)s_ephemeron_pairp);
+    Sforeign_symbol("(cs)box_immobile", (void *)s_box_immobile);
+    Sforeign_symbol("(cs)make_immobile_vector", (void *)s_make_immobile_vector);
+    Sforeign_symbol("(cs)make_immobile_bytevector", (void *)s_make_immobile_bytevector);
     Sforeign_symbol("(cs)continuation_depth", (void *)S_continuation_depth);
     Sforeign_symbol("(cs)single_continuation", (void *)S_single_continuation);
     Sforeign_symbol("(cs)c_exit", (void *)c_exit);
@@ -1724,6 +1770,25 @@ void S_prim5_init() {
 #endif
     Sforeign_symbol("(cs)s_profile_counters", (void *)s_profile_counters);
     Sforeign_symbol("(cs)s_profile_release_counters", (void *)s_profile_release_counters);
+
+    S_install_c_entry(CENTRY_flfloor, proc2ptr(s_floor));
+    S_install_c_entry(CENTRY_flceiling, proc2ptr(s_ceil));
+    S_install_c_entry(CENTRY_flround, proc2ptr(s_round));
+    S_install_c_entry(CENTRY_fltruncate, proc2ptr(s_trunc));
+    S_install_c_entry(CENTRY_flsin, proc2ptr(s_sin));
+    S_install_c_entry(CENTRY_flcos, proc2ptr(s_cos));
+    S_install_c_entry(CENTRY_fltan, proc2ptr(s_tan));
+    S_install_c_entry(CENTRY_flasin, proc2ptr(s_asin));
+    S_install_c_entry(CENTRY_flacos, proc2ptr(s_acos));
+    S_install_c_entry(CENTRY_flatan, proc2ptr(s_atan));
+    S_install_c_entry(CENTRY_flatan2, proc2ptr(s_atan2));
+    S_install_c_entry(CENTRY_flexp, proc2ptr(s_exp));
+    S_install_c_entry(CENTRY_fllog, proc2ptr(s_log));
+    S_install_c_entry(CENTRY_fllog2, proc2ptr(s_log2));
+    S_install_c_entry(CENTRY_flexpt, proc2ptr(s_pow));
+    S_install_c_entry(CENTRY_flsqrt, proc2ptr(s_sqrt));
+
+    S_check_c_entry_vector();
 }
 
 static ptr s_get_reloc(co, with_offsets) ptr co; IBOOL with_offsets; {
diff --git a/src/ChezScheme/c/random.c b/src/ChezScheme/c/random.c
index d496d3a369..c7d80a718d 100644
--- a/src/ChezScheme/c/random.c
+++ b/src/ChezScheme/c/random.c
@@ -22,12 +22,14 @@
 
 /* Representation is arecord with 6 `double` fields: */
 
-#define RANDSTATEX10(x) (((double*)&RECORDINSTIT(x, 0))[0])
-#define RANDSTATEX11(x) (((double*)&RECORDINSTIT(x, 0))[1])
-#define RANDSTATEX12(x) (((double*)&RECORDINSTIT(x, 0))[2])
-#define RANDSTATEX20(x) (((double*)&RECORDINSTIT(x, 0))[3])
-#define RANDSTATEX21(x) (((double*)&RECORDINSTIT(x, 0))[4])
-#define RANDSTATEX22(x) (((double*)&RECORDINSTIT(x, 0))[5])
+#define RECORDINSTDBLA(x) ((double *)((uptr)&RECORDINSTIT(x, 0) + (max_float_alignment - ptr_bytes)))
+
+#define RANDSTATEX10(x) (RECORDINSTDBLA(x)[0])
+#define RANDSTATEX11(x) (RECORDINSTDBLA(x)[1])
+#define RANDSTATEX12(x) (RECORDINSTDBLA(x)[2])
+#define RANDSTATEX20(x) (RECORDINSTDBLA(x)[3])
+#define RANDSTATEX21(x) (RECORDINSTDBLA(x)[4])
+#define RANDSTATEX22(x) (RECORDINSTDBLA(x)[5])
 
 /* The Generator
    =============
diff --git a/src/ChezScheme/c/schlib.c b/src/ChezScheme/c/schlib.c
index 4f3c2e300d..772e95487b 100644
--- a/src/ChezScheme/c/schlib.c
+++ b/src/ChezScheme/c/schlib.c
@@ -216,7 +216,9 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t
      the C stack and we may end up in a garbage collection */
     code = CP(tc);
     if (Sprocedurep(code)) code = CLOSCODE(code);
-    Slock_object(code);
+    if (!IMMEDIATE(code) && !Scodep(code))
+      S_error_abort("S_call_help: invalid code pointer");
+    S_immobilize_object(code);
 
     CP(tc) = AC1(tc);
 
@@ -226,7 +228,7 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t
     if (lock_ts) {
       /* Lock a code object passed in TS, which is a more immediate
          caller whose return address is on the C stack */
-      Slock_object(TS(tc));
+      S_immobilize_object(TS(tc));
       CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc));
     } else {
       CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc));
@@ -293,8 +295,8 @@ void S_return() {
   /* error checks are done; now unlock affected code objects */
     for (xp = CCHAIN(tc); ; xp = Scdr(xp)) {
         ptr p = CDAR(xp);
-        Sunlock_object(Scar(p));
-        if (Scdr(p) != Sfalse) Sunlock_object(Scdr(p));
+        S_mobilize_object(Scar(p));
+        if (Scdr(p) != Sfalse) S_mobilize_object(Scdr(p));
         if (xp == yp) break;
         FREEJMPBUF(CAAR(xp));
     }
diff --git a/src/ChezScheme/c/segment.c b/src/ChezScheme/c/segment.c
index cef05b75de..f77c8ba93e 100644
--- a/src/ChezScheme/c/segment.c
+++ b/src/ChezScheme/c/segment.c
@@ -58,6 +58,13 @@ void S_segment_init() {
   }
   S_G.number_of_nonstatic_segments = 0;
   S_G.number_of_empty_segments = 0;
+
+  if (seginfo_space_disp != offsetof(seginfo, space))
+    S_error_abort("seginfo_space_disp is wrong");
+  if (seginfo_generation_disp != offsetof(seginfo, generation))
+    S_error_abort("seginfo_generation_disp is wrong");
+  if (seginfo_list_bits_disp != offsetof(seginfo, list_bits))
+    S_error_abort("seginfo_list_bits_disp is wrong");
 }
 
 static uptr membytes = 0;
@@ -229,6 +236,10 @@ static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) {
   si->space = s;
   si->generation = g;
   si->sorted = 0;
+  si->old_space = 0;
+  si->use_marks = 0;
+  si->must_mark = 0;
+  si->list_bits = NULL;
   si->min_dirty_byte = 0xff;
   for (d = 0; d < cards_per_segment; d += sizeof(ptr)) {
     iptr *dp = (iptr *)(si->dirty_bytes + d);
@@ -238,9 +249,7 @@ static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) {
   si->has_triggers = 0;
   si->trigger_ephemerons = 0;
   si->trigger_guardians = 0;
-  si->locked_objects = Snil;
-  si->unlocked_objects = Snil;
-  si->locked_mask = NULL;
+  si->marked_mask = NULL;
 #ifdef PRESERVE_FLONUM_EQ
   si->forwarded_flonums = NULL;
 #endif
@@ -380,6 +389,9 @@ static seginfo *allocate_segments(nreq) uptr nreq; {
       si->space = space_empty;
       si->generation = 0;
       si->sorted = 1; /* inserting in reverse order, so emptys are always sorted */
+      si->old_space = 0;
+      si->use_marks = 0;
+      si->must_mark = 0;
       si->next = chunk->unused_segs;
       chunk->unused_segs = si;
     }
@@ -434,6 +446,10 @@ void S_resetmaxmembytes(void) {
   maxmembytes = membytes;
 }
 
+void S_adjustmembytes(iptr amt) {
+  if ((membytes += amt) > maxmembytes) maxmembytes = membytes;
+}
+
 static void expand_segment_table(uptr base, uptr end, seginfo *si) {
 #ifdef segment_t2_bits
 #ifdef segment_t3_bits
diff --git a/src/ChezScheme/c/segment.h b/src/ChezScheme/c/segment.h
index 0d6c3b0210..361e083cc6 100644
--- a/src/ChezScheme/c/segment.h
+++ b/src/ChezScheme/c/segment.h
@@ -81,3 +81,4 @@ FORCEINLINE seginfo *MaybeSegInfo(uptr i) {
 
 #define SegmentSpace(i) (SegInfo(i)->space)
 #define SegmentGeneration(i) (SegInfo(i)->generation)
+#define SegmentOldSpace(i) (SegInfo(i)->old_space)
diff --git a/src/ChezScheme/c/thread.c b/src/ChezScheme/c/thread.c
index 1bc6967f1c..ffe0ac9336 100644
--- a/src/ChezScheme/c/thread.c
+++ b/src/ChezScheme/c/thread.c
@@ -349,9 +349,11 @@ void S_mutex_release(m) scheme_mutex_t *m; {
   if ((count = m->count) == 0 || !s_thread_equal(m->owner, self))
     S_error1("mutex-release", "thread does not own mutex ~s", m);
 
-  if ((m->count = count - 1) == 0)
+  if ((m->count = count - 1) == 0) {
+    m->owner = 0; /* needed for a memory model like ARM, for example */
     if ((status = s_thread_mutex_unlock(&m->pmutex)) != 0)
       S_error1("mutex-release", "failed: ~a", S_strerror(status));
+  }
 }
 
 s_thread_cond_t *S_make_condition() {
diff --git a/src/ChezScheme/c/types.h b/src/ChezScheme/c/types.h
index 8e681192a6..0172681629 100644
--- a/src/ChezScheme/c/types.h
+++ b/src/ChezScheme/c/types.h
@@ -114,24 +114,32 @@ typedef int IFASLCODE;      /* fasl type codes */
 #define addr_get_segment(p) ((uptr)(p) >> segment_offset_bits)
 #define ptr_get_segment(p) (((uptr)(p) + typemod - 1) >> segment_offset_bits)
 
-#define segment_bitmap_bytes    (bytes_per_segment >> (log2_ptr_bytes+3))
-#define segment_bitmap_index(p) ((((uptr)p + (typemod-1)) & (bytes_per_segment - 1)) >> log2_ptr_bytes)
-#define segment_bitmap_byte(p)  (segment_bitmap_index(p) >> 3)
-#define segment_bitmap_bit(p)   ((uptr)1 << (segment_bitmap_index(p) & 0x7))
+#define segment_bitmap_bytes      (bytes_per_segment >> (log2_ptr_bytes+3))
+#define segment_bitmap_index(p)   ((((uptr)(p) + (typemod-1)) & ~(typemod-1) & (bytes_per_segment - 1)) >> log2_ptr_bytes)
+#define segment_bitmap_byte(p)    (segment_bitmap_index(p) >> 3)
+#define segment_bitmap_bits(p, b) ((uptr)(b) << (segment_bitmap_index(p) & 0x7))
+#define segment_bitmap_bit(p)     segment_bitmap_bits(p,1)
 
 #define SPACE(p) SegmentSpace(ptr_get_segment(p))
 #define GENERATION(p) SegmentGeneration(ptr_get_segment(p))
+#define OLDSPACE(p) SegmentOldSpace(ptr_get_segment(p))
 
 #define ptr_align(size) (((size)+byte_alignment-1) & ~(byte_alignment-1))
 
+#define MUST_MARK_INFINITY 3
+
 /* The inlined implementation of primitives like `weak-pair?`
    rely on the first two fields of `seginfo`: */
 typedef struct _seginfo {
   unsigned char space;                      /* space the segment is in */
   unsigned char generation;                 /* generation the segment is in */
-  unsigned char sorted : 1;                 /* sorted indicator---possibly to be incorporated into space flags? */
+  unsigned char old_space : 1;              /* set during GC to indcate space being collected */
+  unsigned char use_marks : 1;              /* set during GC to indicate space to mark in place instead of copy */
+  unsigned char sorted : 1;                 /* sorted indicator */
   unsigned char has_triggers : 1;           /* set if trigger_ephemerons or trigger_guardians is set */
+  unsigned char must_mark : 2;              /* a form of locking, where 3 counts as "infinite" */
   octet min_dirty_byte;                     /* dirty byte for full segment, effectively min(dirty_bytes) */
+  octet *list_bits;                         /* for `$list-bits-ref` and `$list-bits-set!` */
   uptr number;                              /* the segment number */
   struct _chunkinfo *chunk;                 /* the chunk this segment belongs to */
   struct _seginfo *next;                    /* pointer to the next seginfo (used in occupied_segments and unused_segs */
@@ -139,9 +147,8 @@ typedef struct _seginfo {
   struct _seginfo *dirty_next;              /* pointer to the next seginfo on the DirtySegments list */
   ptr trigger_ephemerons;                   /* ephemerons to re-check if object in segment is copied out */
   ptr trigger_guardians;                    /* guardians to re-check if object in segment is copied out */
-  ptr locked_objects;                       /* list of objects (including duplicates) for locked in this segment */
-  ptr unlocked_objects;                     /* list of objects (no duplicates) for formerly locked */
-  octet *locked_mask;                       /* bitmap of locked objects, used only during GC */
+  octet *marked_mask;                       /* bitmap of live objects for a segment in "compacting" mode */
+  uptr marked_count;                        /* number of marked bytes in segment */
 #ifdef PRESERVE_FLONUM_EQ
   octet *forwarded_flonums;                 /* bitmap of flonums whose payload is a forwarding pointer */
 #endif
diff --git a/src/ChezScheme/c/vfasl.c b/src/ChezScheme/c/vfasl.c
index 1cd45421b1..70e1cd9c15 100644
--- a/src/ChezScheme/c/vfasl.c
+++ b/src/ChezScheme/c/vfasl.c
@@ -167,6 +167,7 @@ static ptr copy(vfasl_info *vfi, ptr pp, seginfo *si);
 static uptr sweep(vfasl_info *vfi, ptr p);
 static int is_rtd(ptr tf, vfasl_info *vfi);
 
+static IFASLCODE abs_reloc_variant(IFASLCODE type);
 static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj);
 static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets, IBOOL to_static);
 static ptr find_pointer_from_offset(uptr p_off, ptr *vspaces, uptr *vspace_offsets);
@@ -252,7 +253,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len)
         if (sz > 0) {
           if ((s == vspace_reloc) && !S_G.retain_static_relocation) {
             thread_find_room(tc, typemod, sz, vspaces[s])
-          } else { 
+          } else {
             find_room(vspace_spaces[s], static_generation, typemod, sz, vspaces[s])
           }
           if (S_fasl_stream_read(stream, vspaces[s], sz) < 0)
@@ -523,6 +524,13 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len)
     while (cl != end_closures) {
       ptr code = CLOSCODE(cl);
       code = ptr_add(code, code_delta);
+
+#if 0
+      printf("%p ", code);
+      S_prin1(CODENAME(code));
+      printf("\n");
+#endif
+
       SETCLOSCODE(cl,code);
       cl = ptr_add(cl, size_closure(CLOSLEN(cl)));
     }
@@ -533,6 +541,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len)
     ptr sym_base = vspaces[vspace_symbol];
     ptr code = TYPE(vspaces[vspace_code], type_typed_object);
     ptr code_end = TYPE(VSPACE_END(vspace_code), type_typed_object);
+    S_record_code_mod(tc, (uptr)vspaces[vspace_code], (uptr)code_end - (uptr)code);
     while (code != code_end) {
       relink_code(code, sym_base, vspaces, vspace_offsets, to_static);
       code = ptr_add(code, size_code(CODELEN(code)));
@@ -1076,6 +1085,27 @@ static int is_rtd(ptr tf, vfasl_info *vfi)
 #define VFASL_RELOC_TAG(p) (UNFIX(p) & ((1 << VFASL_RELOC_TAG_BITS) - 1))
 #define VFASL_RELOC_POS(p) (UNFIX(p) >> VFASL_RELOC_TAG_BITS)
 
+/* Picks a relocation variant that fits into the actual relocation's
+   shape, but holds an absolue value */
+static IFASLCODE abs_reloc_variant(IFASLCODE type) {
+  if (type == reloc_abs)
+    return reloc_abs;
+#if defined(I386) || defined(X86_64)
+  return reloc_abs;
+#elif defined(ARMV6)
+  return reloc_arm32_abs;
+#elif defined(AARCH64)
+  return reloc_arm64_abs;
+#elif defined(PPC32)
+  if (type == reloc_ppc32_abs)
+    return reloc_ppc32_abs;
+  else
+    return reloc_abs;
+#else
+  >> need to fill in for this platform <<
+#endif
+}
+
 static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj) {
   ptr pos;
   int which_singleton;
@@ -1083,12 +1113,15 @@ static ptr vfasl_encode_relocation(vfasl_info *vfi, ptr obj) {
   if ((which_singleton = detect_singleton(obj))) {
     obj = FIX(VFASL_RELOC_SINGLETON(which_singleton));
   } else if ((pos = vfasl_hash_table_ref(S_G.c_entries, obj))) {
+    pos = (ptr)((uptr)pos - 1);
     if ((uptr)pos == CENTRY_install_library_entry)
       vfi->installs_library_entry = 1;
     obj = FIX(VFASL_RELOC_C_ENTRY(pos));
   } else if ((pos = vfasl_hash_table_ref(S_G.library_entries, obj))) {
+    pos = (ptr)((uptr)pos - 1);
     obj = FIX(VFASL_RELOC_LIBRARY_ENTRY(pos));
   } else if ((pos = vfasl_hash_table_ref(S_G.library_entry_codes, obj))) {
+    pos = (ptr)((uptr)pos - 1);
     obj = FIX(VFASL_RELOC_LIBRARY_ENTRY_CODE(pos));
   } else if (Ssymbolp(obj)) {
     obj = vfasl_relocate_help(vfi, obj);
@@ -1135,7 +1168,7 @@ static void relink_code(ptr co, ptr sym_base, ptr *vspaces, uptr *vspace_offsets
             code_off = RELOC_CODE_OFFSET(entry);
         }
         a += code_off;
-        obj = S_get_code_obj(reloc_abs, co, a, item_off);
+        obj = S_get_code_obj(abs_reloc_variant(RELOC_TYPE(entry)), co, a, item_off);
 
         if (IMMEDIATE(obj)) {
           if (Sfixnump(obj)) {
@@ -1234,14 +1267,14 @@ static void fasl_init_entry_tables()
 
     for (i = Svector_length(S_G.c_entry_vector); i--; ) {
       ptr entry = Svector_ref(S_G.c_entry_vector, i);
-      vfasl_hash_table_set(S_G.c_entries, entry, (ptr)i);
+      vfasl_hash_table_set(S_G.c_entries, entry, (ptr)(i+1));
     }
 
     for (i = Svector_length(S_G.library_entry_vector); i--; ) {
       ptr entry = Svector_ref(S_G.library_entry_vector, i);
       if (entry != Sfalse) {
-        vfasl_hash_table_set(S_G.library_entries, entry, (ptr)i);
-        vfasl_hash_table_set(S_G.library_entry_codes, CLOSCODE(entry), (ptr)i);
+        vfasl_hash_table_set(S_G.library_entries, entry, (ptr)(i+1));
+        vfasl_hash_table_set(S_G.library_entry_codes, CLOSCODE(entry), (ptr)(i+1));
       }
     }
   }
diff --git a/src/ChezScheme/configure b/src/ChezScheme/configure
index b8e88737d2..08cd3e473e 100755
--- a/src/ChezScheme/configure
+++ b/src/ChezScheme/configure
@@ -82,6 +82,11 @@ case "${CONFIG_UNAME}" in
       m64=""
       tm32=tppc32le
       tm64=""
+    elif uname -a | egrep 'armv|aarch64' > /dev/null 2>&1 ; then
+      m32=arm32le
+      m64=arm64le
+      tm32=tarm32le
+      tm64=tarm64le
     fi
     installprefix=/usr
     installmansuffix=share/man
@@ -303,7 +308,7 @@ while [ $# != 0 ] ; do
 done
 
 if [ "$bits" = "" ] ; then
-  if uname -a | egrep 'amd64|x86_64' > /dev/null 2>&1 ; then
+  if uname -a | egrep 'amd64|x86_64|aarch64' > /dev/null 2>&1 ; then
     bits=64
   else
     bits=32
diff --git a/src/ChezScheme/makefiles/Mf-boot.in b/src/ChezScheme/makefiles/Mf-boot.in
index a079dd5888..6744c7407a 100644
--- a/src/ChezScheme/makefiles/Mf-boot.in
+++ b/src/ChezScheme/makefiles/Mf-boot.in
@@ -20,7 +20,7 @@ doit: $(bootfiles)
 %.boot:
 	( cd .. ; ./workarea $* xc-$* )
 	( cd ../xc-$*/s ; make -f Mf-cross base=../../$(workarea) --jobs=2 m=$(m) xm=$* )
-	for x in `echo scheme.boot petite.boot scheme.h equates.h` ; do\
+	for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc vfasl.inc` ; do\
           if [ ! -h ../xc-$*/boot/$*/$$x ] ; then \
             mv -f ../xc-$*/boot/$*/$$x ../boot/$*/$$x ;\
           fi ;\
diff --git a/src/ChezScheme/makefiles/Mf-install.in b/src/ChezScheme/makefiles/Mf-install.in
index b207e3c76e..71bb66cee5 100644
--- a/src/ChezScheme/makefiles/Mf-install.in
+++ b/src/ChezScheme/makefiles/Mf-install.in
@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.3.25
+Version=csv9.5.3.32
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot
diff --git a/src/ChezScheme/mats/4.ms b/src/ChezScheme/mats/4.ms
index 1505943ba4..a6ad005baf 100644
--- a/src/ChezScheme/mats/4.ms
+++ b/src/ChezScheme/mats/4.ms
@@ -4126,7 +4126,7 @@
           (let* ([g (make-guardian)] [x (list 'a 'b)])
             (g x)
             (collect 0 0)
-            (#%$keep-live x)
+            (keep-live x)
             (g)))
         #f)
    ;; same for ordered:
@@ -4134,7 +4134,7 @@
           (let* ([g (make-guardian #t)] [x (list 'a 'b)])
             (g x)
             (collect 0 0)
-            (#%$keep-live x)
+            (keep-live x)
             (g)))
         #f)
 
diff --git a/src/ChezScheme/mats/5_2.ms b/src/ChezScheme/mats/5_2.ms
index 8410009f24..3d506e5644 100644
--- a/src/ChezScheme/mats/5_2.ms
+++ b/src/ChezScheme/mats/5_2.ms
@@ -1338,3 +1338,98 @@
       (eqv? (car ls) 0)
       (eqv? (apply + ls) 4950)))
 )
+
+(mat list-assuming-immutable?
+  (list-assuming-immutable? '(1 2 3))
+  (not (list-assuming-immutable? '(1 2 . 3)))
+  (not (list-assuming-immutable? #t))
+  (not (list-assuming-immutable? 3))
+  (list-assuming-immutable? '())
+
+  ;; Check concurrent use of thread bits
+  (or (not (threaded?))
+      (let ([m (make-mutex)]
+            [c (make-condition)]
+            [running 4])
+        (define (fail msg) (printf "~a\n" msg) (exit))
+        (let thread-loop ([n-thread running])
+          (unless (zero? n-thread)
+            (fork-thread
+             (lambda ()
+               (let repeat-loop ([n 30] [l '()] [nl 0] [locked '()])
+                 (cond
+                   [(zero? n)
+                    (for-each unlock-object locked)
+                    (mutex-acquire m)
+                    (set! running (sub1 running))
+                    (condition-signal c)
+                    (mutex-release m)]
+                   [else
+                    (mutex-acquire m)
+                    (printf "trying ~a\n" n)
+                    (mutex-release m)
+                    (let ([N 10000])
+                      (let loop ([i N] [l l] [nl nl] [locked locked] [bvs '()])
+                        (cond
+                          [(zero? i)
+                           (let ([locked (let ([p (cons 1 2)])
+                                           (lock-object p)
+                                           (cons p locked))])
+                             (collect-rendezvous)
+                             (let ([check
+                                    (lambda ()
+                                      (let loop ([l l])
+                                        (when (pair? l)
+                                          (unless (list-assuming-immutable? l)
+                                            (fail "not a list?!"))
+                                          (loop (cdr l))))
+                                      (let loop ([nl nl])
+                                        (when (pair? nl)
+                                          (when (list-assuming-immutable? nl)
+                                            (fail "a list?!"))
+                                          (loop (cdr nl)))))])
+                               (check)
+                               (let ([locked (repeat-loop (sub1 n)
+                                                          (if (odd? n) l '())
+                                                          (if (even? n) nl 0)
+                                                          locked)])
+                                 (check)
+                                 locked)))]
+                          [else
+                           (let ([l (if (= 0 (modulo i 17))
+                                        l
+                                        (cons i l))]
+                                 [nl (if (= 0 (modulo i 3))
+                                         nl
+                                         (cons i nl))]
+                                 [locked (if #f ; (= i (/ N 2))
+                                             (let ([p (cons 1 2)])
+                                               (lock-object p)
+                                               (when (list-assuming-immutable? p)
+                                                 (fail "locked object is a list!?"))
+                                               (cons p locked))
+                                             locked)])
+                             (when (zero? (bitwise-and i (sub1 i)))
+                               (let inner-repeat-loop ([j 4])
+                                 (unless (zero? j)
+                                   (unless (list-assuming-immutable? l)
+                                     (fail "not a list?!"))
+                                   (when (list-assuming-immutable? nl)
+                                     (fail "a list?!"))
+                                   (inner-repeat-loop (sub1 j)))))
+                             (when (zero? (modulo i 100))
+                               (collect-rendezvous))
+                             (let ([bv (make-bytevector 12)]) ;; maybe same segment as list bits
+                               (bytevector-u8-set! bv 0 255)
+                               (bytevector-u8-set! bv 1 255)
+                               (bytevector-u8-set! bv 4 255)
+                               (loop (sub1 i) l nl locked (cons bv bvs))))])))]))))
+            (thread-loop (sub1 n-thread))))
+        (mutex-acquire m)
+        (let wait ()
+          (unless (= 0 running)
+            (condition-wait c m)
+            (wait)))
+        (mutex-release m)
+        #t))
+  )
diff --git a/src/ChezScheme/mats/Mf-base b/src/ChezScheme/mats/Mf-base
index 78a28d3d66..70cfc3e386 100644
--- a/src/ChezScheme/mats/Mf-base
+++ b/src/ChezScheme/mats/Mf-base
@@ -92,6 +92,10 @@ cgr = $(defaultcgr)
 defaultcmg = (collect-maximum-generation)
 cmg = $(defaultcmg)
 
+# ipmg is the value to which in-place-minimum-generation is set.
+defaultipmg = (in-place-minimum-generation)
+ipmg = $(defaultipmg)
+
 # rmg is the value to which release-minimum-generation is set.
 defaultrmg = (release-minimum-generation)
 rmg = $(defaultrmg)
@@ -161,6 +165,7 @@ $(objdir)/%.mo : %.ms mat.so
              '(collect-trip-bytes ${ctb})'\
              '(collect-generation-radix ${cgr})'\
              '(collect-maximum-generation ${cmg})'\
+             '(in-place-minimum-generation ${ipmg})'\
              '(enable-object-counts #${eoc})'\
              '(commonization-level ${cl})'\
              '(compile-interpret-simple #${cis})'\
@@ -185,6 +190,7 @@ $(objdir)/%.mo : %.ms mat.so
              '(collect-trip-bytes ${ctb})'\
              '(collect-generation-radix ${cgr})'\
              '(collect-maximum-generation ${cmg})'\
+             '(in-place-minimum-generation ${ipmg})'\
              '(enable-object-counts #${eoc})'\
              '(commonization-level ${cl})'\
              '(compile-interpret-simple #${cis})'\
@@ -359,6 +365,7 @@ script.all$o makescript$o:
              '(collect-trip-bytes ${ctb})'\
              '(collect-generation-radix ${cgr})'\
              '(collect-maximum-generation ${cmg})'\
+             '(in-place-minimum-generation ${ipmg})'\
              '(enable-object-counts #${eoc})'\
              '(commonization-level ${cl})'\
              '(compile-interpret-simple #${cis})'\
diff --git a/src/ChezScheme/mats/Mf-tarm32le b/src/ChezScheme/mats/Mf-tarm32le
new file mode 100644
index 0000000000..c045adc159
--- /dev/null
+++ b/src/ChezScheme/mats/Mf-tarm32le
@@ -0,0 +1,27 @@
+# Mf-tarm32le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = tarm32le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	cc -o cat_flush cat_flush.c
diff --git a/src/ChezScheme/mats/Mf-tarm64le b/src/ChezScheme/mats/Mf-tarm64le
new file mode 100644
index 0000000000..b93dcd7296
--- /dev/null
+++ b/src/ChezScheme/mats/Mf-tarm64le
@@ -0,0 +1,27 @@
+# Mf-tarm64le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = tarm64le
+
+fsrc = foreign1.c foreign2.c foreign3.c foreign4.c
+fobj = foreign1.so
+
+include Mf-base
+
+foreign1.so: ${fsrc} ../boot/$m/scheme.h
+	cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc}
+
+cat_flush: cat_flush.c
+	cc -o cat_flush cat_flush.c
diff --git a/src/ChezScheme/mats/bytevector.ms b/src/ChezScheme/mats/bytevector.ms
index ea574b7610..a1305e53c2 100644
--- a/src/ChezScheme/mats/bytevector.ms
+++ b/src/ChezScheme/mats/bytevector.ms
@@ -20,7 +20,10 @@
   (and (memq (native-endianness) '(big little)) #t)
   (eq? (native-endianness)
        (case (machine-type)
-         [(i3le ti3le i3nt ti3nt a6nt ta6nt i3ob ti3ob i3fb ti3fb i3nb ti3nb i3osx ti3osx a6le ta6le a6nb ta6nb a6osx ta6osx a6fb ta6fb a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx arm32le tarm32le) 'little]
+         [(i3le ti3le i3nt ti3nt a6nt ta6nt i3ob ti3ob i3fb ti3fb i3nb ti3nb i3osx ti3osx a6le ta6le a6nb ta6nb
+                a6osx ta6osx a6fb ta6fb a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx
+                arm32le tarm32le arm64le tarm64le)
+          'little]
          [(ppc32le tppc32le) 'big]
          [else (errorf #f "unrecognized machine type")]))
 )
diff --git a/src/ChezScheme/mats/cp0.ms b/src/ChezScheme/mats/cp0.ms
index bc038e72f2..3da3b9642c 100644
--- a/src/ChezScheme/mats/cp0.ms
+++ b/src/ChezScheme/mats/cp0.ms
@@ -369,6 +369,14 @@
             (y))))
   (error? (apply zero? 0))
   (error? (if (apply eof-object 1 2) 3 4))
+
+  (equivalent-expansion?
+   (expand/optimize '(lambda (t) (#3%$value (if t 1 (values 3 3 3))) #t))
+   (if (eqv? (optimize-level) 3)
+       '(lambda (x) #t)
+       '(lambda (x)
+          (#3%$value (if x 1 (#2%values 3 3 3)))
+          #t)))
 )
 
 (cp0-mat cp0-mrvs
@@ -1232,8 +1240,8 @@
            (fl+) (fl+ 3.0) (fl+ 3.0 4.0) (fl+ x) (fl+ x 0.0) (fl+ x -0.0) (fl+ 0.0 x) (fl+ -0.0 x) (fl+ x 3.0)
            (fl+ x 3.0 4.0) (fl+ 3.0 x 4.0) (fl+ 3.0 x -3.0) (fl+ (truncate -.5) x (/ -inf.0)) (fl+ 3.0 x 4.0 y 5.0)
            (fl+ 3.0 x +nan.0 y 5.0))))
-    '(#3%list 0.0 3.0 7.0 x (#3%fl+ 0.0 x) x (#3%fl+ 0.0 x) x (#3%fl+ 3.0 x)
-       (#3%fl+ 7.0 x) (#3%fl+ 7.0 x) (#3%fl+ 0.0 x) x (#3%fl+ 12.0 x y)
+    '(#3%list 0.0 3.0 7.0 (#3%fl+ x) (#3%fl+ 0.0 x) (#3%fl+ x) (#3%fl+ 0.0 x) (#3%fl+ x) (#3%fl+ 3.0 x)
+       (#3%fl+ 7.0 x) (#3%fl+ 7.0 x) (#3%fl+ 0.0 x) (#3%fl+ x) (#3%fl+ 12.0 x y)
        +nan.0))
   (equivalent-expansion?
     (parameterize ([#%$suppress-primitive-inlining #f]
@@ -1330,8 +1338,8 @@
            (fl*) (fl* 3.0) (fl* 3.0 4.0) (fl* x) (fl* x 1.0) (fl* 1.0 x) (fl* x 3.0)
            (fl* x 3.0 4.0) (fl* 3.0 x 4.0) (fl* 3.0 x #i1/3) (fl* 3.0 x 4.0 y 5.0)
            (fl* 3.0 x 4.0 y +nan.0))))
-    '(#3%list 1.0 3.0 12.0 x x x (#3%fl* 3.0 x)
-       (#3%fl* 12.0 x) (#3%fl* 12.0 x) x (#3%fl* 60.0 x y)
+    '(#3%list 1.0 3.0 12.0 (#3%fl* x) (#3%fl* x) (#3%fl* x) (#3%fl* 3.0 x)
+       (#3%fl* 12.0 x) (#3%fl* 12.0 x) (#3%fl* x) (#3%fl* 60.0 x y)
        +nan.0))
   (equivalent-expansion?
     (parameterize ([#%$suppress-primitive-inlining #f]
@@ -1828,7 +1836,7 @@
            (fl+) (fl+ 3.0) (fl+ 3.0 4.0) (fl+ x) (fl+ x 0.0) (fl+ x -0.0) (fl+ 0.0 x) (fl+ -0.0 x) (fl+ x 3.0)
            (fl+ x 3.0 4.0) (fl+ 3.0 x 4.0) (fl+ 3.0 x -3.0) (fl+ (truncate -.5) x (/ -inf.0)) (fl+ 3.0 x 4.0 y 5.0)
            (fl+ +nan.0 x 3.0 y 5.0) (fl+ 3.0 x +nan.0 y 5.0))))
-    '(#3%list 0.0 3.0 7.0 x (#3%fl+ x 0.0) (#3%fl+ x -0.0) (#3%fl+ 0.0 x) x (#3%fl+ x 3.0)
+    '(#3%list 0.0 3.0 7.0 (#3%fl+ x) (#3%fl+ x 0.0) (#3%fl+ x -0.0) (#3%fl+ 0.0 x) (#3%fl+ x) (#3%fl+ x 3.0)
        (#3%fl+ x 3.0 4.0) (#3%fl+ 3.0 x 4.0) (#3%fl+ 3.0 x -3.0) (#3%fl+ x -0.0) (#3%fl+ 3.0 x 4.0 y 5.0)
        +nan.0 (#3%fl+ 3.0 x +nan.0 y 5.0)))
   (equivalent-expansion?
@@ -1934,7 +1942,7 @@
            (fl*) (fl* 3.0) (fl* 3.0 4.0) (fl* x) (fl* x 1.0) (fl* 1.0 x) (fl* x 3.0)
            (fl* x 3.0 4.0) (fl* 3.0 x 4.0) (fl* 3.0 x #i1/3) (fl* 3.0 x 4.0 y 5.0)
            (fl* +nan.0 x 3.0 y 4.0) (fl* 3.0 x 4.0 y +nan.0))))
-    '(#3%list 1.0 3.0 12.0 x (#3%fl* x 1.0) x (#3%fl* x 3.0)
+    '(#3%list 1.0 3.0 12.0 (#3%fl* x) (#3%fl* x 1.0) (#3%fl* x) (#3%fl* x 3.0)
        (#3%fl* x 3.0 4.0) (#3%fl* 3.0 x 4.0) (#3%fl* 3.0 x #i1/3) (#3%fl* 3.0 x 4.0 y 5.0)
        +nan.0 (#3%fl* +3.0 x 4.0 y +nan.0)))
   (equivalent-expansion?
@@ -3034,6 +3042,13 @@
          (not (equivalent-expansion?
                (expand/optimize `(lambda (g) ,(mk `(g))))
                '(lambda (g) (g))))
+         ;; When moving into an ignored position, ensure single valued
+         ;; in safe mode:
+         (equivalent-expansion?
+          (expand/optimize `(lambda (g) ,(mk `(g)) 0))
+          (if (= 3 (optimize-level))
+              '(lambda (g) (g) 0)
+              '(lambda (g) (#3%$value (g)) 0)))
          ;; Ditto, but in a nested procedure:
          (not (equivalent-expansion?
                (expand/optimize `(lambda () (lambda (g) ,(mk `(g)))))
@@ -3111,4 +3126,18 @@
      (equivalent-expansion?
       (expand/optimize '(let ([g1 (begin (unknown) (void))]) 10))
       '(begin (unknown) 10)))
+
+   (or (not (enable-cp0))
+       (eq? (current-eval) interpret)
+       (equal? (let ([mk (lambda (g)
+                           (letrec ([f (lambda (x)
+                                         (if (= x 100)
+                                             (g)
+                                             (f (add1 x))))])
+                             (lambda () (f 101))))])
+                 (map procedure-known-single-valued?
+                      (list (mk (lambda () 1))
+                            (mk (lambda () (values 1 2))))))
+               '(#t #f)))
+
 )
diff --git a/src/ChezScheme/mats/fl.ms b/src/ChezScheme/mats/fl.ms
index 4e38a1b14b..18f150226d 100644
--- a/src/ChezScheme/mats/fl.ms
+++ b/src/ChezScheme/mats/fl.ms
@@ -26,6 +26,13 @@
         (flonum->fixnum (* (+ (ash (most-positive-fixnum) -1) 1) 1.0)))
    (eq? (most-negative-fixnum)
         (flonum->fixnum (* (most-negative-fixnum) 1.0)))
+   (eq? (+ (ash (most-positive-fixnum) -1) 1)
+        (flonum->fixnum (fl+ (* (+ (ash (most-positive-fixnum) -1) 1) 1.0) 0.5)))
+   (or (not (fixnum? (inexact->exact (exact->inexact (most-positive-fixnum)))))
+       (eq? (most-positive-fixnum)
+            (flonum->fixnum (fl+ (* (most-positive-fixnum) 1.0) 0.5))))
+   (eq? (most-negative-fixnum)
+        (flonum->fixnum (fl- (* (most-negative-fixnum) 1.0) 0.5)))
    (eq? (flonum->fixnum 0.0) 0)
    (eq? (flonum->fixnum 1.0) 1)
    (eq? (flonum->fixnum +4.5) +4)
@@ -1038,3 +1045,137 @@
     '((3.0 . -2.0) (-2.0 . -2.0) (-3.0 . -2.0) (2.0 . -2.0)
       (0.0 . 4.0) (0.0 . -4.0) (-0.0 . 4.0) (0.0 . -4.0)))
 )
+
+(mat fp-unboxing
+  (begin
+    (define-syntax check-loop-allocation
+      (syntax-rules ()
+        [(_ proc) ; proc should allocate only its result flonum
+         (or (eq? (current-eval) interpret)
+             (#%$suppress-primitive-inlining)
+             (let ([before (+ (bytes-allocated) (bytes-deallocated))]
+                   [N 100000])
+               (and
+                (box?
+                 (let loop ([i N] [bx (box 0.0)])
+                   (if (zero? i)
+                       bx
+                       (loop (sub1 i) (let ([v (unbox bx)])
+                                        (box (proc v)))))))
+                (let ([allocated (- (+ (bytes-allocated) (bytes-deallocated)) before)]
+                      [expected (* N (+ (compute-size 1.0)
+                                        (compute-size (box #f))))])
+                  (printf "~s ~s\n" allocated expected)
+                  (<= expected allocated (* 1.2 expected))))))]))
+    #t)
+
+  (check-loop-allocation (lambda (v) (fl+ v v)))
+  (check-loop-allocation (lambda (v) (fl* v v)))
+  (check-loop-allocation (lambda (v) (fl- v 1.0)))
+  (check-loop-allocation (lambda (v) (fl/ v 2.0)))
+
+  (check-loop-allocation (lambda (v) (fl+ v 2.0 v)))
+  (check-loop-allocation (lambda (v) (fl+ v (fl* 2.0 v))))
+
+  (check-loop-allocation (lambda (v) (fl+ v v v)))
+  (check-loop-allocation (lambda (v) (fl+ v (fl* v v) (fl/ v 2.0))))
+
+  (check-loop-allocation (lambda (v) (flabs v)))
+  (check-loop-allocation (lambda (v) (fl- v)))
+
+  (check-loop-allocation (lambda (v) (flabs (fl+ v v))))
+  (check-loop-allocation (lambda (v) (fl- (fl+ v v))))
+
+  (check-loop-allocation (lambda (v) (flround v)))
+  (check-loop-allocation (lambda (v) (fltruncate v)))
+  (check-loop-allocation (lambda (v) (flfloor v)))
+  (check-loop-allocation (lambda (v) (flceiling v)))
+  
+  (check-loop-allocation (lambda (v) (flsqrt v)))
+  (check-loop-allocation (lambda (v) (flsin v)))
+  (check-loop-allocation (lambda (v) (flcos v)))
+  (check-loop-allocation (lambda (v) (fltan v)))
+  (check-loop-allocation (lambda (v) (flasin v)))
+  (check-loop-allocation (lambda (v) (flacos v)))
+  (check-loop-allocation (lambda (v) (flatan v)))
+  (check-loop-allocation (lambda (v) (flatan v v)))
+  (check-loop-allocation (lambda (v) (flexp v)))
+  (check-loop-allocation (lambda (v) (fllog v)))
+  (check-loop-allocation (lambda (v) (fllog v v)))
+  (check-loop-allocation (lambda (v) (flexpt v v)))
+
+  (let ([i 0])
+    (check-loop-allocation (lambda (v) (begin
+                                         (set! i (add1 i))
+                                         (fl+ v (fixnum->flonum i))))))
+  (let ([i 0])
+    (check-loop-allocation (lambda (v) (begin
+                                         (set! i (flonum->fixnum v))
+                                         (fl+ v 1.0)))))
+
+  (check-loop-allocation (lambda (v) (let ([u (fl+ v v)])
+                                       (fl* u u))))
+
+  (check-loop-allocation (lambda (v) (if (fl= (fl+ v (fl* 2.0 v)) 7.0)
+                                         (fl+ v 1.0)
+                                         (fl- v 1.0))))
+  (check-loop-allocation (lambda (v) (if (fl< (fl+ v v) v)
+                                         (fl+ v 1.0)
+                                         (fl- v 1.0))))
+  (check-loop-allocation (lambda (v) (if (fl> (fl+ v v) v)
+                                         (fl+ v 1.0)
+                                         (fl- v 1.0))))
+  (check-loop-allocation (lambda (v) (if (fl<= (fl+ v v) v)
+                                         (fl+ v 1.0)
+                                         (fl- v 1.0))))
+  (check-loop-allocation (lambda (v) (if (fl>= (fl+ v v) v)
+                                         (fl+ v 1.0)
+                                         (fl- v 1.0))))
+
+  (check-loop-allocation (lambda (v)
+                           ;; The two single-argument `fl+`s here should work as
+                           ;; a hint for unboxing in the loop
+                           (let loop ([n 100] [v (fl+ v)])
+                             (if (fx= n 0)
+                                 (fl+ v)
+                                 (loop (fx- n 1) (fl+ v 1.0))))))
+
+  (let ([bv (make-bytevector 8 0)])
+    (check-loop-allocation (lambda (v) (fl+ v (bytevector-ieee-double-native-ref bv 0)))))
+  (let ([bv (make-bytevector 8 0)])
+    (check-loop-allocation (lambda (v) (begin
+                                         (bytevector-ieee-double-native-set! bv 0 (fl+ v 0.1))
+                                         (fl* v 0.99)))))
+  (let ([bv (make-bytevector 8 0)])
+    (check-loop-allocation (lambda (v) (let ([v (fl+ v 1.0)])
+                                         (bytevector-ieee-double-native-set! bv 0 v)
+                                         (fl* v 0.99)))))
+  (or (not (enable-cp0))
+      (let ()
+        (define-record pseudo-random-generator
+          ((mutable double x10) (mutable double x11) (mutable double x12)
+           (mutable double x20) (mutable double x21) (mutable double x22))
+          ())
+        (let ([s (make-pseudo-random-generator 1.0 2.0 3.0 4.0 5.0 6.0)])
+          (check-loop-allocation (lambda (v) (let ([v (fl+ (pseudo-random-generator-x10 s) 1.0)])
+                                               (set-pseudo-random-generator-x11! s v)
+                                               (set-pseudo-random-generator-x12! s v)
+                                               (pseudo-random-generator-x20 s)))))))
+
+  (begin
+    (define many-compare
+      (lambda (a b c d e f g h i j k)
+        (fl<= a b c d e f g h i j k)))
+    (many-compare 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0))
+
+  (begin
+    (define many-add
+      (lambda (a b c d e f g h i j k)
+        (fl+ a b c d e f g h i j k)))
+    (fl= 66.0 (many-add 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0)))
+
+  (eqv? (let ([x 4.0]) (fl+ x)) 4.0)
+  (eqv? (let ([x 4.0]) (fl+ (fl- x 1.0))) 3.0)
+  (eqv? (let ([x 5.0]) (fl* x)) 5.0)
+
+  )
diff --git a/src/ChezScheme/mats/foreign.ms b/src/ChezScheme/mats/foreign.ms
index 7e2b7ff552..9254c74b56 100644
--- a/src/ChezScheme/mats/foreign.ms
+++ b/src/ChezScheme/mats/foreign.ms
@@ -184,7 +184,7 @@
       (error? (load-shared-object 3))
     )
    ]
-  [(i3le ti3le a6le ta6le arm32le tarm32le ppc32le tppc32le)
+  [(i3le ti3le a6le ta6le arm32le tarm32le arm64le tarm64le ppc32le tppc32le)
    (mat load-shared-object
       (file-exists? "foreign1.so")
       (begin (load-shared-object "./foreign1.so") #t)
@@ -1038,6 +1038,12 @@
     (define call-u64 (foreign-procedure "call_u64" (ptr unsigned-64 int int) unsigned-64))
     (define call-sf (foreign-procedure "call_sf" (ptr single-float int int) single-float))
     (define call-df (foreign-procedure "call_df" (ptr double-float int int) double-float))
+    (define call-varargs-df (foreign-procedure "call_varargs_df" (ptr double-float int int) double-float))
+    (define call-varargs-i7df (foreign-procedure "call_varargs_i7df" (ptr int
+                                                                          double-float double-float double-float
+                                                                          double-float double-float double-float
+                                                                          double-float)
+                                                 double-float))
     (define ($test-call-int signed? size call-int make-fc)
       (define n10000 (expt 256 size))
       (define nffff (- n10000 1))
@@ -1151,6 +1157,22 @@
         (double-float) double-float)
       73.25 7 23)
     108.25)
+  (equal?
+    (call-varargs-df
+      (foreign-callable
+        __varargs
+        (lambda (x y) (+ x y 5))
+        (double-float double-float) double-float)
+      10.25 20 300)
+    325.5)
+  (equal?
+    (call-varargs-i7df
+      (foreign-callable
+        __varargs
+        (lambda (i a b c d e f g) (+ i a b c d e f g 7))
+        (int double-float double-float double-float double-float double-float double-float double-float) double-float)
+      1 2.2 3.2 4.5 6.7 8.9 10.1 11.5)
+    55.1)
 
   (error?
     (call-i8
@@ -1212,6 +1234,13 @@
         (lambda (x) '(- x 7))
         (double-float) double-float)
       73.25 0 0))
+  (error?
+    (call-varargs-df
+      (foreign-callable
+        __varargs
+        (lambda (x y) '(- x 7))
+        (double-float double-float) double-float)
+      73.25 0 0))
 
   (begin
     (define u32xu32->u64
@@ -2002,6 +2031,19 @@
  )
 
 (mat foreign-callable
+  (begin
+    ;; We don't have to use `lock-object` on the result of a `foreign-callable`,
+    ;; because it is immobile. We have to keep it live, though.
+    (define-syntax with-object-kept-live
+      (lambda (x)
+        (syntax-case x ()
+          [(_ id expr)
+           (identifier? #'id)
+           #'(let ([v expr])
+               (keep-live id)
+               v)])))
+    #t)
+
   (error? ; spam is not a procedure
     (foreign-callable 'spam () void))
   (error? ; spam is not a procedure
@@ -2085,19 +2127,16 @@
     (define args3 (list #f #\newline -51293 3.1415 2.5 #f))
     (let ()
       (define addr
-        (begin
-          (lock-object Fargtest)
-          (foreign-callable-entry-point Fargtest)))
-      (dynamic-wind
-        void
-        (lambda ()
+        (foreign-callable-entry-point Fargtest))
+      (let ()
           (collect (collect-maximum-generation))
           (collect (collect-maximum-generation))
-          (and
+          (with-object-kept-live
+           Fargtest
+           (and
             (equal? (apply Sargtest addr args1) (reverse args1))
             (equal? (apply Sargtest addr args2) (reverse args2))
-            (equal? (apply Sargtest addr args3) (reverse args3))))
-        (lambda () (unlock-object Fargtest)))))
+            (equal? (apply Sargtest addr args3) (reverse args3)))))))
   (let ()
     (define Fargtest2
       (foreign-callable
@@ -2114,19 +2153,16 @@
     (define args3 (list -7500 #x987654 #\? +inf.0 3210 #\7))
     (let ()
       (define addr
-        (begin
-          (lock-object Fargtest2)
-          (foreign-callable-entry-point Fargtest2)))
-      (dynamic-wind
-        void
-        (lambda ()
+        (foreign-callable-entry-point Fargtest2))
+      (let ()
           (collect (collect-maximum-generation))
           (collect (collect-maximum-generation))
-          (and
+          (with-object-kept-live
+           Fargtest2
+           (and
             (equal? (apply Sargtest2 addr args1) (reverse args1))
             (equal? (apply Sargtest2 addr args2) (reverse args2))
-            (equal? (apply Sargtest2 addr args3) (reverse args3))))
-        (lambda () (unlock-object Fargtest2)))))
+            (equal? (apply Sargtest2 addr args3) (reverse args3)))))))
   (let ()
     (define Frvtest_int32
       (foreign-callable
@@ -2229,9 +2265,9 @@
     (let ([x 5])
       (define call-twice (foreign-procedure "call_twice" (void* int int) void))
       (let ([co (foreign-callable (lambda (y) (set! x (+ x y))) (int) void)])
-        (lock-object co)
-        (call-twice (foreign-callable-entry-point co) 7 31)
-        (unlock-object co))
+        (with-object-kept-live
+         co
+         (call-twice (foreign-callable-entry-point co) 7 31)))
       x)
     43)
   (equal?
@@ -2247,7 +2283,6 @@
       (define callback
         (lambda (p)
           (let ([code (foreign-callable p (char) void)])
-            (lock-object code)
             (foreign-callable-entry-point code))))
       (let ()
         (define ouch
@@ -2278,9 +2313,9 @@
    ; this form needs to be after the preceding form and not part of it, so that when
    ; we lock code we don't also lock the code object created by foreign-procedure
    (begin
-     (lock-object code)
-     ((foreign-procedure (foreign-callable-entry-point code) () scheme-object))
-     (unlock-object code)
+     (with-object-kept-live
+      code
+      ((foreign-procedure (foreign-callable-entry-point code) () scheme-object)))
      #t)
 
   (not (locked-object?
@@ -2408,11 +2443,11 @@
             (define fptr (make-ftype-pointer foo f))
             (define g (ftype-ref foo () fptr))
             (with-exception-handler
-              (lambda (c) (*k* *m*))
-              (lambda ()
-                (call/cc
-                  (lambda (k)
-                    (fluid-let ([*k* k]) (f $stack-depth $base-value))))))
+             (lambda (c) (*k* *m*))
+             (lambda ()
+               (call/cc
+                (lambda (k)
+                  (fluid-let ([*k* k]) (f $stack-depth $base-value))))))
             (unlock-object
               (foreign-callable-code-object
                 (ftype-pointer-address fptr)))
@@ -2491,8 +2526,7 @@
               (ftype-pointer-address fptr)))
           *m*)
         (+ $stack-depth $base-value)))
-  ;; Make sure that a callable is suitably locked, and that it's
-  ;; unlocked when the C stack is popped by an escape
+  ;; A callable isn't locked, but it's immobile
   (equal?
     (let ()
       (define Sinvoke2
@@ -2502,9 +2536,7 @@
       (define Fcons
         (foreign-callable
           (lambda (k y)
-            ;; Escape with locked, which should be #t
-            ;; because a callable is locked while it's
-            ;; called:
+            (collect) ; might crash if `Fcons` were mobile
             (k (locked-object? Fcons)))
           (scheme-object iptr)
           scheme-object))
@@ -2515,7 +2547,7 @@
        ;; Escape from callable:
        (let ([v ($with-exit-proc (lambda (k) (Sinvoke2 Fcons k 5)))])
          (list v (locked-object? Fcons)))))
-    '((#t #f) (#t #f)))
+    '((#f #f) (#f #f)))
 
   ;; Make sure the code pointer for a call into a
   ;; foreign procedure is correctly saved for locking
@@ -2534,11 +2566,36 @@
              (set! v (add1 v))
              (loop (bitwise-arithmetic-shift-right n 1))))))
      (define handler (foreign-callable work (long) void))
-     (lock-object handler)
-     (call_many_times (foreign-callable-entry-point handler))
+     (with-object-kept-live
+      handler
+      (call_many_times (foreign-callable-entry-point handler)))
+     (unlock-object handler)
      v)
    14995143)
 
+  (equal?
+   (let ()
+     (define v 0)
+     (define call_many_times_bv (foreign-procedure "call_many_times_bv" (void*) void))
+     (define work
+       (lambda (bv)
+         (set! v (+ v (bytevector-u8-ref bv 0)))
+         ;; Varying work, as above:
+         (let loop ([n (bitwise-and (bytevector-u8-ref bv 1) #xFFFF)])
+           (unless (zero? n)
+             (set! v (add1 v))
+             (loop (bitwise-arithmetic-shift-right n 1))))))
+     (define handlers (list (foreign-callable work (u8*) void)
+                            (foreign-callable work (u16*) void)
+                            (foreign-callable work (u32*) void)))
+     (map lock-object handlers)
+     (for-each (lambda (handler)
+                 (call_many_times_bv (foreign-callable-entry-point handler)))
+               handlers)
+     (map unlock-object handlers)
+     v)
+   103500000)
+
   ;; regression test related to saving registers that hold allocated
   ;; callable argument
   (let* ([call-with-many-args (foreign-procedure "call_with_many_args" (void*) boolean)]
@@ -2557,9 +2614,9 @@
                            (eqv? i3 2))))
               (int u8* u8* u8* u8* int u8* u8* int)
               void)])
-    (lock-object cb)
-    (call-with-many-args (foreign-callable-entry-point cb))
-    (unlock-object cb)
+    (with-object-kept-live
+     cb
+     (call-with-many-args (foreign-callable-entry-point cb)))
     result)
 
 )
@@ -2668,7 +2725,7 @@
       (machine-case
         [(i3ob ti3ob a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx i3nb ti3nb a6nb ta6nb)
          '(load-shared-object "libc.so")]
-        [(i3le ti3le a6le ta6le arm32le tarm32le ppc32le tppc32le)
+        [(i3le ti3le a6le ta6le arm32le tarm32le arm64le tarm64le ppc32le tppc32le)
          '(load-shared-object "libc.so.6")]
         [(i3fb ti3fb a6fb ta6fb)
          '(load-shared-object "libc.so.7")]
@@ -2683,7 +2740,7 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double) int))
+           (define f (foreign-procedure __varargs "printf" (string double) int))
            (f "(%g)" 3.5)
            (void)))
       read)
@@ -2693,7 +2750,7 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double double double double double double) int))
+           (define f (foreign-procedure __varargs "printf" (string double double double double double double) int))
            (f "(%g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5)
            (void)))
       read)
@@ -2703,7 +2760,7 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double double double double double double double double) int))
+           (define f (foreign-procedure __varargs "printf" (string double double double double double double double double) int))
            (f "(%g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5)
            (void)))
       read)
@@ -2713,11 +2770,30 @@
       (separate-eval
         `(begin
            ,load-libc
-           (define f (foreign-procedure "printf" (string double double double double double double double double double double) int))
+           (define f (foreign-procedure __varargs "printf" (string double double double double double double double double double double) int))
            (f "(%g %g %g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5)
            (void)))
       read)
     '(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5))
+
+  (equal? (let ([cb (foreign-callable __varargs
+                                      (lambda (x y) (+ x y 5))
+                                      (double-float double-float) double-float)])
+            (with-object-kept-live
+             cb
+             ((foreign-procedure __varargs (foreign-callable-entry-point cb)
+                                 (double-float double-float) double-float)
+              3.4 5.5)))
+          13.9)
+  (equal? (let ([cb (foreign-callable __varargs
+                                      (lambda (x y) (+ x y 5))
+                                      (double-float double-float) single-float)])
+            (with-object-kept-live
+             cb
+             ((foreign-procedure __varargs (foreign-callable-entry-point cb)
+                                 (double-float double-float) single-float)
+              3.5 -5.25)))
+          3.25)
 )
 
 (mat structs
diff --git a/src/ChezScheme/mats/foreign2.c b/src/ChezScheme/mats/foreign2.c
index 3e12cf1fff..56b2f5b2db 100644
--- a/src/ChezScheme/mats/foreign2.c
+++ b/src/ChezScheme/mats/foreign2.c
@@ -244,6 +244,17 @@ EXPORT double_float call_df(ptr code, double_float x, int m, int k) {
   return (*((double_float (*) (double_float))Sforeign_callable_entry_point(code)))(x + m) + k;
 }
 
+EXPORT double_float call_varargs_df(ptr code, double_float x, int m, int k) {
+  return (*((double_float (*) (double, ...))Sforeign_callable_entry_point(code)))(x - m, x + m) + k;
+}
+
+EXPORT double_float call_varargs_i7df(ptr code, int i,
+                                      double_float a, double_float b, double_float c,
+                                      double_float d, double_float e, double_float f,
+                                      double_float g) {
+  return (*((double_float (*) (int, ...))Sforeign_callable_entry_point(code)))(i, a, b, c, d, e, f, g);
+}
+
 EXPORT u8 *u8_star_to_u8_star(u8 *s) {
   return s == (u8 *)0 ? (u8 *)0 : s + 1;
 }
@@ -444,6 +455,18 @@ EXPORT void call_many_times(void (*f)(iptr))
   }
 }
 
+EXPORT void call_many_times_bv(void (*f)(char *s))
+{
+  /* make this sensible as u8*, u16*, and u32* */
+  char buf[8] = { 1, 2, 3, 4, 0, 0, 0, 0 };
+  int x;
+
+  for (x = 0; x < 1000000; x++) {
+    buf[0] = (x & 63) + 1;
+    f(buf);
+  }
+}
+
 typedef void (*many_arg_callback_t)(int i, const char* s1, const char* s2, const char* s3,
                                     const char* s4, int i2, const char* s6, const char* s7, int i3);
 EXPORT void call_with_many_args(many_arg_callback_t callback)
diff --git a/src/ChezScheme/mats/ftype.ms b/src/ChezScheme/mats/ftype.ms
index 7fc237f1f9..3cdffad19e 100644
--- a/src/ChezScheme/mats/ftype.ms
+++ b/src/ChezScheme/mats/ftype.ms
@@ -560,7 +560,7 @@
                         (system (format "set cl= && ..\\c\\vs.bat amd64 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))]
                        [(i3nt ti3nt)
                         (system (format "set cl= && ..\\c\\vs.bat x86 && cl /DWIN32 /Fe~a /LD /MD /nologo ~a" testfile.so testfile.c))]
-                       [(arm32le tarm32le)
+                       [(arm32le tarm32le arm64le tarm64le)
                         (system (format "cc -fPIC -shared -o ~a ~a" testfile.so testfile.c))]
                        [else ; this should work for most intel-based systems that use gcc...
                         (if (> (fixnum-width) 32)
diff --git a/src/ChezScheme/mats/hash.ms b/src/ChezScheme/mats/hash.ms
index 92b8324949..a61f7c7643 100644
--- a/src/ChezScheme/mats/hash.ms
+++ b/src/ChezScheme/mats/hash.ms
@@ -1674,7 +1674,10 @@
           [wht (make-weak-eq-hashtable)]
           [eht (make-ephemeron-eq-hashtable)])
       (let ([ls2 (map (lambda (a1) (eq-hashtable-cell ht (car a1) (cdr a1))) ls1)]
-            [ls2-2 (map (lambda (a1) (eq-hashtable-try-atomic-cell ht (car a1) (cdr a1))) ls1)]
+            [ls2-2 (map (lambda (a1) (let loop ()
+                                       (define c (eq-hashtable-try-atomic-cell ht (car a1) (cdr a1)))
+                                       (or c (loop))))
+                        ls1)]
             [ls3 (map (lambda (a1) (hashtable-cell wht (car a1) (cdr a1))) ls1)]
             [ls4 (map (lambda (a1) (hashtable-cell eht (car a1) (cdr a1))) ls1)])
         (let ([ls2* (map (lambda (a1) (eq-hashtable-ref-cell ht (car a1))) ls1)]
diff --git a/src/ChezScheme/mats/ieee.ms b/src/ChezScheme/mats/ieee.ms
index b85a6f4ec7..81cfdbe3db 100644
--- a/src/ChezScheme/mats/ieee.ms
+++ b/src/ChezScheme/mats/ieee.ms
@@ -159,7 +159,7 @@
 (mat fl=
    (let ((n (read (open-input-string "+nan.0"))))
      (not (fl= n n)))
-   (not (fl= (nan)))
+   (fl= (nan))
    (not (fl= (nan) +inf.0))
    (not (fl= (nan) -inf.0))
    (not (fl= (nan) (nan)))
@@ -171,7 +171,7 @@
  )
 
 (mat fl<
-   (not (fl< (nan)))
+   (fl< (nan))
    (not (fl< (nan) (nan)))
    (not (fl< (nan) 0.0))
    (not (fl< 0.0 (nan)))
@@ -179,7 +179,7 @@
  )
 
 (mat fl>
-   (not (fl> (nan)))
+   (fl> (nan))
    (not (fl> (nan) (nan)))
    (not (fl> (nan) 0.0))
    (not (fl> 0.0 (nan)))
@@ -189,14 +189,14 @@
  )
 
 (mat fl<=
-   (not (fl<= (nan)))
+   (fl<= (nan))
    (not (fl<= (nan) (nan)))
    (not (fl<= (nan) 0.0))
    (not (fl<= 0.0 (nan)))
  )
 
 (mat fl>=
-   (not (fl>= (nan)))
+   (fl>= (nan))
    (not (fl>= (nan) (nan)))
    (not (fl>= (nan) 0.0))
    (not (fl>= 0.0 (nan)))
@@ -714,7 +714,7 @@
   (equal? (number->string 1.1665795231290236e-302) "1.1665795231290236e-302")
  ; fp printing algorithm always rounds up on ties
   (equal? (number->string 3.6954879760742188e-6) "3.6954879760742188e-6")
-  (equal? (number->string 5.629499534213123e14) "5.629499534213123e+14")
+  (equal? (number->string 5.629499534213123e14) "562949953421312.3")
  )
 
 (mat string->number
diff --git a/src/ChezScheme/mats/misc.ms b/src/ChezScheme/mats/misc.ms
index af999a4b32..fb6588bda6 100644
--- a/src/ChezScheme/mats/misc.ms
+++ b/src/ChezScheme/mats/misc.ms
@@ -14,7 +14,7 @@
 ;;; limitations under the License.
 
 ;;; regression and other tests that don't fit somewhere more logical
-  
+
 (define-syntax biglet
   (lambda (x)
     (syntax-case x ()
@@ -1224,6 +1224,26 @@
   ;; sure they don't fail:
   (list? (collect 0 0 (list (call/cc values))))
   (list? (collect (collect-maximum-generation) (collect-maximum-generation) (list (call/cc values))))
+
+  (let ()
+    (define e (ephemeron-cons #t (gensym)))
+    (collect 0 1)
+    (let ([g (gensym)])
+      (set-car! e g)
+      (set! g #f)
+      ;; For this collection, `e` is both on the dirty list
+      ;; and involved in measuring; make sure those roles
+      ;; don't conflict
+      (collect 1 1 (list e))
+      (equal? e (cons #!bwp #!bwp))))
+
+  (let ()
+    (define e (ephemeron-cons #t 'other))
+    (collect 0 1)
+    (let ([g (gensym)])
+      (set-car! e g)
+      (collect 1 1 (list e))
+      (equal? e (cons g 'other))))
 )
 
 (mat compute-composition
@@ -2696,6 +2716,8 @@
   (time=? (cost-center-time $cc-3) (make-time 'time-duration 0 0))
 )
 
+
+
 (mat lock-object
   (begin
     (define $locked-objects (foreign-procedure "(cs)locked_objects" () ptr))
@@ -3042,7 +3064,7 @@
       (set-car! p 'yes)
       (unlock-object v)
       (equal? '(yes . 2) (vector-ref v (sub1 N)))))
-)
+  )
 
 (mat eval-order
   (eqv? (call/cc (lambda (k) (0 (k 1)))) 1)
@@ -4672,34 +4694,35 @@
              (#2%display 1))))
 )
 
-(mat $read-time-stamp-counter
+(unless (memq (machine-type) '(arm32le tarm32le arm64le tarm64le)) ; timestamp counter tends to be priviledged on Arm
+  (mat $read-time-stamp-counter
 
-  (let ([t (#%$read-time-stamp-counter)])
-    (and (integer? t) (exact? t)))
+    (let ([t (#%$read-time-stamp-counter)])
+      (and (integer? t) (exact? t)))
 
-  (let ()
-    ;; NB: pulled from thread.ms, to use as a delay
-    (define fat+
-      (lambda (x y)
-        (if (zero? y)
-            x
-            (fat+ (1+ x) (1- y)))))
-    (define fatfib
-      (lambda (x)
-        (if (< x 2)
-            1
-            (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
-    (let loop ([count 10] [success 0])
-      (if (fx= count 0)
-          (>= success 9)
-          (let ([t0 (#%$read-time-stamp-counter)])
-            (fatfib 26)
-            (let ([t1 (#%$read-time-stamp-counter)])
-              (loop (fx- count 1)
-                    (if (< t0 t1)
-                        (fx+ success 1)
-                        success)))))))
-)
+    (let ()
+      ;; NB: pulled from thread.ms, to use as a delay
+      (define fat+
+        (lambda (x y)
+          (if (zero? y)
+              x
+              (fat+ (1+ x) (1- y)))))
+      (define fatfib
+        (lambda (x)
+          (if (< x 2)
+              1
+              (fat+ (fatfib (1- x)) (fatfib (1- (1- x)))))))
+      (let loop ([count 10] [success 0])
+        (if (fx= count 0)
+            (>= success 9)
+            (let ([t0 (#%$read-time-stamp-counter)])
+              (fatfib 26)
+              (let ([t1 (#%$read-time-stamp-counter)])
+                (loop (fx- count 1)
+                      (if (< t0 t1)
+                          (fx+ success 1)
+                          success)))))))
+    ))
 
 (mat procedure-arity-mask
   (equal? (procedure-arity-mask (lambda () #f)) 1)
@@ -4756,13 +4779,36 @@
     (define should-be-named-h (let ([f (let ([h (lambda (x) x)]) h)]) f))
     (define should-be-named-i (letrec ([f (let ([i (lambda (x) x)]) i)]) f))
     (define should-be-named-j (let ([f (letrec ([j (lambda (x) x)]) j)]) f))
+    (define (result-should-be-named-mk-CP)
+      (let ([struct:CP (make-record-type-descriptor* 'CP #f #f #f #f 1 1)])
+        (let ([mk-CP (record-constructor (make-record-constructor-descriptor
+                                          struct:CP #f #f))])
+          mk-CP)))
     #t)
   (ok-name? (procedure-name procedure-name) "procedure-name")
   (ok-name? (procedure-name should-be-named-f) "f")
   (ok-name? (procedure-name should-be-named-g) "g")
   (ok-name? (procedure-name should-be-named-h) "h")
   (ok-name? (procedure-name should-be-named-i) "i")
-  (ok-name? (procedure-name should-be-named-j) "j"))
+  (ok-name? (procedure-name should-be-named-j) "j")
+
+  (or (not (enable-cp0))
+      (let ([gx (make-guardian)])
+        (ok-name? (procedure-name gx) "gx")))
+  (or (not (enable-cp0))
+      (ok-name? (procedure-name (result-should-be-named-mk-CP)) "mk-CP"))
+
+  (or (not (enable-cp0))
+      (andmap ok-name?
+              (map
+               procedure-name
+               (let ([f (lambda (g)
+                          (g (lambda (x) x)))])
+                 (list (f (lambda (a) a))
+                       (f (lambda (b) b)))))
+              '("a" "b")))
+  )
+
 
 (mat wrapper-procedure
   (error? (make-wrapper-procedure))
@@ -4870,7 +4916,6 @@
       (and
        (equal? (wrapper-procedure-data a) g)
        (begin (unlock-object a) #t))))
-
   )
 
 (mat fasl-immutable
@@ -5093,10 +5138,12 @@
      (bytes-allocated)
      (* 2.25 $pre-allocated))
 
-  ;; No big change to `(current-memory-bytes)`
-  (< (* 0.75 $pre-memory)
+  ;; Big change to `(current-memory-bytes)`
+  (< (+ (* 0.75 $pre-allocated)
+        $pre-memory)
      (current-memory-bytes)
-     (* 1.25 $pre-memory))
+     (+ (* 1.25 $pre-memory)
+        $pre-memory))
 
   ;; Same change after GC
   (begin
@@ -5140,4 +5187,184 @@
     (< (* 0.75 $pre-allocated)
        (bytes-allocated)
        (* 1.25 $pre-allocated)))
-)
+  )
+
+(mat immobile
+  (error? (box-immobile))
+  (error? (box-immobile 1 2))
+
+  (error? (make-immobile-vector))
+  (error? (make-immobile-vector 'a))
+  (error? (make-immobile-vector -10))
+  (error? (make-immobile-vector (expt 2 100)))
+  (error? (make-immobile-vector 10 1 2))
+
+  (error? (make-immobile-bytevector))
+  (error? (make-immobile-bytevector 'a))
+  (error? (make-immobile-byte-vector -10))
+  (error? (make-immobile-bytevector (expt 2 100)))
+  (error? (make-immobile-bytevector 10 1024))
+  (error? (make-immobile-bytevector 10 1 2))
+
+  (box? (box-immobile 10))
+  (vector? (make-immobile-vector 10))
+  (eqv? 0 (vector-ref (make-immobile-vector 10) 9))
+  (bytevector? (make-immobile-bytevector 10))
+  (eqv? 0 (bytevector-u8-ref (make-immobile-bytevector 10 0) 9))
+
+  (begin
+    (define (make-objects)
+      (let loop ([i 16])
+        (cond
+          [(zero? i) '()]
+          [else
+           (let* ([b (box-immobile (format "box ~a" i))]
+                  [b-addr (#%$fxaddress b)]
+                  [v (make-immobile-vector (expt 2 i) b)]
+                  [v-addr (#%$fxaddress v)]
+                  [s (make-immobile-bytevector (expt 2 i) i)]
+                  [s-addr (#%$fxaddress s)])
+             (cons (list i
+                         b b-addr
+                         v v-addr
+                         s s-addr)
+                   (loop (sub1 i))))])))
+    (define (check-objects l)
+      (let loop ([l l])
+        (or (null? l)
+            (let-values ([(i b b-addr v v-addr s s-addr) (apply values (car l))])
+              (and (equal? (format "box ~a" i) (unbox b))
+                   (equal? (format "box ~a" i) (unbox (vector-ref v (sub1 (vector-length v)))))
+                   (eqv? i (bytevector-u8-ref s (sub1 (bytevector-length s))))
+                   (eqv? b-addr (#%$fxaddress b))
+                   (eqv? v-addr (#%$fxaddress v))
+                   (eqv? s-addr (#%$fxaddress s))
+                   (loop (cdr l)))))))
+    (define (mutate-objects l)
+      (let loop ([l l])
+        (or (null? l)
+            (let-values ([(i b b-addr v v-addr s s-addr) (apply values (car l))])
+              (set-box! b (format "box ~a" i))
+              (vector-set! v (sub1 (vector-length v)) (box (unbox b)))
+              (loop (cdr l))))))
+    #t)
+
+  (with-interrupts-disabled
+   (let ([objs (make-objects)])
+     (and (check-objects objs)
+          (begin
+            (collect 0 1)
+            (and
+             (check-objects objs)
+             (begin
+               (mutate-objects objs)
+               (collect 0 0)
+               (and
+                (check-objects objs)
+                (begin
+                  (collect (collect-maximum-generation))
+                  (check-objects objs)))))))))
+
+  (or
+   (not (threaded?))
+   (let ([m (make-mutex)]
+         [c (make-condition)]
+         [running 4])
+     (let thread-loop ([t running])
+       (unless (= t 0)
+         (fork-thread
+          (lambda ()
+            (let loop ([i 1000] [objs '()] [addrs '()])
+              (cond
+                [(= i 0)
+                 (mutex-acquire m)
+                 (set! running (sub1 running))
+                 (condition-signal c)
+                 (mutex-release m)]
+                [else
+                 (let ([v (case (modulo i 3)
+                            [(0) (box-immobile objs)]
+                            [(1) (make-immobile-vector i objs)]
+                            [(2) (make-immobile-bytevector i)])])
+                   (let ([objs (cons v objs)]
+                         [addrs (cons (#%$fxaddress v) addrs)])
+                     (collect-rendezvous)
+                     (let check ([objs objs] [addrs addrs])
+                       (unless (null? objs)
+                         (let ([v (car objs)])
+                           (unless (= (#%$fxaddress v) (car addrs))
+                             (error 'immobile "address changed: ~s" v))
+                           (cond
+                             [(box? v)
+                              (unless (eq? (unbox v) (cdr objs))
+                                (error 'immobile "bad box content"))]
+                             [(vector? v)
+                              (let loop ([j 0])
+                                (unless (= j (vector-length v))
+                                  (unless (eq? (cdr objs) (vector-ref v j))
+                                    (error 'immobile "bad vector content"))
+                                  (loop (add1 j))))]
+                             [(bytevector? v)
+                              (void)]
+                             [else
+                              (error 'immobile "bad object: ~s" v)]))
+                         (check (cdr objs) (cdr addrs))))
+                     (loop (sub1 i) objs addrs)))]))))
+         (thread-loop (sub1 t))))
+     (mutex-acquire m)
+     (let loop ()
+       (unless (= running 0)
+         (condition-wait c m)
+         (loop)))
+     (mutex-release m)
+     ;; Wait for threads to exit
+     (let ()
+       (define $threads (foreign-procedure "(cs)threads" () scheme-object))
+       (let loop ()
+         (unless (= 1 (length ($threads)))
+           (sleep (make-time 'time-duration 10000 0))
+           (loop))))
+     #t))
+
+  )
+
+(mat compacting
+  ;; try to provoke the GC into putting a record into marked
+  ;; (instead of copied) space and check the write barrier there
+  (let loop ([N 2])
+    (or (= N 8192)
+        (let sel-loop ([sels (list car cadr)])
+          (cond
+            [(null? sels) (loop (* N 2))]
+            [else
+             (let ()
+               (define rtd (make-record-type
+                            "r"
+                            (let loop ([i N])
+                              (if (zero? i)
+                                  (list '[ptr y])
+                                  (cons `[uptr ,(string->symbol (format "x~a" i))]
+                                        (loop (sub1 i)))))))
+               
+               (define (make-r)
+                 (apply (record-constructor rtd)
+                        (let loop ([i N])
+                          (if (zero? i)
+                              '(the-y-value)
+                              (cons 0 (loop (sub1 i)))))))
+               
+               (define r-y (record-accessor rtd N))
+               (define set-r-y! (record-mutator rtd N))
+               
+               (define rs (list (make-r)
+                                (make-r)
+                                (make-r)))
+               (collect (collect-maximum-generation))
+               (set! rs (list (car rs) (caddr rs)))
+               (collect (collect-maximum-generation))
+               (set-r-y! ((car sels) rs) (string-copy "new-string-to-go"))
+               (collect)
+               (and (equal? (r-y ((car sels) rs))
+                            "new-string-to-go")
+                    (sel-loop (cdr sels))))]))))
+  )
diff --git a/src/ChezScheme/mats/patch-compile-0-f-t-f b/src/ChezScheme/mats/patch-compile-0-f-t-f
index 7d09c27916..a82bd035c9 100644
--- a/src/ChezScheme/mats/patch-compile-0-f-t-f
+++ b/src/ChezScheme/mats/patch-compile-0-f-t-f
@@ -1,7 +1,7 @@
-*** errors-compile-0-f-f-f	2020-03-11 22:32:59.000000000 -0600
---- errors-compile-0-f-t-f	2020-03-11 21:56:23.000000000 -0600
+*** errors-compile-0-f-f-f	2020-06-03 12:04:45.000000000 -0600
+--- errors-compile-0-f-t-f	2020-06-03 11:23:43.000000000 -0600
 ***************
-*** 254,260 ****
+*** 198,204 ****
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c".
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m".
@@ -9,7 +9,7 @@
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable y".
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
---- 254,260 ----
+--- 198,204 ----
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable c".
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable m".
@@ -18,7 +18,7 @@
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
   3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
 ***************
-*** 273,279 ****
+*** 217,223 ****
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b".
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a".
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g".
@@ -26,7 +26,7 @@
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable f".
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c".
   3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
---- 273,279 ----
+--- 217,223 ----
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable b".
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable a".
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable g".
@@ -35,7 +35,7 @@
   3.mo:Expected error in mat cpvalid: "attempt to reference undefined variable c".
   3.mo:Expected warning in mat cpvalid: "possible attempt to reference undefined variable x".
 ***************
-*** 320,329 ****
+*** 264,273 ****
   3.mo:Expected error in mat mrvs: "returned three values to single value return context".
   3.mo:Expected error in mat mrvs: "returned three values to single value return context".
   3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@@ -46,7 +46,7 @@
   3.mo:Expected error in mat mrvs: "variable $mrvs-foo is not bound".
   3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
   3.mo:Expected error in mat mrvs: "returned two values to single value return context".
---- 320,329 ----
+--- 264,273 ----
   3.mo:Expected error in mat mrvs: "returned three values to single value return context".
   3.mo:Expected error in mat mrvs: "returned three values to single value return context".
   3.mo:Expected error in mat mrvs: "returned zero values to single value return context".
@@ -58,7 +58,7 @@
   3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
   3.mo:Expected error in mat mrvs: "returned two values to single value return context".
 ***************
-*** 4085,4091 ****
+*** 4034,4040 ****
   misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@@ -66,7 +66,7 @@
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
---- 4085,4091 ----
+--- 4034,4040 ----
   misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@@ -75,7 +75,7 @@
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
   misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
 ***************
-*** 7650,7657 ****
+*** 7612,7619 ****
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -84,7 +84,7 @@
   record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
---- 7650,7657 ----
+--- 7612,7619 ----
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -94,7 +94,7 @@
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
 ***************
-*** 7659,7673 ****
+*** 7621,7635 ****
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -110,7 +110,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid input #f".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
---- 7659,7673 ----
+--- 7621,7635 ----
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -127,7 +127,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
 ***************
-*** 7680,7705 ****
+*** 7642,7667 ****
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -154,7 +154,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
---- 7680,7705 ----
+--- 7642,7667 ----
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -182,7 +182,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
 ***************
-*** 7830,7868 ****
+*** 7792,7830 ****
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -222,7 +222,7 @@
   record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
---- 7830,7868 ----
+--- 7792,7830 ----
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -263,14 +263,14 @@
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
 ***************
-*** 7877,7933 ****
+*** 7839,7895 ****
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 2 to #<procedure constructor>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure constructor>".
@@ -321,14 +321,14 @@
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
---- 7877,7933 ----
+--- 7839,7895 ----
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure n>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure n>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure pcons>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure pcons>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (ccons 1)".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (ccons 1 2 3)".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (n (+ z 7) w "what?")".
diff --git a/src/ChezScheme/mats/patch-compile-0-t-f-f b/src/ChezScheme/mats/patch-compile-0-t-f-f
index 5a096b0771..e0ca03f29e 100644
--- a/src/ChezScheme/mats/patch-compile-0-t-f-f
+++ b/src/ChezScheme/mats/patch-compile-0-t-f-f
@@ -1,5 +1,5 @@
-*** errors-compile-0-f-f-f	2020-03-11 22:32:59.000000000 -0600
---- errors-compile-0-t-f-f	2020-03-11 22:04:54.000000000 -0600
+*** errors-compile-0-f-f-f	2020-04-20 14:03:37.000000000 -0600
+--- errors-compile-0-t-f-f	2020-04-20 14:17:38.000000000 -0600
 ***************
 *** 222,228 ****
   3.mo:Expected error in mat case-lambda: "incorrect number of arguments 2 to #<procedure foo>".
@@ -3861,7 +3861,7 @@
   misc.mo:Expected error in mat compiler3: "incorrect argument count in call (consumer 1 2)".
   misc.mo:Expected error in mat compiler3: "variable goto is not bound".
 ***************
-*** 4108,4114 ****
+*** 4113,4119 ****
   misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
   misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
   misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 4".
@@ -3869,7 +3869,7 @@
   misc.mo:Expected error in mat cost-center: "with-cost-center: foo is not a cost center".
   misc.mo:Expected error in mat cost-center: "with-cost-center: bar is not a procedure".
   misc.mo:Expected error in mat cost-center: "cost-center-instruction-count: 5 is not a cost center".
---- 4108,4114 ----
+--- 4113,4119 ----
   misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
   misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: failed for probably-does-not-exist: no such file or directory".
   misc.mo:Expected error in mat $fasl-file-equal?: "$fasl-file-equal?: record comparison failed while comparing testfile-fatfib1.so and testfile-fatfib3.so within fasl entry 4".
@@ -3878,7 +3878,7 @@
   misc.mo:Expected error in mat cost-center: "with-cost-center: bar is not a procedure".
   misc.mo:Expected error in mat cost-center: "cost-center-instruction-count: 5 is not a cost center".
 ***************
-*** 4162,4169 ****
+*** 4167,4174 ****
   misc.mo:Expected error in mat apropos: "apropos: 3 is not a symbol or string".
   misc.mo:Expected error in mat apropos: "apropos: (hit me) is not a symbol or string".
   misc.mo:Expected error in mat apropos: "apropos-list: b is not an environment".
@@ -3887,7 +3887,7 @@
   misc.mo:Expected error in mat apropos: "variable $apropos-unbound1 is not bound".
   misc.mo:Expected error in mat apropos: "variable $apropos-unbound2 is not bound".
   misc.mo:Expected error in mat simplify-if: "textual-port?: a is not a port".
---- 4162,4169 ----
+--- 4167,4174 ----
   misc.mo:Expected error in mat apropos: "apropos: 3 is not a symbol or string".
   misc.mo:Expected error in mat apropos: "apropos: (hit me) is not a symbol or string".
   misc.mo:Expected error in mat apropos: "apropos-list: b is not an environment".
@@ -3897,7 +3897,7 @@
   misc.mo:Expected error in mat apropos: "variable $apropos-unbound2 is not bound".
   misc.mo:Expected error in mat simplify-if: "textual-port?: a is not a port".
 ***************
-*** 4178,4193 ****
+*** 4183,4198 ****
   misc.mo:Expected error in mat pariah: "invalid syntax (pariah)".
   misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)".
   misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure".
@@ -3914,7 +3914,7 @@
   misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: 1 is not a procedure".
   misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-a-procedure is not a procedure".
   misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask".
---- 4178,4193 ----
+--- 4183,4198 ----
   misc.mo:Expected error in mat pariah: "invalid syntax (pariah)".
   misc.mo:Expected error in mat pariah: "invalid syntax (pariah . 17)".
   misc.mo:Expected error in mat procedure-arity-mask: "procedure-arity-mask: 17 is not a procedure".
@@ -3932,7 +3932,7 @@
   misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-a-procedure is not a procedure".
   misc.mo:Expected error in mat wrapper-procedure: "make-arity-wrapper-procedure: not-an-exact-integer is not an arity mask".
 ***************
-*** 4197,4209 ****
+*** 4202,4233 ****
   misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: 1 is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure".
@@ -3946,7 +3946,26 @@
   misc.mo:Expected error in mat wrapper-procedure: "set-wrapper-procedure-data!: 1 is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "set-wrapper-procedure-data!: #<procedure> is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "set-wrapper-procedure-data!: #<procedure> is not a wrapper procedure".
---- 4197,4209 ----
+  misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: -1 is not a valid phantom bytevector length".
+  misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: 1267650600228229401496703205376 is not a valid phantom bytevector length".
+  misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: x is not a valid phantom bytevector length".
+! misc.mo:Expected error in mat immobile: "incorrect argument count in call (box-immobile)".
+! misc.mo:Expected error in mat immobile: "incorrect argument count in call (box-immobile 1 2)".
+! misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-vector)".
+  misc.mo:Expected error in mat immobile: "make-immobile-vector: a is not a valid vector length".
+  misc.mo:Expected error in mat immobile: "make-immobile-vector: -10 is not a valid vector length".
+  misc.mo:Expected error in mat immobile: "make-immobile-vector: 1267650600228229401496703205376 is not a valid vector length".
+! misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-vector 10 1 2)".
+! misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-bytevector)".
+  misc.mo:Expected error in mat immobile: "make-immobile-bytevector: a is not a valid bytevector length".
+  misc.mo:Expected error in mat immobile: "variable make-immobile-byte-vector is not bound".
+  misc.mo:Expected error in mat immobile: "make-immobile-bytevector: 1267650600228229401496703205376 is not a valid bytevector length".
+  misc.mo:Expected error in mat immobile: "make-immobile-bytevector: 1024 is not a valid fill value".
+! misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-bytevector 10 1 2)".
+  cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
+  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
+  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))".
+--- 4202,4233 ----
   misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: 1 is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "wrapper-procedure-data: #<procedure> is not a wrapper procedure".
@@ -3960,8 +3979,27 @@
   misc.mo:Expected error in mat wrapper-procedure: "set-wrapper-procedure-data!: 1 is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "set-wrapper-procedure-data!: #<procedure> is not a wrapper procedure".
   misc.mo:Expected error in mat wrapper-procedure: "set-wrapper-procedure-data!: #<procedure> is not a wrapper procedure".
-***************
-*** 4223,4231 ****
+  misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: -1 is not a valid phantom bytevector length".
+  misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: 1267650600228229401496703205376 is not a valid phantom bytevector length".
+  misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: x is not a valid phantom bytevector length".
+! misc.mo:Expected error in mat immobile: "incorrect number of arguments 0 to #<procedure box-immobile>".
+! misc.mo:Expected error in mat immobile: "incorrect number of arguments 2 to #<procedure box-immobile>".
+! misc.mo:Expected error in mat immobile: "incorrect number of arguments 0 to #<procedure make-immobile-vector>".
+  misc.mo:Expected error in mat immobile: "make-immobile-vector: a is not a valid vector length".
+  misc.mo:Expected error in mat immobile: "make-immobile-vector: -10 is not a valid vector length".
+  misc.mo:Expected error in mat immobile: "make-immobile-vector: 1267650600228229401496703205376 is not a valid vector length".
+! misc.mo:Expected error in mat immobile: "incorrect number of arguments 3 to #<procedure make-immobile-vector>".
+! misc.mo:Expected error in mat immobile: "incorrect number of arguments 0 to #<procedure make-immobile-bytevector>".
+  misc.mo:Expected error in mat immobile: "make-immobile-bytevector: a is not a valid bytevector length".
+  misc.mo:Expected error in mat immobile: "variable make-immobile-byte-vector is not bound".
+  misc.mo:Expected error in mat immobile: "make-immobile-bytevector: 1267650600228229401496703205376 is not a valid bytevector length".
+  misc.mo:Expected error in mat immobile: "make-immobile-bytevector: 1024 is not a valid fill value".
+! misc.mo:Expected error in mat immobile: "incorrect number of arguments 3 to #<procedure make-immobile-bytevector>".
+  cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
+  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
+  cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))".
+***************
+*** 4241,4249 ****
   cp0.mo:Expected error in mat cp0-regression: "condition: #f is not a condition".
   cp0.mo:Expected error in mat cp0-regression: "apply: 0 is not a proper list".
   cp0.mo:Expected error in mat cp0-regression: "apply: 2 is not a proper list".
@@ -3971,7 +4009,7 @@
   cp0.mo:Expected error in mat expand-output: "expand-output: #t is not a textual output port or #f".
   cp0.mo:Expected error in mat expand-output: "expand-output: #<binary output port bytevector> is not a textual output port or #f".
   cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #t is not a textual output port or #f".
---- 4223,4231 ----
+--- 4241,4249 ----
   cp0.mo:Expected error in mat cp0-regression: "condition: #f is not a condition".
   cp0.mo:Expected error in mat cp0-regression: "apply: 0 is not a proper list".
   cp0.mo:Expected error in mat cp0-regression: "apply: 2 is not a proper list".
@@ -3982,7 +4020,7 @@
   cp0.mo:Expected error in mat expand-output: "expand-output: #<binary output port bytevector> is not a textual output port or #f".
   cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #t is not a textual output port or #f".
 ***************
-*** 4289,4297 ****
+*** 4307,4315 ****
   5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 . 3) is not a proper list".
   5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 3 2 3 2 ...) is circular".
   5_6.mo:Expected error in mat fxvector->list: "fxvector->list: (a b c) is not an fxvector".
@@ -3992,7 +4030,7 @@
   5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure".
   5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure".
   5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure".
---- 4289,4297 ----
+--- 4307,4315 ----
   5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 . 3) is not a proper list".
   5_6.mo:Expected error in mat list->fxvector: "list->fxvector: (1 2 3 2 3 2 ...) is circular".
   5_6.mo:Expected error in mat fxvector->list: "fxvector->list: (a b c) is not an fxvector".
@@ -4003,7 +4041,7 @@
   5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure".
   5_6.mo:Expected error in mat vector-map: "vector-map: #() is not a procedure".
 ***************
-*** 4306,4314 ****
+*** 4324,4332 ****
   5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #() and #(x) differ".
   5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ".
   5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ".
@@ -4013,7 +4051,7 @@
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure".
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure".
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure".
---- 4306,4314 ----
+--- 4324,4332 ----
   5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #() and #(x) differ".
   5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ".
   5_6.mo:Expected error in mat vector-map: "vector-map: lengths of input vectors #(y) and #() differ".
@@ -4024,7 +4062,7 @@
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure".
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: #() is not a procedure".
 ***************
-*** 4323,4340 ****
+*** 4341,4358 ****
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #() and #(x) differ".
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ".
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ".
@@ -4043,7 +4081,7 @@
   5_6.mo:Expected error in mat vector-sort!: "vector-sort!: 3 is not a mutable vector".
   5_6.mo:Expected error in mat vector-sort!: "vector-sort!: (1 2 3) is not a mutable vector".
   5_6.mo:Expected error in mat vector-sort!: "vector-sort!: #(a b c) is not a procedure".
---- 4323,4340 ----
+--- 4341,4358 ----
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #() and #(x) differ".
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ".
   5_6.mo:Expected error in mat vector-for-each: "vector-for-each: lengths of input vectors #(y) and #() differ".
@@ -4063,7 +4101,7 @@
   5_6.mo:Expected error in mat vector-sort!: "vector-sort!: (1 2 3) is not a mutable vector".
   5_6.mo:Expected error in mat vector-sort!: "vector-sort!: #(a b c) is not a procedure".
 ***************
-*** 4345,4353 ****
+*** 4363,4371 ****
   5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector".
   5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector".
   5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector".
@@ -4073,7 +4111,7 @@
   5_6.mo:Expected error in mat vector-cas!: "vector-cas!: 1 is not a mutable vector".
   5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector".
   5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)".
---- 4345,4353 ----
+--- 4363,4371 ----
   5_6.mo:Expected error in mat vector->immutable-vector: "vector-sort!: #(1 2 3) is not a mutable vector".
   5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-set!: #vfx(1 2 3) is not a mutable fxvector".
   5_6.mo:Expected error in mat fxvector->immutable-fxvector: "fxvector-fill!: #vfx(1 2 3) is not a mutable fxvector".
@@ -4084,7 +4122,7 @@
   5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a mutable vector".
   5_6.mo:Expected error in mat vector-cas!: "vector-cas!: #(4 5 3) is not a valid index for #(4 5 3)".
 ***************
-*** 4404,4411 ****
+*** 4422,4429 ****
   5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol".
   5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol".
   5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol".
@@ -4093,7 +4131,7 @@
   5_8.mo:Expected error in mat box-cas!: "box-cas!: 1 is not a mutable box".
   5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box".
   6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
---- 4404,4411 ----
+--- 4422,4429 ----
   5_7.mo:Expected error in mat putprop-getprop: "getprop: 3 is not a symbol".
   5_7.mo:Expected error in mat putprop-getprop: "putprop: "hi" is not a symbol".
   5_7.mo:Expected error in mat putprop-getprop: "property-list: (a b c) is not a symbol".
@@ -4103,7 +4141,7 @@
   5_8.mo:Expected error in mat box-cas!: "box-cas!: #&1 is not a mutable box".
   6.mo:Expected error in mat port-operations: "open-input-file: failed for nonexistent file: no such file or directory".
 ***************
-*** 4443,4464 ****
+*** 4461,4482 ****
   6.mo:Expected error in mat port-operations: "clear-output-port: not permitted on closed port #<output port testfile.ss>".
   6.mo:Expected error in mat port-operations: "current-output-port: a is not a textual output port".
   6.mo:Expected error in mat port-operations: "current-input-port: a is not a textual input port".
@@ -4126,7 +4164,7 @@
   6.mo:Expected error in mat port-operations1: "open-input-output-file: furball is not a string".
   6.mo:Expected error in mat port-operations1: "open-input-output-file: failed for /probably/not/a/good/path: no such file or directory".
   6.mo:Expected error in mat port-operations1: "open-input-output-file: invalid option compressed".
---- 4443,4464 ----
+--- 4461,4482 ----
   6.mo:Expected error in mat port-operations: "clear-output-port: not permitted on closed port #<output port testfile.ss>".
   6.mo:Expected error in mat port-operations: "current-output-port: a is not a textual output port".
   6.mo:Expected error in mat port-operations: "current-input-port: a is not a textual input port".
@@ -4150,7 +4188,7 @@
   6.mo:Expected error in mat port-operations1: "open-input-output-file: failed for /probably/not/a/good/path: no such file or directory".
   6.mo:Expected error in mat port-operations1: "open-input-output-file: invalid option compressed".
 ***************
-*** 4467,4473 ****
+*** 4485,4491 ****
   6.mo:Expected error in mat port-operations1: "truncate-file: all-the-way is not a valid length".
   6.mo:Expected error in mat port-operations1: "truncate-file: #<input port testfile.ss> is not an output port".
   6.mo:Expected error in mat port-operations1: "truncate-file: animal-crackers is not an output port".
@@ -4158,7 +4196,7 @@
   6.mo:Expected error in mat port-operations1: "truncate-file: not permitted on closed port #<input/output port testfile.ss>".
   6.mo:Expected error in mat port-operations1: "get-output-string: #<input port string> is not a string output port".
   6.mo:Expected error in mat port-operations1: "get-output-string: #<output port testfile.ss> is not a string output port".
---- 4467,4473 ----
+--- 4485,4491 ----
   6.mo:Expected error in mat port-operations1: "truncate-file: all-the-way is not a valid length".
   6.mo:Expected error in mat port-operations1: "truncate-file: #<input port testfile.ss> is not an output port".
   6.mo:Expected error in mat port-operations1: "truncate-file: animal-crackers is not an output port".
@@ -4167,7 +4205,7 @@
   6.mo:Expected error in mat port-operations1: "get-output-string: #<input port string> is not a string output port".
   6.mo:Expected error in mat port-operations1: "get-output-string: #<output port testfile.ss> is not a string output port".
 ***************
-*** 4484,4491 ****
+*** 4502,4509 ****
   6.mo:Expected error in mat string-port-file-position: "file-position: -1 is not a valid position".
   6.mo:Expected error in mat fresh-line: "fresh-line: 3 is not a textual output port".
   6.mo:Expected error in mat fresh-line: "fresh-line: #<input port string> is not a textual output port".
@@ -4176,7 +4214,7 @@
   6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
   6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
   6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format".
---- 4484,4491 ----
+--- 4502,4509 ----
   6.mo:Expected error in mat string-port-file-position: "file-position: -1 is not a valid position".
   6.mo:Expected error in mat fresh-line: "fresh-line: 3 is not a textual output port".
   6.mo:Expected error in mat fresh-line: "fresh-line: #<input port string> is not a textual output port".
@@ -4186,7 +4224,7 @@
   6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
   6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "~a~~~s" in call to format".
 ***************
-*** 6969,7000 ****
+*** 6987,7018 ****
   io.mo:Expected error in mat port-operations: "put-u8: not permitted on closed port #<binary output port testfile.ss>".
   io.mo:Expected error in mat port-operations: "put-bytevector: not permitted on closed port #<binary output port testfile.ss>".
   io.mo:Expected error in mat port-operations: "flush-output-port: not permitted on closed port #<binary output port testfile.ss>".
@@ -4219,7 +4257,7 @@
   io.mo:Expected error in mat port-operations1: "open-file-input/output-port: failed for /probably/not/a/good/path: no such file or directory".
   io.mo:Expected error in mat port-operations1: "invalid file option uncompressed".
   io.mo:Expected error in mat port-operations1: "invalid file option truncate".
---- 6969,7000 ----
+--- 6987,7018 ----
   io.mo:Expected error in mat port-operations: "put-u8: not permitted on closed port #<binary output port testfile.ss>".
   io.mo:Expected error in mat port-operations: "put-bytevector: not permitted on closed port #<binary output port testfile.ss>".
   io.mo:Expected error in mat port-operations: "flush-output-port: not permitted on closed port #<binary output port testfile.ss>".
@@ -4253,7 +4291,7 @@
   io.mo:Expected error in mat port-operations1: "invalid file option uncompressed".
   io.mo:Expected error in mat port-operations1: "invalid file option truncate".
 ***************
-*** 7005,7011 ****
+*** 7023,7029 ****
   io.mo:Expected error in mat port-operations1: "set-port-length!: all-the-way is not a valid length".
   io.mo:Expected error in mat port-operations1: "truncate-port: #<binary input port testfile.ss> is not an output port".
   io.mo:Expected error in mat port-operations1: "truncate-port: animal-crackers is not an output port".
@@ -4261,7 +4299,7 @@
   io.mo:Expected error in mat port-operations1: "truncate-port: not permitted on closed port #<binary input/output port testfile.ss>".
   io.mo:Expected error in mat port-operations3: "file-port?: "not a port" is not a port".
   io.mo:Expected error in mat port-operations3: "port-file-descriptor: oops is not a port".
---- 7005,7011 ----
+--- 7023,7029 ----
   io.mo:Expected error in mat port-operations1: "set-port-length!: all-the-way is not a valid length".
   io.mo:Expected error in mat port-operations1: "truncate-port: #<binary input port testfile.ss> is not an output port".
   io.mo:Expected error in mat port-operations1: "truncate-port: animal-crackers is not an output port".
@@ -4270,7 +4308,7 @@
   io.mo:Expected error in mat port-operations3: "file-port?: "not a port" is not a port".
   io.mo:Expected error in mat port-operations3: "port-file-descriptor: oops is not a port".
 ***************
-*** 7188,7200 ****
+*** 7206,7218 ****
   io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: #vu8(1 2 3) is not a valid size for #<binary output port bytevector>".
   io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: -1 is not a valid size for #<binary output port bytevector>".
   io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: 6 is not a valid size for #<binary output port bytevector>".
@@ -4284,7 +4322,7 @@
   io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: shoe is not a positive fixnum".
   io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0 is not a positive fixnum".
   io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum".
---- 7188,7200 ----
+--- 7206,7218 ----
   io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: #vu8(1 2 3) is not a valid size for #<binary output port bytevector>".
   io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: -1 is not a valid size for #<binary output port bytevector>".
   io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: 6 is not a valid size for #<binary output port bytevector>".
@@ -4299,7 +4337,7 @@
   io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0 is not a positive fixnum".
   io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum".
 ***************
-*** 7220,7235 ****
+*** 7238,7253 ****
   io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
   io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
   io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
@@ -4316,7 +4354,7 @@
   io.mo:Expected error in mat custom-binary-ports: "unget-u8: cannot unget 255 on #<binary input port foo>".
   io.mo:Expected error in mat custom-binary-ports: "put-u8: #<binary input port foo> is not a binary output port".
   io.mo:Expected error in mat custom-binary-ports: "port-length: #<binary input port foo> does not support operation".
---- 7220,7235 ----
+--- 7238,7253 ----
   io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
   io.mo:Expected error in mat compression: "port-file-compressed!: #<output port string> is not a file port".
   io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #<binary input/output port testfile.ss>".
@@ -4334,7 +4372,7 @@
   io.mo:Expected error in mat custom-binary-ports: "put-u8: #<binary input port foo> is not a binary output port".
   io.mo:Expected error in mat custom-binary-ports: "port-length: #<binary input port foo> does not support operation".
 ***************
-*** 7301,7316 ****
+*** 7319,7334 ****
   io.mo:Expected error in mat current-ports: "console-output-port: #<input port string> is not a textual output port".
   io.mo:Expected error in mat current-ports: "console-error-port: #<input port string> is not a textual output port".
   io.mo:Expected error in mat current-transcoder: "current-transcoder: #<output port string> is not a transcoder".
@@ -4351,7 +4389,7 @@
   io.mo:Expected error in mat utf-16-codec: "utf-16-codec: invalid endianness #f".
   io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 0 of #<input port string>".
   io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 15 of #<input port string>".
---- 7301,7316 ----
+--- 7319,7334 ----
   io.mo:Expected error in mat current-ports: "console-output-port: #<input port string> is not a textual output port".
   io.mo:Expected error in mat current-ports: "console-error-port: #<input port string> is not a textual output port".
   io.mo:Expected error in mat current-transcoder: "current-transcoder: #<output port string> is not a transcoder".
@@ -4369,7 +4407,7 @@
   io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 0 of #<input port string>".
   io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 15 of #<input port string>".
 ***************
-*** 7482,7488 ****
+*** 7500,7506 ****
   7.mo:Expected error in mat eval-when: "invalid syntax visit-x".
   7.mo:Expected error in mat eval-when: "invalid syntax revisit-x".
   7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory".
@@ -4377,7 +4415,7 @@
   7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in environment: attempt to import invisible library (testfile-wpo-lib)
   7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found
   7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found
---- 7482,7488 ----
+--- 7500,7506 ----
   7.mo:Expected error in mat eval-when: "invalid syntax visit-x".
   7.mo:Expected error in mat eval-when: "invalid syntax revisit-x".
   7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory".
@@ -4386,7 +4424,7 @@
   7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found
   7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found
 ***************
-*** 7548,7574 ****
+*** 7566,7592 ****
   7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A)
   7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B)
   7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol".
@@ -4414,7 +4452,7 @@
   7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: hello is not an environment".
   7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: #<environment *scheme*> is not a symbol".
   7.mo:Expected error in mat top-level-value-functions: "variable i-am-not-bound-i-hope is not bound".
---- 7548,7574 ----
+--- 7566,7592 ----
   7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A)
   7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B)
   7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol".
@@ -4443,7 +4481,7 @@
   7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: #<environment *scheme*> is not a symbol".
   7.mo:Expected error in mat top-level-value-functions: "variable i-am-not-bound-i-hope is not bound".
 ***************
-*** 7883,7889 ****
+*** 7901,7907 ****
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@@ -4451,7 +4489,7 @@
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>".
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>".
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>".
---- 7883,7889 ----
+--- 7901,7907 ----
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@@ -4460,7 +4498,7 @@
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>".
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar>".
 ***************
-*** 7973,8087 ****
+*** 7991,8105 ****
   hash.mo:Expected error in mat old-hash-table: "hash-table-for-each: ((a . b)) is not an eq hashtable".
   hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>".
   hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>".
@@ -4576,7 +4614,7 @@
   hash.mo:Expected error in mat hashtable-arguments: "hashtable-ephemeron?: (hash . table) is not a hashtable".
   hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value "oops" for any".
   hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value 3.5 for any".
---- 7973,8087 ----
+--- 7991,8105 ----
   hash.mo:Expected error in mat old-hash-table: "hash-table-for-each: ((a . b)) is not an eq hashtable".
   hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>".
   hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments 2 to #<procedure>".
@@ -4693,7 +4731,7 @@
   hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value "oops" for any".
   hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function #<procedure> return value 3.5 for any".
 ***************
-*** 8104,8226 ****
+*** 8122,8244 ****
   hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value "oops" for any".
   hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 3.5 for any".
   hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 1+2i for any".
@@ -4817,7 +4855,7 @@
   hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument -1".
   hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #t".
   hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #f".
---- 8104,8226 ----
+--- 8122,8244 ----
   hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value "oops" for any".
   hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 3.5 for any".
   hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function #<procedure> return value 1+2i for any".
@@ -4942,7 +4980,7 @@
   hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #t".
   hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #f".
 ***************
-*** 8228,8243 ****
+*** 8246,8261 ****
   hash.mo:Expected error in mat generic-hashtable: "hashtable-delete!: #<hashtable> is not mutable".
   hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable".
   hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable".
@@ -4959,7 +4997,7 @@
   hash.mo:Expected error in mat hash-functions: "string-ci-hash: hello is not a string".
   hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<eqv hashtable>".
   hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<hashtable>".
---- 8228,8243 ----
+--- 8246,8261 ----
   hash.mo:Expected error in mat generic-hashtable: "hashtable-delete!: #<hashtable> is not mutable".
   hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable".
   hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: #<hashtable> is not mutable".
@@ -4977,7 +5015,7 @@
   hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<eqv hashtable>".
   hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #<hashtable>".
 ***************
-*** 8353,8360 ****
+*** 8371,8378 ****
   8.mo:Expected error in mat with-syntax: "invalid syntax a".
   8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)".
   8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)".
@@ -4986,7 +5024,7 @@
   8.mo:Expected error in mat generate-temporaries: "generate-temporaries: improper list structure (a b . c)".
   8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)".
   8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #<syntax a>".
---- 8353,8360 ----
+--- 8371,8378 ----
   8.mo:Expected error in mat with-syntax: "invalid syntax a".
   8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)".
   8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)".
@@ -4996,7 +5034,7 @@
   8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)".
   8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #<syntax a>".
 ***************
-*** 8971,8986 ****
+*** 8989,9004 ****
   8.mo:Expected error in mat rnrs-eval: "attempt to assign unbound identifier foo".
   8.mo:Expected error in mat rnrs-eval: "invalid definition in immutable environment (define cons (quote #<procedure vector>))".
   8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: "hello" is not a symbol".
@@ -5013,7 +5051,7 @@
   8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: hello is not an environment".
   8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: #<environment *scheme*> is not a symbol".
   8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: cannot modify immutable environment #<environment *scheme*>".
---- 8971,8986 ----
+--- 8989,9004 ----
   8.mo:Expected error in mat rnrs-eval: "attempt to assign unbound identifier foo".
   8.mo:Expected error in mat rnrs-eval: "invalid definition in immutable environment (define cons (quote #<procedure vector>))".
   8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: "hello" is not a symbol".
@@ -5031,7 +5069,7 @@
   8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: #<environment *scheme*> is not a symbol".
   8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: cannot modify immutable environment #<environment *scheme*>".
 ***************
-*** 9079,9101 ****
+*** 9097,9119 ****
   fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum".
   fx.mo:Expected error in mat fx=?: "fx=?: <int> is not a fixnum".
   fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum".
@@ -5055,7 +5093,7 @@
   fx.mo:Expected error in mat $fxu<: "incorrect number of arguments 1 to #<procedure $fxu<>".
   fx.mo:Expected error in mat $fxu<: "incorrect number of arguments 3 to #<procedure $fxu<>".
   fx.mo:Expected error in mat $fxu<: "$fxu<: <-int> is not a fixnum".
---- 9079,9101 ----
+--- 9097,9119 ----
   fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum".
   fx.mo:Expected error in mat fx=?: "fx=?: <int> is not a fixnum".
   fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum".
@@ -5080,7 +5118,7 @@
   fx.mo:Expected error in mat $fxu<: "incorrect number of arguments 3 to #<procedure $fxu<>".
   fx.mo:Expected error in mat $fxu<: "$fxu<: <-int> is not a fixnum".
 ***************
-*** 9127,9139 ****
+*** 9145,9157 ****
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -5094,7 +5132,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
---- 9127,9139 ----
+--- 9145,9157 ----
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -5109,7 +5147,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
 ***************
-*** 9183,9195 ****
+*** 9201,9213 ****
   fx.mo:Expected error in mat fx1+: "fx1+: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx1+: "fx1+: <int> is not a fixnum".
   fx.mo:Expected error in mat fx1+: "fx1+: a is not a fixnum".
@@ -5123,7 +5161,7 @@
   fx.mo:Expected error in mat fxmax: "fxmax: a is not a fixnum".
   fx.mo:Expected error in mat fxmax: "fxmax: <int> is not a fixnum".
   fx.mo:Expected error in mat fxmax: "fxmax: <-int> is not a fixnum".
---- 9183,9195 ----
+--- 9201,9213 ----
   fx.mo:Expected error in mat fx1+: "fx1+: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx1+: "fx1+: <int> is not a fixnum".
   fx.mo:Expected error in mat fx1+: "fx1+: a is not a fixnum".
@@ -5138,7 +5176,7 @@
   fx.mo:Expected error in mat fxmax: "fxmax: <int> is not a fixnum".
   fx.mo:Expected error in mat fxmax: "fxmax: <-int> is not a fixnum".
 ***************
-*** 9287,9296 ****
+*** 9305,9314 ****
   fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <int> and 10".
   fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments -4097 and <int>".
   fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <-int> and 1".
@@ -5149,7 +5187,7 @@
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: 35.0 is not a fixnum".
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: 5.0 is not a valid start index".
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: 8.0 is not a valid end index".
---- 9287,9296 ----
+--- 9305,9314 ----
   fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <int> and 10".
   fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments -4097 and <int>".
   fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <-int> and 1".
@@ -5161,7 +5199,7 @@
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: 5.0 is not a valid start index".
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: 8.0 is not a valid end index".
 ***************
-*** 9304,9337 ****
+*** 9322,9355 ****
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index".
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid start index".
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index".
@@ -5196,7 +5234,7 @@
   fx.mo:Expected error in mat fxif: "fxif: a is not a fixnum".
   fx.mo:Expected error in mat fxif: "fxif: 3.4 is not a fixnum".
   fx.mo:Expected error in mat fxif: "fxif: (a) is not a fixnum".
---- 9304,9337 ----
+--- 9322,9355 ----
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index".
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid start index".
   fx.mo:Expected error in mat fxbit-field: "fxbit-field: <int> is not a valid end index".
@@ -5232,7 +5270,7 @@
   fx.mo:Expected error in mat fxif: "fxif: 3.4 is not a fixnum".
   fx.mo:Expected error in mat fxif: "fxif: (a) is not a fixnum".
 ***************
-*** 9341,9384 ****
+*** 9359,9402 ****
   fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum".
   fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum".
   fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum".
@@ -5277,7 +5315,7 @@
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: 3.4 is not a fixnum".
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: "3" is not a fixnum".
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: <int> is not a fixnum".
---- 9341,9384 ----
+--- 9359,9402 ----
   fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum".
   fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum".
   fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum".
@@ -5323,7 +5361,7 @@
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: "3" is not a fixnum".
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: <int> is not a fixnum".
 ***************
-*** 9387,9397 ****
+*** 9405,9415 ****
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index -1".
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>".
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>".
@@ -5335,7 +5373,7 @@
   fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: "3" is not a fixnum".
   fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3.4 is not a valid start index".
   fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3/4 is not a valid end index".
---- 9387,9397 ----
+--- 9405,9415 ----
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index -1".
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>".
   fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index <int>".
@@ -5348,7 +5386,7 @@
   fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3.4 is not a valid start index".
   fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3/4 is not a valid end index".
 ***************
-*** 9451,9460 ****
+*** 9469,9478 ****
   fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: (a) is not a fixnum".
   fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0".
   fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0".
@@ -5359,7 +5397,7 @@
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: 1.0 is not a fixnum".
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: 2.0 is not a fixnum".
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: 3.0 is not a fixnum".
---- 9451,9460 ----
+--- 9469,9478 ----
   fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: (a) is not a fixnum".
   fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0".
   fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0".
@@ -5371,7 +5409,7 @@
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: 2.0 is not a fixnum".
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: 3.0 is not a fixnum".
 ***************
-*** 9470,9479 ****
+*** 9488,9497 ****
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum".
@@ -5382,7 +5420,7 @@
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: 1.0 is not a fixnum".
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: 2.0 is not a fixnum".
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: 3.0 is not a fixnum".
---- 9470,9479 ----
+--- 9488,9497 ----
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum".
@@ -5394,7 +5432,7 @@
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: 2.0 is not a fixnum".
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: 3.0 is not a fixnum".
 ***************
-*** 9489,9498 ****
+*** 9507,9516 ****
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum".
@@ -5405,7 +5443,7 @@
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: 1.0 is not a fixnum".
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: 2.0 is not a fixnum".
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: 3.0 is not a fixnum".
---- 9489,9498 ----
+--- 9507,9516 ----
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum".
@@ -5417,7 +5455,7 @@
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: 2.0 is not a fixnum".
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: 3.0 is not a fixnum".
 ***************
-*** 9508,9518 ****
+*** 9526,9536 ****
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum".
@@ -5429,7 +5467,7 @@
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: a is not a fixnum".
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid start index 0.0".
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index 2.0".
---- 9508,9518 ----
+--- 9526,9536 ----
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum".
@@ -5442,7 +5480,7 @@
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid start index 0.0".
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index 2.0".
 ***************
-*** 9535,9544 ****
+*** 9553,9562 ****
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>".
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>".
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: count 1 is greater than difference between end index 5 and start index 5".
@@ -5453,7 +5491,7 @@
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: a is not a fixnum".
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid start index 0.0".
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index 2.0".
---- 9535,9544 ----
+--- 9553,9562 ----
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>".
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index <int>".
   fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: count 1 is greater than difference between end index 5 and start index 5".
@@ -5465,7 +5503,7 @@
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid start index 0.0".
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index 2.0".
 ***************
-*** 9554,9571 ****
+*** 9572,9589 ****
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <int>".
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <-int>".
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: start index 7 is greater than end index 5".
@@ -5484,7 +5522,7 @@
   fl.mo:Expected error in mat fl=: "fl=: (a) is not a flonum".
   fl.mo:Expected error in mat fl=: "fl=: a is not a flonum".
   fl.mo:Expected error in mat fl=: "fl=: a is not a flonum".
---- 9554,9571 ----
+--- 9572,9589 ----
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <int>".
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <-int>".
   fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: start index 7 is greater than end index 5".
@@ -5504,7 +5542,7 @@
   fl.mo:Expected error in mat fl=: "fl=: a is not a flonum".
   fl.mo:Expected error in mat fl=: "fl=: a is not a flonum".
 ***************
-*** 9573,9579 ****
+*** 9591,9597 ****
   fl.mo:Expected error in mat fl=: "fl=: 3 is not a flonum".
   fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum".
@@ -5512,7 +5550,7 @@
   fl.mo:Expected error in mat fl<: "fl<: (a) is not a flonum".
   fl.mo:Expected error in mat fl<: "fl<: a is not a flonum".
   fl.mo:Expected error in mat fl<: "fl<: a is not a flonum".
---- 9573,9579 ----
+--- 9591,9597 ----
   fl.mo:Expected error in mat fl=: "fl=: 3 is not a flonum".
   fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum".
@@ -5521,7 +5559,7 @@
   fl.mo:Expected error in mat fl<: "fl<: a is not a flonum".
   fl.mo:Expected error in mat fl<: "fl<: a is not a flonum".
 ***************
-*** 9581,9587 ****
+*** 9599,9605 ****
   fl.mo:Expected error in mat fl<: "fl<: 3 is not a flonum".
   fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum".
@@ -5529,7 +5567,7 @@
   fl.mo:Expected error in mat fl>: "fl>: (a) is not a flonum".
   fl.mo:Expected error in mat fl>: "fl>: a is not a flonum".
   fl.mo:Expected error in mat fl>: "fl>: a is not a flonum".
---- 9581,9587 ----
+--- 9599,9605 ----
   fl.mo:Expected error in mat fl<: "fl<: 3 is not a flonum".
   fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum".
@@ -5538,7 +5576,7 @@
   fl.mo:Expected error in mat fl>: "fl>: a is not a flonum".
   fl.mo:Expected error in mat fl>: "fl>: a is not a flonum".
 ***************
-*** 9589,9595 ****
+*** 9607,9613 ****
   fl.mo:Expected error in mat fl>: "fl>: 3 is not a flonum".
   fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum".
@@ -5546,7 +5584,7 @@
   fl.mo:Expected error in mat fl<=: "fl<=: (a) is not a flonum".
   fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum".
   fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum".
---- 9589,9595 ----
+--- 9607,9613 ----
   fl.mo:Expected error in mat fl>: "fl>: 3 is not a flonum".
   fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum".
@@ -5555,7 +5593,7 @@
   fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum".
   fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum".
 ***************
-*** 9597,9603 ****
+*** 9615,9621 ****
   fl.mo:Expected error in mat fl<=: "fl<=: 3 is not a flonum".
   fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum".
@@ -5563,7 +5601,7 @@
   fl.mo:Expected error in mat fl>=: "fl>=: (a) is not a flonum".
   fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum".
   fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum".
---- 9597,9603 ----
+--- 9615,9621 ----
   fl.mo:Expected error in mat fl<=: "fl<=: 3 is not a flonum".
   fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum".
@@ -5572,7 +5610,7 @@
   fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum".
   fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum".
 ***************
-*** 9605,9644 ****
+*** 9623,9662 ****
   fl.mo:Expected error in mat fl>=: "fl>=: 3 is not a flonum".
   fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum".
@@ -5613,7 +5651,7 @@
   fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum".
   fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum".
   fl.mo:Expected error in mat fl>=?: "fl>=?: 3 is not a flonum".
---- 9605,9644 ----
+--- 9623,9662 ----
   fl.mo:Expected error in mat fl>=: "fl>=: 3 is not a flonum".
   fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum".
   fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum".
@@ -5655,7 +5693,7 @@
   fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum".
   fl.mo:Expected error in mat fl>=?: "fl>=?: 3 is not a flonum".
 ***************
-*** 9648,9654 ****
+*** 9666,9672 ****
   fl.mo:Expected error in mat fl+: "fl+: (a . b) is not a flonum".
   fl.mo:Expected error in mat fl+: "fl+: 1 is not a flonum".
   fl.mo:Expected error in mat fl+: "fl+: 2/3 is not a flonum".
@@ -5663,7 +5701,7 @@
   fl.mo:Expected error in mat fl-: "fl-: (a . b) is not a flonum".
   fl.mo:Expected error in mat fl-: "fl-: 1 is not a flonum".
   fl.mo:Expected error in mat fl-: "fl-: a is not a flonum".
---- 9648,9654 ----
+--- 9666,9672 ----
   fl.mo:Expected error in mat fl+: "fl+: (a . b) is not a flonum".
   fl.mo:Expected error in mat fl+: "fl+: 1 is not a flonum".
   fl.mo:Expected error in mat fl+: "fl+: 2/3 is not a flonum".
@@ -5672,7 +5710,7 @@
   fl.mo:Expected error in mat fl-: "fl-: 1 is not a flonum".
   fl.mo:Expected error in mat fl-: "fl-: a is not a flonum".
 ***************
-*** 9658,9740 ****
+*** 9676,9758 ****
   fl.mo:Expected error in mat fl*: "fl*: (a . b) is not a flonum".
   fl.mo:Expected error in mat fl*: "fl*: 1 is not a flonum".
   fl.mo:Expected error in mat fl*: "fl*: 2/3 is not a flonum".
@@ -5756,7 +5794,7 @@
   fl.mo:Expected error in mat flround: "flround: a is not a flonum".
   fl.mo:Expected error in mat flround: "flround: 2.0+1.0i is not a flonum".
   fl.mo:Expected error in mat flround: "flround: 2+1i is not a flonum".
---- 9658,9740 ----
+--- 9676,9758 ----
   fl.mo:Expected error in mat fl*: "fl*: (a . b) is not a flonum".
   fl.mo:Expected error in mat fl*: "fl*: 1 is not a flonum".
   fl.mo:Expected error in mat fl*: "fl*: 2/3 is not a flonum".
@@ -5841,7 +5879,7 @@
   fl.mo:Expected error in mat flround: "flround: 2.0+1.0i is not a flonum".
   fl.mo:Expected error in mat flround: "flround: 2+1i is not a flonum".
 ***************
-*** 9754,9789 ****
+*** 9772,9807 ****
   fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3 is not a flonum".
   fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3/4 is not a flonum".
   fl.mo:Expected error in mat flinfinite?: "flinfinite?: hi is not a flonum".
@@ -5878,7 +5916,7 @@
   fl.mo:Expected error in mat fleven?: "fleven?: a is not a flonum".
   fl.mo:Expected error in mat fleven?: "fleven?: 3 is not a flonum".
   fl.mo:Expected error in mat fleven?: "fleven?: 3.2 is not an integer".
---- 9754,9789 ----
+--- 9772,9807 ----
   fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3 is not a flonum".
   fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3/4 is not a flonum".
   fl.mo:Expected error in mat flinfinite?: "flinfinite?: hi is not a flonum".
@@ -5916,7 +5954,7 @@
   fl.mo:Expected error in mat fleven?: "fleven?: 3 is not a flonum".
   fl.mo:Expected error in mat fleven?: "fleven?: 3.2 is not an integer".
 ***************
-*** 9791,9798 ****
+*** 9809,9816 ****
   fl.mo:Expected error in mat fleven?: "fleven?: 1+1i is not a flonum".
   fl.mo:Expected error in mat fleven?: "fleven?: +inf.0 is not an integer".
   fl.mo:Expected error in mat fleven?: "fleven?: +nan.0 is not an integer".
@@ -5925,7 +5963,7 @@
   fl.mo:Expected error in mat flodd?: "flodd?: a is not a flonum".
   fl.mo:Expected error in mat flodd?: "flodd?: 3 is not a flonum".
   fl.mo:Expected error in mat flodd?: "flodd?: 3.2 is not an integer".
---- 9791,9798 ----
+--- 9809,9816 ----
   fl.mo:Expected error in mat fleven?: "fleven?: 1+1i is not a flonum".
   fl.mo:Expected error in mat fleven?: "fleven?: +inf.0 is not an integer".
   fl.mo:Expected error in mat fleven?: "fleven?: +nan.0 is not an integer".
@@ -5935,7 +5973,7 @@
   fl.mo:Expected error in mat flodd?: "flodd?: 3 is not a flonum".
   fl.mo:Expected error in mat flodd?: "flodd?: 3.2 is not an integer".
 ***************
-*** 9800,9806 ****
+*** 9818,9824 ****
   fl.mo:Expected error in mat flodd?: "flodd?: 3+1i is not a flonum".
   fl.mo:Expected error in mat flodd?: "flodd?: +inf.0 is not an integer".
   fl.mo:Expected error in mat flodd?: "flodd?: +nan.0 is not an integer".
@@ -5943,7 +5981,7 @@
   fl.mo:Expected error in mat flmin: "flmin: a is not a flonum".
   fl.mo:Expected error in mat flmin: "flmin: a is not a flonum".
   fl.mo:Expected error in mat flmin: "flmin: a is not a flonum".
---- 9800,9806 ----
+--- 9818,9824 ----
   fl.mo:Expected error in mat flodd?: "flodd?: 3+1i is not a flonum".
   fl.mo:Expected error in mat flodd?: "flodd?: +inf.0 is not an integer".
   fl.mo:Expected error in mat flodd?: "flodd?: +nan.0 is not an integer".
@@ -5952,7 +5990,7 @@
   fl.mo:Expected error in mat flmin: "flmin: a is not a flonum".
   fl.mo:Expected error in mat flmin: "flmin: a is not a flonum".
 ***************
-*** 9808,9814 ****
+*** 9826,9832 ****
   fl.mo:Expected error in mat flmin: "flmin: a is not a flonum".
   fl.mo:Expected error in mat flmin: "flmin: 0.0+1.0i is not a flonum".
   fl.mo:Expected error in mat flmin: "flmin: 0+1i is not a flonum".
@@ -5960,7 +5998,7 @@
   fl.mo:Expected error in mat flmax: "flmax: a is not a flonum".
   fl.mo:Expected error in mat flmax: "flmax: a is not a flonum".
   fl.mo:Expected error in mat flmax: "flmax: 3 is not a flonum".
---- 9808,9814 ----
+--- 9826,9832 ----
   fl.mo:Expected error in mat flmin: "flmin: a is not a flonum".
   fl.mo:Expected error in mat flmin: "flmin: 0.0+1.0i is not a flonum".
   fl.mo:Expected error in mat flmin: "flmin: 0+1i is not a flonum".
@@ -5969,7 +6007,7 @@
   fl.mo:Expected error in mat flmax: "flmax: a is not a flonum".
   fl.mo:Expected error in mat flmax: "flmax: 3 is not a flonum".
 ***************
-*** 9816,9829 ****
+*** 9834,9847 ****
   fl.mo:Expected error in mat flmax: "flmax: a is not a flonum".
   fl.mo:Expected error in mat flmax: "flmax: 0.0+1.0i is not a flonum".
   fl.mo:Expected error in mat flmax: "flmax: 0+1i is not a flonum".
@@ -5984,7 +6022,7 @@
   fl.mo:Expected error in mat fldenominator: "fldenominator: a is not a flonum".
   fl.mo:Expected error in mat fldenominator: "fldenominator: 3 is not a flonum".
   fl.mo:Expected error in mat fldenominator: "fldenominator: 0+1i is not a flonum".
---- 9816,9829 ----
+--- 9834,9847 ----
   fl.mo:Expected error in mat flmax: "flmax: a is not a flonum".
   fl.mo:Expected error in mat flmax: "flmax: 0.0+1.0i is not a flonum".
   fl.mo:Expected error in mat flmax: "flmax: 0+1i is not a flonum".
@@ -6000,7 +6038,7 @@
   fl.mo:Expected error in mat fldenominator: "fldenominator: 3 is not a flonum".
   fl.mo:Expected error in mat fldenominator: "fldenominator: 0+1i is not a flonum".
 ***************
-*** 9869,9875 ****
+*** 9887,9893 ****
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
@@ -6008,7 +6046,7 @@
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
---- 9869,9875 ----
+--- 9887,9893 ----
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
@@ -6017,7 +6055,7 @@
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
   cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum".
 ***************
-*** 9879,9892 ****
+*** 9897,9910 ****
   cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum".
   cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum".
   cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum".
@@ -6032,7 +6070,7 @@
   foreign.mo:Expected error in mat load-shared-object: "load-shared-object: invalid path 3".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"".
---- 9879,9892 ----
+--- 9897,9910 ----
   cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum".
   cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum".
   cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum".
@@ -6048,7 +6086,7 @@
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"".
 ***************
-*** 9921,9928 ****
+*** 9939,9946 ****
   foreign.mo:Expected error in mat foreign-procedure: "id: invalid foreign-procedure argument foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle abcde".
   foreign.mo:Expected error in mat foreign-procedure: "float_id: invalid foreign-procedure argument 0".
@@ -6057,7 +6095,7 @@
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
   foreign.mo:Expected error in mat foreign-bytevectors: "u8*->u8*: invalid foreign-procedure argument "hello"".
---- 9921,9928 ----
+--- 9939,9946 ----
   foreign.mo:Expected error in mat foreign-procedure: "id: invalid foreign-procedure argument foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle abcde".
   foreign.mo:Expected error in mat foreign-procedure: "float_id: invalid foreign-procedure argument 0".
@@ -6067,7 +6105,7 @@
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
   foreign.mo:Expected error in mat foreign-bytevectors: "u8*->u8*: invalid foreign-procedure argument "hello"".
 ***************
-*** 10420,10432 ****
+*** 10438,10450 ****
   unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory".
   unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory".
   unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory".
@@ -6081,7 +6119,7 @@
   windows.mo:Expected error in mat registry: "get-registry: pooh is not a string".
   windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string".
   windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string".
---- 10420,10432 ----
+--- 10438,10450 ----
   unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory".
   unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory".
   unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory".
@@ -6096,7 +6134,7 @@
   windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string".
   windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string".
 ***************
-*** 10454,10525 ****
+*** 10472,10543 ****
   ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for -inf.0 would be outside of fixnum range".
   ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for +nan.0 would be outside of fixnum range".
   ieee.mo:Expected error in mat fllp: "fllp: 3 is not a flonum".
@@ -6169,7 +6207,7 @@
   date.mo:Expected error in mat time: "time>=?: 3 is not a time record".
   date.mo:Expected error in mat time: "time>=?: #<procedure car> is not a time record".
   date.mo:Expected error in mat time: "time>=?: types of <time> and <time> differ".
---- 10454,10525 ----
+--- 10472,10543 ----
   ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for -inf.0 would be outside of fixnum range".
   ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for +nan.0 would be outside of fixnum range".
   ieee.mo:Expected error in mat fllp: "fllp: 3 is not a flonum".
@@ -6243,7 +6281,7 @@
   date.mo:Expected error in mat time: "time>=?: #<procedure car> is not a time record".
   date.mo:Expected error in mat time: "time>=?: types of <time> and <time> differ".
 ***************
-*** 10527,10540 ****
+*** 10545,10558 ****
   date.mo:Expected error in mat time: "add-duration: <time> does not have type time-duration".
   date.mo:Expected error in mat time: "subtract-duration: <time> does not have type time-duration".
   date.mo:Expected error in mat time: "copy-time: <date> is not a time record".
@@ -6258,7 +6296,7 @@
   date.mo:Expected error in mat date: "make-date: invalid nanosecond -1".
   date.mo:Expected error in mat date: "make-date: invalid nanosecond <int>".
   date.mo:Expected error in mat date: "make-date: invalid nanosecond zero".
---- 10527,10540 ----
+--- 10545,10558 ----
   date.mo:Expected error in mat time: "add-duration: <time> does not have type time-duration".
   date.mo:Expected error in mat time: "subtract-duration: <time> does not have type time-duration".
   date.mo:Expected error in mat time: "copy-time: <date> is not a time record".
@@ -6274,7 +6312,7 @@
   date.mo:Expected error in mat date: "make-date: invalid nanosecond <int>".
   date.mo:Expected error in mat date: "make-date: invalid nanosecond zero".
 ***************
-*** 10560,10620 ****
+*** 10578,10638 ****
   date.mo:Expected error in mat date: "make-date: invalid time-zone offset 90000".
   date.mo:Expected error in mat date: "make-date: invalid time-zone offset est".
   date.mo:Expected error in mat date: "make-date: invalid time-zone offset "est"".
@@ -6336,7 +6374,7 @@
   date.mo:Expected error in mat date: "current-date: invalid time-zone offset -90000".
   date.mo:Expected error in mat date: "current-date: invalid time-zone offset 90000".
   date.mo:Expected error in mat conversions/sleep: "date->time-utc: <time> is not a date record".
---- 10560,10620 ----
+--- 10578,10638 ----
   date.mo:Expected error in mat date: "make-date: invalid time-zone offset 90000".
   date.mo:Expected error in mat date: "make-date: invalid time-zone offset est".
   date.mo:Expected error in mat date: "make-date: invalid time-zone offset "est"".
diff --git a/src/ChezScheme/mats/patch-interpret-0-f-t-f b/src/ChezScheme/mats/patch-interpret-0-f-t-f
index 7c881ead11..2eae3d95fc 100644
--- a/src/ChezScheme/mats/patch-interpret-0-f-t-f
+++ b/src/ChezScheme/mats/patch-interpret-0-f-t-f
@@ -1,5 +1,5 @@
-*** errors-compile-0-f-t-f	2020-03-11 21:56:23.000000000 -0600
---- errors-interpret-0-f-t-f	2020-03-11 22:23:49.000000000 -0600
+*** errors-compile-0-f-t-f	2020-06-03 11:23:43.000000000 -0600
+--- errors-interpret-0-f-t-f	2020-06-03 15:11:49.000000000 -0600
 ***************
 *** 18,25 ****
   primvars.mo:Expected error testing (environment (quote (chezscheme)) (quote (chezscheme)) (quote #f)): Exception in environment: invalid library reference #f
@@ -20,7 +20,7 @@
   primvars.mo:Expected error testing (expand 1.0+2.0i (quote #f)): Exception in sc-expand: #f is not an environment
   primvars.mo:Expected error testing (expand 1.0+2.0i (quote ((a . b))) 1.0+2.0i): Exception in sc-expand: ((a . b)) is not an environment
 ***************
-*** 130,136 ****
+*** 74,80 ****
   primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
   primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
   primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>".
@@ -28,7 +28,7 @@
   primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: a is not a positive fixnum".
   primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
   primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
---- 130,136 ----
+--- 74,80 ----
   primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
   primvars.mo:Expected error in mat make-parameter: "+: a is not a number".
   primvars.mo:Expected error in mat make-parameter: "incorrect number of arguments 1 to #<procedure>".
@@ -37,7 +37,7 @@
   primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: -1 is not a positive fixnum".
   primvars.mo:Expected error in mat collect-generation-radix: "collect-generation-radix: 0 is not a positive fixnum".
 ***************
-*** 157,227 ****
+*** 101,171 ****
   primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
   primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
   primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@@ -109,7 +109,7 @@
   3.mo:Expected error in mat let: "incorrect argument count in call ((lambda (x . r) (eq? x (...))))".
   3.mo:Expected error in mat letrec: "variable f is not bound".
   3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
---- 157,227 ----
+--- 101,171 ----
   primvars.mo:Expected error in mat print-radix: "print-radix: 1 is not between 2 and 36".
   primvars.mo:Expected error in mat timer-interrupt-handler: "timer-interrupt-handler: midnight is not a procedure".
   primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input port string> is not a textual output port".
@@ -182,7 +182,7 @@
   3.mo:Expected error in mat letrec: "variable f is not bound".
   3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
 ***************
-*** 7462,7468 ****
+*** 7424,7430 ****
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@@ -190,7 +190,7 @@
   7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
---- 7462,7468 ----
+--- 7424,7430 ----
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@@ -199,7 +199,7 @@
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
 ***************
-*** 7650,7657 ****
+*** 7612,7619 ****
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -208,7 +208,7 @@
   record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
---- 7650,7657 ----
+--- 7612,7619 ----
   7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
   7.mo:Expected error in mat error: "a: hit me!".
   7.mo:Expected error in mat error: "f: n is 0".
@@ -218,7 +218,7 @@
   record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
   record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
 ***************
-*** 7659,7673 ****
+*** 7621,7635 ****
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -234,7 +234,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid input #f".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
---- 7659,7673 ----
+--- 7621,7635 ----
   record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
   record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
   record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@@ -251,7 +251,7 @@
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
   record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
 ***************
-*** 7680,7705 ****
+*** 7642,7667 ****
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -278,7 +278,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
---- 7680,7705 ----
+--- 7642,7667 ----
   record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
   record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@@ -306,7 +306,7 @@
   record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
   record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
 ***************
-*** 7830,7868 ****
+*** 7792,7830 ****
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -346,7 +346,7 @@
   record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
---- 7830,7868 ----
+--- 7792,7830 ----
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
   record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@@ -387,14 +387,14 @@
   record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
   record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
 ***************
-*** 7877,7933 ****
+*** 7839,7895 ****
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure n>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure n>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure pcons>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure pcons>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (ccons 1)".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (ccons 1 2 3)".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect argument count in call (n (+ z 7) w "what?")".
@@ -445,14 +445,14 @@
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
---- 7877,7933 ----
+--- 7839,7895 ----
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
   record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 2 to #<procedure constructor>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
-! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
+  record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
 ! record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 4 to #<procedure constructor>".
@@ -504,7 +504,7 @@
   record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
   record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
 ***************
-*** 9127,9139 ****
+*** 9089,9101 ****
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -518,7 +518,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
---- 9127,9139 ----
+--- 9089,9101 ----
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -533,7 +533,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
 ***************
-*** 10623,10632 ****
+*** 10585,10594 ****
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@@ -544,7 +544,7 @@
   oop.mo:Expected error in mat oop: "m1: not applicable to 17".
   oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
   oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
---- 10623,10632 ----
+--- 10585,10594 ----
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
diff --git a/src/ChezScheme/mats/primvars.ms b/src/ChezScheme/mats/primvars.ms
index 17ddfbd309..fa2bd042a5 100644
--- a/src/ChezScheme/mats/primvars.ms
+++ b/src/ChezScheme/mats/primvars.ms
@@ -635,7 +635,11 @@
                                                                              "invalid palette ~s"
                                                                              "bit argument ~s is not 0 or 1"
                                                                              "unrecognized type ~s"
-                                                                             "invalid code page ~s")))
+                                                                             "invalid code page ~s"
+                                                                             "invalid mask ~s"
+                                                                             "invalid removal mask ~s"
+                                                                             "invalid addition mask ~s"
+                                                                             "invalid field count ~s")))
                                                                     (equal? (condition-irritants c) (list bad)))
                                                                (and (or (member (condition-message c)
                                                                           '("~s is not a valid index for ~s"
diff --git a/src/ChezScheme/mats/root-experr-compile-0-f-f-f b/src/ChezScheme/mats/root-experr-compile-0-f-f-f
index fc44dbfa8f..9b3d5453b6 100644
--- a/src/ChezScheme/mats/root-experr-compile-0-f-f-f
+++ b/src/ChezScheme/mats/root-experr-compile-0-f-f-f
@@ -36,13 +36,9 @@ primvars.mo:Expected error testing (hashtable-cells (quote #f)): Exception in ha
 primvars.mo:Expected error testing (make-input-port (quote 0) "a"): Exception in make-input-port: fixnum handler no longer supported; use open-fd-input-port
 primvars.mo:Expected error testing (make-input/output-port (quote 0) "a" "a"): Exception in make-input/output-port: fixnum handler no longer supported; use open-fd-input-port
 primvars.mo:Expected error testing (make-output-port (quote 0) "a"): Exception in make-output-port: fixnum handler no longer supported; use open-fd-input-port
-primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote q) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count q
-primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote 1152921504606846976) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count 1152921504606846976
-primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote -1152921504606846977) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count -1152921504606846977
-primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i (quote #f) (- (most-negative-fixnum) 1)): Exception in make-record-type-descriptor*: invalid field count #f
-primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote 2.0)): Exception in make-record-type-descriptor*: invalid field count -1
-primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote 1/2)): Exception in make-record-type-descriptor*: invalid field count -1
-primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i -1 (quote #f)): Exception in make-record-type-descriptor*: invalid field count -1
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i 0 (quote 2.0)): Exception in make-record-type-descriptor*: invalid mutability mask 2.0 for field count 0
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i 0 (quote 1/2)): Exception in make-record-type-descriptor*: invalid mutability mask 1/2 for field count 0
+primvars.mo:Expected error testing (make-record-type-descriptor* (quote a) *rtd (quote a) 1.0+2.0i 1.0+2.0i 0 (quote #f)): Exception in make-record-type-descriptor*: invalid mutability mask #f for field count 0
 primvars.mo:Expected error testing (make-sstats (quote "no-time") *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: cpu value "no-time" is not a time record
 primvars.mo:Expected error testing (make-sstats (quote #f) *time (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: cpu value #f is not a time record
 primvars.mo:Expected error testing (make-sstats *time (quote "no-time") (- (most-negative-fixnum) 1) (- (most-negative-fixnum) 1) *time *time (- (most-negative-fixnum) 1)): Exception in make-sstats: real value "no-time" is not a time record
@@ -68,58 +64,6 @@ primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #!eof)
 primvars.mo:Expected error testing (pseudo-random-generator-next! (quote #f) *pseudo-random-generator): Exception: variable *pseudo-random-generator is not bound
 primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote 0)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
 primvars.mo:Expected error testing (set-wrapper-procedure! 1.0+2.0i (quote #f)): Exception in set-wrapper-procedure!: 1.0+2.0i is not a wrapper procedure
-primvars.mo:Expected error testing (stencil-vector (quote -1)): Exception in stencil-vector: invalid mask -1
-primvars.mo:Expected error testing (stencil-vector (quote a)): Exception in stencil-vector: invalid mask a
-primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616)): Exception in stencil-vector: invalid mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector (quote #f)): Exception in stencil-vector: invalid mask #f
-primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i): Exception in stencil-vector: invalid mask -1
-primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i): Exception in stencil-vector: invalid mask a
-primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i): Exception in stencil-vector: invalid mask #f
-primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask -1
-primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask a
-primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask #f
-primvars.mo:Expected error testing (stencil-vector (quote -1) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask -1
-primvars.mo:Expected error testing (stencil-vector (quote a) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask a
-primvars.mo:Expected error testing (stencil-vector (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector (quote #f) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector: invalid mask #f
-primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote -1)): Exception in stencil-vector-truncate!: invalid mask -1
-primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote a)): Exception in stencil-vector-truncate!: invalid mask a
-primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote 18446744073709551616)): Exception in stencil-vector-truncate!: invalid mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-truncate! (stencil-vector 7 1 2 3) (quote #f)): Exception in stencil-vector-truncate!: invalid mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0): Exception in stencil-vector-update: invalid removal mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0): Exception in stencil-vector-update: invalid removal mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0): Exception in stencil-vector-update: invalid removal mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1)): Exception in stencil-vector-update: invalid addition mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a)): Exception in stencil-vector-update: invalid addition mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616)): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f)): Exception in stencil-vector-update: invalid addition mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote -1) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote a) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote 18446744073709551616) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) (quote #f) 0 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid removal mask #f
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote -1) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask -1
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote a) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask a
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote 18446744073709551616) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask 18446744073709551616
-primvars.mo:Expected error testing (stencil-vector-update (stencil-vector 7 1 2 3) 0 (quote #f) 1.0+2.0i 1.0+2.0i 1.0+2.0i): Exception in stencil-vector-update: invalid addition mask #f
 primvars.mo:Expected error testing (vector->pseudo-random-generator (quote "a")): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector "a"
 primvars.mo:Expected error testing (vector->pseudo-random-generator (quote #f)): Exception in vector->pseudo-random-generator: not a valid pseudo-random generator state vector #f
 primvars.mo:Expected error testing (vector->pseudo-random-generator! (quote #f) (quote #(a))): Exception in vector->pseudo-random-generator!: not a pseudo-random generator #f
@@ -4215,6 +4159,19 @@ misc.mo:Expected error in mat wrapper-procedure: "set-wrapper-procedure-data!: #
 misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: -1 is not a valid phantom bytevector length".
 misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: 1267650600228229401496703205376 is not a valid phantom bytevector length".
 misc.mo:Expected error in mat phantom-bytevector: "make-phantom-bytevector: x is not a valid phantom bytevector length".
+misc.mo:Expected error in mat immobile: "incorrect argument count in call (box-immobile)".
+misc.mo:Expected error in mat immobile: "incorrect argument count in call (box-immobile 1 2)".
+misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-vector)".
+misc.mo:Expected error in mat immobile: "make-immobile-vector: a is not a valid vector length".
+misc.mo:Expected error in mat immobile: "make-immobile-vector: -10 is not a valid vector length".
+misc.mo:Expected error in mat immobile: "make-immobile-vector: 1267650600228229401496703205376 is not a valid vector length".
+misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-vector 10 1 2)".
+misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-bytevector)".
+misc.mo:Expected error in mat immobile: "make-immobile-bytevector: a is not a valid bytevector length".
+misc.mo:Expected error in mat immobile: "variable make-immobile-byte-vector is not bound".
+misc.mo:Expected error in mat immobile: "make-immobile-bytevector: 1267650600228229401496703205376 is not a valid bytevector length".
+misc.mo:Expected error in mat immobile: "make-immobile-bytevector: 1024 is not a valid fill value".
+misc.mo:Expected error in mat immobile: "incorrect argument count in call (make-immobile-bytevector 10 1 2)".
 cp0.mo:Expected error in mat cp0-regression: "attempt to reference undefined variable x".
 cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (g)".
 cp0.mo:Expected error in mat cp0-regression: "incorrect argument count in call (cont0 (quote x))".
@@ -9993,6 +9950,7 @@ foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid
 foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
+foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 foreign.mo:Expected error in mat foreign-C-types: "int-to-int: invalid foreign-procedure argument qqq".
 foreign.mo:Expected error in mat foreign-C-types: "unsigned-to-unsigned: invalid foreign-procedure argument qqq".
 foreign.mo:Expected error in mat foreign-C-types: "unsigned-int-to-unsigned-int: invalid foreign-procedure argument qqq".
diff --git a/src/ChezScheme/mats/thread.ms b/src/ChezScheme/mats/thread.ms
index 8d4cbfb77d..64d9e403d0 100644
--- a/src/ChezScheme/mats/thread.ms
+++ b/src/ChezScheme/mats/thread.ms
@@ -751,11 +751,11 @@
                                            (collect))])
                            (chew 0)))
                        (set! q (+ q 7)))])
-              (lock-object p)
-              (bt p)
-              (let f () (when (= q 0) ($yield) (f)))
-              (let f () (unless (= (length ($threads)) 1) ($yield) (f)))
-              (unlock-object p))
+              (let ([b (box-immobile p)])
+                (bt b)
+                (let f () (when (= q 0) ($yield) (f)))
+                (let f () (unless (= (length ($threads)) 1) ($yield) (f)))
+                (set-box! b #f)))
             (unless (= q 14) (errorf #f "~s isn't 14" q))
             (f (- n 1)))))
       'cool)
@@ -1568,7 +1568,64 @@
         (set! done? #t)
         (condition-broadcast c))
       (equal? gc-ids (list (get-thread-id)))))
+  )
+
+(mat memory-consistency
+  (equal? (memory-order-acquire) (void))
+  (equal? (memory-order-release) (void))
+  ;; Try to make a thread see a partially constructed box
+  (let ([ids '(one two three four)])
+    (let ([m (make-mutex)]
+          [c (make-condition)]
+          [ok? #t]
+          [running (length ids)]
+          [v (make-vector 1000 (box (car ids)))])
+      (let loop ([i running])
+        (unless (= i 0)
+          (fork-thread (lambda ()
+                         (let ([id (list-ref ids (sub1 i))]
+                               [failed? #f])
+                           (let loop ([j 10000])
+                             (cond
+                               [(fx= j 0)
+                                (mutex-acquire m)
+                                (set! running (sub1 running))
+                                (condition-signal c)
+                                (set! ok? (and ok? (not failed?)))
+                                (mutex-release m)]
+                               [else
+                                (let loop ([i 0])
+                                  (unless (fx= i (vector-length v))
+                                    (let ([b (vector-ref v i)])
+                                      (unless (and (box? b)
+                                                   (memq (unbox b) ids))
+                                        (set! failed? #t)))
+                                    (vector-set! v i (box id))
+                                    (loop (fx+ i 1))))
+                                (loop (fx- j 1))])))))
+          (loop (sub1 i))))
+      (mutex-acquire m)
+      (let loop ()
+        (cond
+          [(not (zero? running))
+           (condition-wait c m)
+           (loop)]
+          [else
+           (mutex-release m)]))
+      ok?))
+)
+
+(mat wait-for-threads
+  (begin
+    ;; To avoid breaking later tests that use `(collect)`,
+    ;; wait for any threads created here to exit
+    (let ()
+      (define $threads (foreign-procedure "(cs)threads" () scheme-object))
+      (let loop ()
+        (unless (= 1 (length ($threads)))
+          (sleep (make-time 'time-duration 10000 0))
+          (loop))))
+    #t)
 )
-  
 
 )
diff --git a/src/ChezScheme/s/5_2.ss b/src/ChezScheme/s/5_2.ss
index 67e1830a27..de579b19ea 100644
--- a/src/ChezScheme/s/5_2.ss
+++ b/src/ChezScheme/s/5_2.ss
@@ -792,3 +792,31 @@
   (set! enumerate
     (lambda (ls)
       ($iota (fx- ($list-length ls 'enumerate) 1) '()))))
+
+(define list-assuming-immutable?
+  ;; Use list bits to record discovered listness:
+  ;;   0 => unknown
+  ;;   1 => is a list
+  ;;   2 => not a list
+  ;; Record this information half-way to the point that the
+  ;; decision is made (i.e., a kind of path compression)
+  (lambda (v)
+    (or (null? v)
+        (and (pair? v)
+             (let loop ([fast (cdr v)] [slow v] [slow-step? #f])
+               (let ([return (lambda (bits)
+                               ($list-bits-set! slow bits)
+                               (fx= bits 1))])
+                 (cond
+                   [(null? fast) (return 1)]
+                   [(not (pair? fast)) (return 2)]
+                   [(eq? fast slow) (return 2)] ; cycle
+                   [else
+                    (let ([bits ($list-bits-ref fast)])
+                      (cond
+                        [(fx= bits 0)
+                         (if slow-step?
+                             (loop (cdr fast) (cdr slow) #f)
+                             (loop (cdr fast) slow #t))]
+                        [else
+                         (return bits)]))])))))))
diff --git a/src/ChezScheme/s/5_3.ss b/src/ChezScheme/s/5_3.ss
index e377cf8b9e..b1e0aea996 100644
--- a/src/ChezScheme/s/5_3.ss
+++ b/src/ChezScheme/s/5_3.ss
@@ -2624,9 +2624,7 @@
   (set-who! fxbit-count
     (lambda (n)
       (unless (fixnum? n) ($oops who "~s is not a fixnum" n))
-      (if (fx< n 0)
-          (fxnot ($fxbit-count (fxnot n)))
-          ($fxbit-count n))))
+      ($fxbit-count n)))
   (set-who! bitwise-bit-count
     (lambda (n)
       (cond
diff --git a/src/ChezScheme/s/7.ss b/src/ChezScheme/s/7.ss
index 4fe5e1ed41..219280db65 100644
--- a/src/ChezScheme/s/7.ss
+++ b/src/ChezScheme/s/7.ss
@@ -86,6 +86,13 @@
       [(g) (ba (filter-generation g) -1)]
       [(g s) (ba (if g (filter-generation g) -1) (if s (filter-space s) -1))])))
 
+(define-who bytes-finalized
+  (let ([bf (foreign-procedure "(cs)bytes_finalized"
+              ()
+              scheme-object)])
+    (lambda ()
+      (bf))))
+
 (define $spaces (lambda () (map car (constant real-space-alist))))
 
 (define current-memory-bytes (foreign-procedure "(cs)curmembytes" () uptr))
diff --git a/src/ChezScheme/s/Mf-tarm32le b/src/ChezScheme/s/Mf-tarm32le
new file mode 100644
index 0000000000..655c04a279
--- /dev/null
+++ b/src/ChezScheme/s/Mf-tarm32le
@@ -0,0 +1,19 @@
+# Mf-tarm32le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = tarm32le
+archincludes = arm32.ss
+
+include Mf-base
diff --git a/src/ChezScheme/s/Mf-tarm64le b/src/ChezScheme/s/Mf-tarm64le
new file mode 100644
index 0000000000..420ba56c8e
--- /dev/null
+++ b/src/ChezScheme/s/Mf-tarm64le
@@ -0,0 +1,19 @@
+# Mf-tarm64le
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = tarm64le
+archincludes = arm64.ss
+
+include Mf-base
diff --git a/src/ChezScheme/s/a6fb.def b/src/ChezScheme/s/a6fb.def
index 6f62f5e5e9..2ac6740a12 100644
--- a/src/ChezScheme/s/a6fb.def
+++ b/src/ChezScheme/s/a6fb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/a6le.def b/src/ChezScheme/s/a6le.def
index d1d38dce01..dec9dc8148 100644
--- a/src/ChezScheme/s/a6le.def
+++ b/src/ChezScheme/s/a6le.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/a6nb.def b/src/ChezScheme/s/a6nb.def
index a0d51758d3..6b16231122 100644
--- a/src/ChezScheme/s/a6nb.def
+++ b/src/ChezScheme/s/a6nb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/a6nt.def b/src/ChezScheme/s/a6nt.def
index 858ec529a9..4d6044e2ad 100644
--- a/src/ChezScheme/s/a6nt.def
+++ b/src/ChezScheme/s/a6nt.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long long int")
 (define-constant typedef-uptr "unsigned long long int")
diff --git a/src/ChezScheme/s/a6ob.def b/src/ChezScheme/s/a6ob.def
index a1bac80483..d845fd00fe 100644
--- a/src/ChezScheme/s/a6ob.def
+++ b/src/ChezScheme/s/a6ob.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/a6osx.def b/src/ChezScheme/s/a6osx.def
index dbf65de27d..b5c4d8ae48 100644
--- a/src/ChezScheme/s/a6osx.def
+++ b/src/ChezScheme/s/a6osx.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/a6s2.def b/src/ChezScheme/s/a6s2.def
index 85342c1769..fc53782722 100644
--- a/src/ChezScheme/s/a6s2.def
+++ b/src/ChezScheme/s/a6s2.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/arm32.ss b/src/ChezScheme/s/arm32.ss
index d4600323e1..53321e3d36 100644
--- a/src/ChezScheme/s/arm32.ss
+++ b/src/ChezScheme/s/arm32.ss
@@ -60,51 +60,51 @@
 
 (define-registers
   (reserved
-    [%tc  %r9                   #t  9]
-    [%sfp %r10                  #t 10]
-    [%ap  %r5                   #t  5]
+    [%tc  %r9                   #t  9 uptr]
+    [%sfp %r10                  #t 10 uptr]
+    [%ap  %r5                   #t  5 uptr]
     #;[%esp]
     #;[%eap]
-    [%trap %r8                  #t  8])
+    [%trap %r8                  #t  8 uptr])
   (allocable
-    [%ac0 %r4                   #t  4]
-    [%xp  %r6                   #t  6]
-    [%ts  %ip                   #f 12]
-    [%td  %r11                  #t 11]
+    [%ac0 %r4                   #t  4 uptr]
+    [%xp  %r6                   #t  6 uptr]
+    [%ts  %ip                   #f 12 uptr]
+    [%td  %r11                  #t 11 uptr]
     #;[%ret]
-    [%cp  %r7                   #t  7]
+    [%cp  %r7                   #t  7 uptr]
     #;[%ac1]
     #;[%yp]
-    [     %r0  %Carg1 %Cretval  #f  0]
-    [     %r1  %Carg2           #f  1]
-    [     %r2  %Carg3           #f  2]
-    [     %r3  %Carg4           #f  3]
-    [     %lr                   #f 14] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room
+    [     %r0  %Carg1 %Cretval  #f  0 uptr]
+    [     %r1  %Carg2           #f  1 uptr]
+    [     %r2  %Carg3 %reify1   #f  2 uptr]
+    [     %r3  %Carg4 %reify2   #f  3 uptr]
+    [     %lr                   #f 14 uptr] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room
+    [%fp1           %d8  %s16   #t 16 fp]   ; allocable fp regs must not overlap with any half registers
+    [%fp2           %d9  %s18   #t 18 fp]
   )
   (machine-dependent
-    [%sp                        #t 13]
-    [%pc                        #f 15]
-    [%Cfparg1 %Cfpretval %d0  %s0   #f  0] ; < 32: low bit goes in D, N, or M bit, high bits go in Vd, Vn, Vm
-    [%Cfparg1b                %s1   #f  1]
-    [%Cfparg2            %d1  %s2   #f  2]
-    [%Cfparg2b                %s3   #f  3]
-    [%Cfparg3            %d2  %s4   #f  4]
-    [%Cfparg3b                %s5   #f  5]
-    [%Cfparg4            %d3  %s6   #f  6]
-    [%Cfparg4b                %s7   #f  7]
-    [%Cfparg5            %d4  %s8   #f  8]
-    [%Cfparg5b                %s9   #f  9]
-    [%Cfparg6            %d5  %s10  #f 10]
-    [%Cfparg6b                %s11  #f 11]
-    [%Cfparg7            %d6  %s12  #f 12]
-    [%Cfparg7b                %s13  #f 13]
-    [%Cfparg8            %d7  %s14  #f 14]
-    [%Cfparg8b                %s15  #f 15]
-    [%flreg1             %d8  %s16  #f 16]
-    [%flreg2             %d9  %s18  #f 18] 
-    ; etc.
-    #;[                  %d16       #f 32] ; >= 32: high bit goes in D, N, or M bit, low bits go in Vd, Vn, Vm
-    #;[                  %d17       #f 33]
+    [%sp                        #t 13 uptr]
+    [%pc                        #f 15 uptr]
+    [%Cfparg1 %Cfpretval %d0  %s0   #f  0 fp] ; < 32: low bit goes in D, N, or M bit, high bits go in Vd, Vn, Vm
+    [%Cfparg1b                %s1   #f  1 fp]
+    [%Cfparg2            %d1  %s2   #f  2 fp]
+    [%Cfparg2b                %s3   #f  3 fp]
+    [%Cfparg3            %d2  %s4   #f  4 fp]
+    [%Cfparg3b                %s5   #f  5 fp]
+    [%Cfparg4            %d3  %s6   #f  6 fp]
+    [%Cfparg4b                %s7   #f  7 fp]
+    [%Cfparg5            %d4  %s8   #f  8 fp]
+    [%Cfparg5b                %s9   #f  9 fp]
+    [%Cfparg6            %d5  %s10  #f 10 fp]
+    [%Cfparg6b                %s11  #f 11 fp]
+    [%Cfparg7            %d6  %s12  #f 12 fp]
+    [%Cfparg7b                %s13  #f 13 fp]
+    [%Cfparg8            %d7  %s14  #f 14 fp]
+    [%Cfparg8b                %s15  #f 15 fp]
+    ;; etc., but other FP registers are preserved
+    #;[                  %d16       #t 32 fp] ; >= 32: high bit goes in D, N, or M bit, low bits go in Vd, Vn, Vm
+    #;[                  %d17       #t 33 fp]
     ; etc.
     ))
 
@@ -130,6 +130,18 @@
     (lambda (x)
       (or (lmem? x) (literal@? x))))
 
+  (define fpmem?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
+        [else #f])))
+
+  (define-syntax mem-of-type?
+    (lambda (stx)
+      (syntax-case stx (mem fpmem)
+        [(_ mem e) #'(lmem? e)]
+        [(_ fpmem e) #'(fpmem? e)])))
+
   (define imm-funky12?
     (lambda (x)
       (nanopass-case (L15c Triv) x
@@ -206,42 +218,40 @@
   (define mref->mref
     (lambda (a k)
       (define return
-        (lambda (x0 x1 imm)
+        (lambda (x0 x1 imm type)
           ; arm load & store instructions support index or offset but not both
           (safe-assert (or (eq? x1 %zero) (eqv? imm 0)))
-          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))
+          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))
       (nanopass-case (L15c Triv) a
-        [(mref ,lvalue0 ,lvalue1 ,imm)
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type)
          (lvalue->ur lvalue0
            (lambda (x0)
              (lvalue->ur lvalue1
                (lambda (x1)
                  (cond
                    [(and (eq? x1 %zero) (or (unsigned12? imm) (unsigned12? (- imm))))
-                    (return x0 %zero imm)]
-                   [(funky12 imm) =>
+                    (return x0 %zero imm type)]
+                   [(funky12 imm)
                     ; NB: dubious value?  check to see if it's exercised
-                    (lambda (imm)
-                      (let ([u (make-tmp 'u)])
-                        (seq
-                          (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm)))
-                          (return u x1 0))))]
-                   [(funky12 (- imm)) =>
+                    (let ([u (make-tmp 'u)])
+                      (seq
+                        (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm)))
+                        (return u x1 0 type)))]
+                   [(funky12 (- imm))
                     ; NB: dubious value?  check to see if it's exercised
-                    (lambda (imm)
-                      (let ([u (make-tmp 'u)])
-                        (seq
-                          (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x0 (immediate ,imm)))
-                          (return u x1 0))))]
+                    (let ([u (make-tmp 'u)])
+                      (seq
+                        (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x0 (immediate ,(- imm))))
+                        (return u x1 0 type)))]
                    [else
                     (let ([u (make-tmp 'u)])
                       (seq
                         (build-set! ,u (immediate ,imm))
                         (if (eq? x1 %zero)
-                            (return x0 u 0)
+                            (return x0 u 0 type)
                             (seq
                               (build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1))
-                              (return x0 u 0)))))])))))])))
+                              (return x0 u 0 type)))))])))))])))
 
   (define mem->mem
     (lambda (a k)
@@ -250,14 +260,50 @@
          (let ([u (make-tmp 'u)])
            (seq
              (build-set! ,u ,(literal@->literal a))
-             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0)))))]
+             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
         [else (mref->mref a k)])))
 
+  (define fpmem->fpmem ; allows mem argument, too
+    (lambda (a k)
+      (define return
+        (lambda (x0 x1 imm)
+          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm fp)))))
+      (nanopass-case (L15c Triv) a
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type)
+         (lvalue->ur lvalue0
+           (lambda (x0)
+             (lvalue->ur lvalue1
+               (lambda (x1)
+                 (cond
+                   [(not (and (<= 0 imm #x3FF)
+                              (fx= 0 (fxand imm #b11))))
+                    ;; offset not aligned or out of range
+                    (let ([u (make-tmp 'umov)])
+                      (seq
+                       (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm)))
+                       (if (eq? x1 %zero)
+                           (return u %zero 0)
+                           (seq
+                            (build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1))
+                            (return u %zero 0)))))]
+                   [(not (eq? x1 %zero))
+                    (let ([u (make-tmp 'umov)])
+                      (seq
+                       (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 ,x1))
+                       (return u %zero imm)))]
+                   [else
+                    (return x0 %zero imm)])))))])))
+
+  (define mem->fpmem
+    (lambda (a k)
+      (fpmem->fpmem a k)))
+
   (define-syntax coercible?
     (syntax-rules ()
       [(_ ?a ?aty*)
        (let ([a ?a] [aty* ?aty*])
-         (or (memq 'ur aty*)
+         (or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
+             (and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
              (and (memq 'funky12 aty*) (imm-funky12? a))
              (and (memq 'negate-funky12 aty*) (imm-negate-funky12? a))
              (and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a))
@@ -266,7 +312,8 @@
              (and (memq 'unsigned12 aty*) (imm-unsigned12? a))
              (and (memq 'imm-constant aty*) (imm-constant? a))
              (and (memq 'uword8 aty*) (imm-uword8? a))
-             (and (memq 'mem aty*) (mem? a))))]))
+             (and (memq 'mem aty*) (mem? a))
+             (and (memq 'fpmem aty*) (fpmem? a))))]))
 
   (define-syntax coerce-opnd ; passes k something compatible with aty*
     (syntax-rules ()
@@ -274,6 +321,7 @@
        (let ([a ?a] [aty* ?aty*] [k ?k])
          (cond
            [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
+           [(and (memq 'fpmem aty*) (fpmem? a)) (fpmem->fpmem a k)]
            [(and (memq 'funky12 aty*) (imm-funky12? a)) (k (imm->imm a))]
            [(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a)) (k (imm->negate-imm a))]
            [(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a)) (k (imm->lognot-imm a))]
@@ -298,6 +346,18 @@
                        (build-set! ,u ,a)
                        (k u)))))]
               [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
+           [(memq 'fpur aty*)
+            (cond
+              [(fpur? a) (k a)]
+              [(fpmem? a)
+               (fpmem->fpmem a
+                 (lambda (a)
+                   (let ([u (make-tmp 'u 'fp)])
+                     (seq
+                       (build-set! ,u ,a)
+                       (k u)))))]
+              [else
+               (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
            [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
 
   (define set-ur=mref
@@ -334,7 +394,7 @@
     (lambda (x)
       (define make-value-clause
         (lambda (fmt)
-          (syntax-case fmt (mem ur)
+          (syntax-case fmt (mem fpmem ur fpur)
             [(op (c mem) (a ur))
              #`(lambda (c a)
                  (if (lmem? c)
@@ -344,6 +404,20 @@
                            (lambda (c)
                              (rhs c a)))))
                      (next c a)))]
+            [(op (c fpmem) (a aty ...) ...)
+             #`(lambda (c a ...)
+                 (if (and (fpmem? c) (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (cond
+                           [(null? a*)
+                            #'(fpmem->fpmem c
+                               (lambda (c)
+                                 (rhs c a ...)))]
+                           [else
+                            #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                (lambda (#,(car a*))
+                                  #,(f (cdr a*) (cdr aty**))))]))
+                     (next c a ...)))]
             [(op (c ur) (a aty ...) ...)
              #`(lambda (c a ...)
                  (if (and (coercible? a '(aty ...)) ...)
@@ -359,6 +433,22 @@
                                            (build-set! ,c ,u))))))
                              #`(coerce-opnd #,(car a*) '#,(car aty**)
                                  (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
+                     (next c a ...)))]
+            [(op (c fpur) (a aty ...) ...)
+             #`(lambda (c a ...)
+                 (if (and (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (if (null? a*)
+                             #'(if (fpur? c)
+                                   (rhs c a ...)
+                                   (let ([u (make-tmp 'u 'fp)])
+                                     (seq
+                                       (rhs u a ...)
+                                       (fpmem->fpmem c
+                                         (lambda (c)
+                                           (build-set! ,c ,u))))))
+                             #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
                      (next c a ...)))])))
 
       (define-who make-pred-clause
@@ -532,7 +622,7 @@
   (define-instruction value (move)
     [(op (z mem) (x ur))
      `(set! ,(make-live-info) ,z ,x)]
-    [(op (z ur) (x ur mem imm))
+    [(op (z ur) (x ur mem imm-constant))
      `(set! ,(make-live-info) ,z ,x)])
 
   (define-instruction value lea1
@@ -633,77 +723,88 @@
                      `(asm ,null-info ,(asm-store type) ,x ,y ,w ,u)))
                  `(asm ,null-info ,(asm-store type) ,x ,y ,w ,z)))))]))
 
+  (define-instruction value (load-single->double)
+    [(op (x fpur) (y fpmem))
+     (let ([u (make-tmp 'u 'fp)])
+       (seq
+        `(set! ,(make-live-info) ,u (asm ,null-info ,asm-fpmove-single ,y))
+        `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,u))))])
+
+  (define-instruction effect (store-double->single)
+    [(op (x fpmem) (y fpur))
+     (let ([u (make-tmp 'u 'fp)])
+       (seq
+        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
+        `(asm ,info ,asm-fpmove-single ,x ,u)))])
+
+  (define-instruction effect (store-single)
+    [(op (x fpmem) (y fpur))
+     `(asm ,info ,asm-fpmove-single ,x ,y)])
+
+  (define-instruction value (load-single)
+    [(op (x fpur) (y fpmem fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove-single ,y))])
+
+  (define-instruction value (single->double double->single)
+    [(op (x fpur) (y fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))])
+
   (let ()
-    (define pick-asm-op
-      (lambda (op info)
-        (let ([flreg (info-loadfl-flreg info)])
-          (case op
-            [(load-single->double load-double->single) (asm-fl-load/cvt op flreg)]
-            [(store-single->double) (asm-fl-store/cvt op flreg)]
-            [else (asm-fl-load/store op flreg)]))))
-    (define-instruction effect (load-single->double load-double->single store-single->double
-                                 store-single store-double
-                                 load-single load-double)
-      [(op (x ur) (y ur) (z uword8))
-       (if (eq? y %zero)
-           `(asm ,info ,(pick-asm-op op info) ,x ,z)
-           (let ([u (make-tmp 'u)])
-             (seq
-               `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,y))
-               `(asm ,info ,(pick-asm-op op info) ,u ,z))))]
-      [(op (x ur) (y ur) (z ur))
-       (let ([u (make-tmp 'u)])
+    (define (fpmem->mem mem dir)
+      (with-output-language (L15d Triv)
+        (nanopass-case (L15d Triv) mem
+          [(mref ,x1 ,x2 ,imm ,type)
+           (safe-assert (eq? type 'fp))
+           (let ([delta (constant-case native-endianness
+                          [(little) (if (eq? dir 'lo) 0 4)]
+                          [(big) (if (eq? dir 'hi) 0 4)])])
+             `(mref ,x1 ,x2 ,(fx+ imm delta) uptr))]
+          [else (sorry! 'fpmem->mem "unexpected reference ~s" mem)])))
+
+    (define-instruction value (fpt)
+      [(op (x fpur) (y ur))
+       (let ([u (make-tmp 'u 'fp)])
          (seq
-           `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,z))
-           (if (eq? y %zero)
-               `(asm ,info ,(pick-asm-op op info) ,u (immediate 0))
-               (seq
-                 `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,u ,y))
-                 `(asm ,info ,(pick-asm-op op info) ,u (immediate 0))))))]))
+          `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
+          `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y, u))))])
 
-  (let ()
-    ; vldr, vstr allow only word offsets, and we require byte offset due to the type tag
-    (module (with-flonum-data-pointers)
-      (define $flonum-data-pointer
-        (lambda (x p)
-          (with-output-language (L15d Effect)
-            (let ([u (make-tmp 'u)])
-              (seq
-                `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,(constant flonum-data-disp))))
-                (p u))))))
-      (define-syntax with-flonum-data-pointers
-        (syntax-rules ()
-          [(_ () e1 e2 ...) (begin e1 e2 ...)]
-          [(_ (x1 x2 ...) e1 e2 ...)
-           ($flonum-data-pointer x1
-             (lambda (x1)
-               (with-flonum-data-pointers (x2 ...) e1 e2 ...)))])))
-
-    (define-instruction effect (flt)
-      [(op (x ur) (y ur))
-       (with-flonum-data-pointers (y)
-         `(asm ,info ,asm-flt ,x ,y))])
-
-    (define-instruction effect (fl+ fl- fl/ fl*)
-      [(op (x ur) (y ur) (z ur))
-       (with-flonum-data-pointers (x y z)
-         `(asm ,info ,(asm-flop-2 op) ,x ,y ,z))])
-
-    (define-instruction effect (flsqrt)
-      [(op (x ur) (y ur))
-       (with-flonum-data-pointers (x y)
-         `(asm ,info ,asm-flsqrt ,x ,y))])
-
-    (define-instruction value (trunc)
-      [(op (z ur) (x ur))
-       (with-flonum-data-pointers (x)
-         `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x)))])
-
-    (define-instruction pred (fl= fl< fl<=)
-      [(op (x ur) (y ur))
-       (with-flonum-data-pointers (x y)
-         (let ([info (make-info-condition-code op #f #f)])
-           (values '() `(asm ,info ,(asm-fl-relop info) ,x ,y))))]))
+    (define-instruction value (fpmove)
+      [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
+      [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)])
+
+    (define-instruction value (fpcastto/hi)
+      [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'hi))]
+      [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'hi) ,y))])
+    
+    (define-instruction value (fpcastto/lo)
+      [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'lo))]
+      [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'lo) ,y))])
+    
+    (define-instruction value (fpcastfrom)
+      [(op (x fpmem) (hi ur) (lo ur)) (seq
+                                       `(set! ,(make-live-info) ,(fpmem->mem x 'lo) ,lo)
+                                       `(set! ,(make-live-info) ,(fpmem->mem x 'hi) ,hi))]
+      [(op (x fpur) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,lo ,hi))]))
+
+  (define-instruction value (fp+ fp- fp/ fp*)
+    [(op (x fpur) (y fpur) (z fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
+
+  (define-instruction value (fpsqrt)
+    [(op (x fpur) (y fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
+
+  (define-instruction value (fptrunc)
+    [(op (z ur) (x fpur))
+     (let ([u (make-tmp 'u 'fp)])
+       (seq
+        `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
+        `(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x ,u))))])
+
+  (define-instruction pred (fp= fp< fp<=)
+    [(op (x fpur) (y fpur))
+     (let ([info (make-info-condition-code op #f #f)])
+       (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
 
   (define-instruction effect (inc-cc-counter)
     [(op (x ur) (w ur funky12) (z funky12 ur))
@@ -741,6 +842,32 @@
          `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
          `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc ,u ,ulr))))])
 
+  (define-instruction value activate-thread
+    [(op (z ur))
+     (safe-assert (eq? z %Cretval))
+     (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread ,u ,ulr))))])
+
+  (define-instruction effect deactivate-thread
+    [(op)
+     (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(asm ,info ,asm-deactivate-thread ,u ,ulr)))])
+
+  (define-instruction effect unactivate-thread
+    [(op (x ur))
+     (safe-assert (eq? x %Carg1))
+     (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(asm ,info ,asm-unactivate-thread ,x ,u ,ulr)))])
+
   (define-instruction value (asmlibcall)
     [(op (z ur)) 
      (let ([u (make-tmp 'u)])
@@ -828,14 +955,16 @@
     ; NB: compiler ipmlements init-lock! and unlock! as 32-bit store of zero 
     (define-instruction pred (lock!)
       [(op (x ur) (y ur) (w funky12))
-       (let ([u (make-tmp 'u)])
+       (let ([u (make-tmp 'u)]
+             [u2 (make-tmp 'u2)])
          (values
            (lea->reg x y w
              (lambda (r)
                (with-output-language (L15d Effect)
                  (seq
                    `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
-                   `(asm ,null-info ,asm-lock ,r ,u)))))
+                   `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
+                   `(asm ,null-info ,asm-lock ,r ,u ,u2)))))
            `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))])
     (define-instruction effect (locked-incr! locked-decr!)
       [(op (x ur) (y ur) (w funky12))
@@ -856,6 +985,18 @@
                `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
 	       `(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))]))
 
+  (define-instruction effect (store-store-fence)
+    [(op)
+     `(asm ,info ,(asm-fence 'store-store))])
+
+  (define-instruction effect (acquire-fence)
+    [(op)
+     `(asm ,info ,(asm-fence 'acquire))])
+  
+  (define-instruction effect (release-fence)
+    [(op)
+     `(asm ,info ,(asm-fence 'release))])
+
   (define-instruction effect (pause)
     ; NB: user sqrt or something like that?
     [(op) '()])
@@ -876,6 +1017,9 @@
   (define-instruction effect (vpush-multiple)
     [(op) `(asm ,info ,(asm-vpush-multiple (info-vpush-reg info) (info-vpush-n info)))])
 
+  (define-instruction effect (vpop-multiple)
+    [(op) `(asm ,info ,(asm-vpop-multiple (info-vpush-reg info) (info-vpush-n info)))])
+
   (define-instruction effect save-flrv
     [(op) `(asm ,info ,asm-save-flrv)])
 
@@ -891,15 +1035,14 @@
                      asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump
                      asm-mul asm-smull asm-cmp/shift asm-add asm-sub asm-rsb asm-logand asm-logor asm-logxor asm-bic
                      asm-pop-multiple asm-shiftop asm-logand asm-lognot
-                     asm-logtest asm-fl-relop asm-relop asm-push-multiple asm-vpush-multiple
+                     asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-vpush-multiple asm-vpop-multiple
                      asm-indirect-jump asm-literal-jump
                      asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
                      asm-rp-header asm-rp-compact-header
                      asm-indirect-call asm-condition-code
-                     asm-fl-load/store 
-                     asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc 
-                     asm-lock asm-lock+/- asm-cas
-                     asm-flop-2 asm-flsqrt asm-c-simple-call
+                     asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc 
+                     asm-lock asm-lock+/- asm-cas asm-fence
+                     asm-fpop-2 asm-fpsqrt asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                      asm-enter asm-foreign-call asm-foreign-callable
                      asm-read-counter
@@ -908,6 +1051,7 @@
                      shift-count? unsigned8? unsigned12?
                      ; threaded version specific
                      asm-get-tc
+                     asm-activate-thread asm-deactivate-thread asm-unactivate-thread
                      ; machine dependent exports
                      asm-kill
                      info-vpush-reg info-vpush-n)
@@ -1050,6 +1194,10 @@
   (define-op ldrex ldrex-op      #b00011001)
   (define-op strex strex-op      #b00011000)
 
+  (define-op dmbst    dmb-op #b1110)
+  (define-op dmbish   dmb-op #b1011)
+  (define-op dmbishst dmb-op #b1010)
+
   (define-op bnei  branch-imm-op       (ax-cond 'ne))
   (define-op brai  branch-imm-op       (ax-cond 'al))
 
@@ -1072,15 +1220,18 @@
 
   (define-op popm  pm-op #b10001011) 
   (define-op pushm pm-op #b10010010)
-  (define-op vpushm vpushm-op)
+  (define-op vpushm vpm-op #b11010 #b10)
+  (define-op vpopm  vpm-op #b11001 #b11)
 
   (define-op vldr.sgl vldr/vstr-op #b1010 #b01)
   (define-op vldr.dbl vldr/vstr-op #b1011 #b01)
   (define-op vstr.sgl vldr/vstr-op #b1010 #b00)
   (define-op vstr.dbl vldr/vstr-op #b1011 #b00)
 
-  (define-op vmov.gpr->s32 vmov-op #b0)
-  (define-op vmov.s32->gpr vmov-op #b1)
+  (define-op vmov.gpr->s32 vmov.gpr-op #b0)
+  (define-op vmov.s32->gpr vmov.gpr-op #b1)
+  (define-op vmov.gprgpr->s64 vmov.gpr64-op #b0)
+  (define-op vmov.fpr vmov.fpr-op)
 
   (define-op vcvt.sgl->dbl vcvt-op #b01 #b110111)
   (define-op vcvt.dbl->sgl vcvt-op #b11 #b110111)
@@ -1101,6 +1252,7 @@
   (define-op mrc mrc/mcr-op #b1)
 
   (define-op vadd vadd-op #b11 #b0 #b11100)
+
   (define-op vsub vadd-op #b11 #b1 #b11100)
   (define-op vmul vadd-op #b10 #b0 #b11100)
   (define-op vdiv vadd-op #b00 #b0 #b11101)
@@ -1288,6 +1440,12 @@
         [4  #b1001]
         [0  (ax-ea-reg-code opnd0-ea)])))
 
+  (define dmb-op
+    (lambda (op opcode code*)
+      (emit-code (op code*)
+	[4 #b1111010101111111111100000101]
+	[0 opcode])))
+
   (define branch-imm-op
     (lambda (op cond-bits disp code*)
       (emit-code (op disp code*)
@@ -1347,6 +1505,8 @@
 
   (define vldr/vstr-op
     (lambda (op opc1 opc2 flreg reg offset code*)
+      (safe-assert (and (<= 0 offset #x3FF)
+                        (fx= 0 (fxand offset #b11))))
       (let-values ([(d vd) (ax-flreg->bits flreg)])
         (emit-code (op flreg reg offset code*)
           [28 (ax-cond 'al)]
@@ -1360,10 +1520,10 @@
           [8  opc1]
           [0  (fxsrl offset 2)]))))
 
-  (define vmov-op
-    (lambda (op dir flreg gpreg code*)
-      (let-values ([(n vn) (ax-flreg->bits flreg)])
-        (emit-code (op flreg gpreg code*)
+  (define vmov.gpr-op
+    (lambda (op dir flreg flreg-delta gpreg code*)
+      (let-values ([(n vn) (ax-flreg->bits flreg flreg-delta)])
+        (emit-code (op flreg gpreg flreg-delta code*)
           [28 (ax-cond 'al)]
           [21 #b1110000]
           [20 dir]
@@ -1373,6 +1533,44 @@
           [7  n]
           [0  #b0010000]))))
 
+  (define vmov.gpr64-op
+    (lambda (op dir flreg gpreglo gpreghi code*)
+      (let-values ([(n vn) (ax-flreg->bits flreg)])
+        (emit-code (op flreg gpreglo gpreghi code*)
+          [28 (ax-cond 'al)]
+          [23 #b11000]
+          [22 1]
+          [21 0]
+          [20 dir] ; 0 to fp, 1 from fp
+          [16 (ax-ea-reg-code gpreghi)]
+          [12 (ax-ea-reg-code gpreglo)]
+          [10 #b10]
+          [8 #b11]
+          [6 #b00]
+          [5 n]
+          [4 1]
+          [0 vn]))))
+
+  (define vmov.fpr-op
+    (lambda (op destreg srcreg code*)
+      (let-values ([(d vd) (ax-flreg->bits destreg)]
+                   [(m vm) (ax-flreg->bits srcreg)])
+        (emit-code (op destreg srcreg code*)
+          [28 (ax-cond 'al)]
+          [23 #b11101]
+          [22 0] ; D
+          [20 #b11]
+          [19 d]
+          [16 #b000]
+          [12 vd]
+          [10 #b10]
+          [8 #b11]
+          [7 0]
+          [6 1]
+          [5 m]
+          [4 0]
+          [00 vm]))))
+
   (define vcvt-op
     (lambda (op szop opc2 dest src code*)
       (let-values ([(d vd) (ax-flreg->bits dest)]
@@ -1414,14 +1612,15 @@
         [12 #b1111]
         [0  #b101000010000])))
 
-  (define vpushm-op
-    (lambda (op flreg n code*)
+  (define vpm-op
+    (lambda (op opcode opcode2 flreg n code*)
       (let-values ([(d vd) (ax-flreg->bits flreg)])
         (emit-code (op flreg n code*)
           [28 (ax-cond 'al)]
-          [23 #b11010]
+          [23 opcode]
           [22 d]
-          [16 #b101101]
+          [20 opcode2]
+          [16 #b1101]
           [12 vd]
           [8  #b1011]
           [0  (fxsll n 1)]))))
@@ -1588,11 +1787,13 @@
         [else ($oops who "unsupported op ~s" op)])))
 
   (define ax-flreg->bits
-    (lambda (flreg)
-      (let ([n (reg-mdinfo flreg)])
+    (case-lambda
+     [(flreg) (ax-flreg->bits flreg 0)]
+     [(flreg flreg-delta)
+      (let ([n (fx+ (reg-mdinfo flreg) flreg-delta)])
         (if (fx< n 32)
             (values (fxlogand n 1) (fxsrl n 1))
-            (values (fxsrl n 4) (fxlogand n #b1111))))))
+            (values (fxsrl n 4) (fxlogand n #b1111))))]))
 
   (define-syntax emit-code
     (lambda (x)
@@ -1615,14 +1816,6 @@
          (fold-right cons #'(aop-cons* `(asm ,op ,opnd ...) ?code*)
            #'((build long (byte-fields chunk ...))))])))
 
-  (define-who ax-size-code
-    (lambda (x)
-      (case x
-        [(byte) 0]
-        [(word) 1]
-        [(long) 1]
-        [else (sorry! who "invalid size ~s" x)])))
-
   (define-syntax build
     (syntax-rules ()
       [(_ x e)
@@ -1797,40 +1990,15 @@
         (Trivit (src0 src1)
           (emit cmp/shift count type src0 src1 code*)))))
 
-  (define-who asm-fl-load/cvt
-    (lambda (op flreg)
-      (lambda (code* base offset)
-        (Trivit (base offset)
-          (case op
-            [(load-single->double)
-             (emit vldr.sgl %flreg2 base (ax-imm-data offset)
-               (emit vcvt.sgl->dbl flreg %flreg2 code*))]
-            [(load-double->single)
-             (emit vldr.dbl %flreg2 base (ax-imm-data offset)
-               (emit vcvt.dbl->sgl flreg %flreg2 code*))]
-            [else (sorry! who "unrecognized op ~s" op)])))))
-
-  (define-who asm-fl-store/cvt
-    (lambda (op flreg)
-      (lambda (code* base offset)
-        (Trivit (base offset)
-          (case op
-            [(store-single->double)
-             (emit vcvt.sgl->dbl %flreg2 flreg
-               (emit vstr.dbl %flreg2 base (ax-imm-data offset) code*))]
-            [else (sorry! who "unrecognized op ~s" op)])))))
-
-  (define-who asm-fl-load/store
-    (lambda (op flreg)
-      (lambda (code* base offset)
-        (Trivit (base offset)
-          (let ([offset (ax-imm-data offset)])
-            (case op
-              [(load-single) (emit vldr.sgl flreg base offset code*)]
-              [(load-double) (emit vldr.dbl flreg base offset code*)]
-              [(store-single) (emit vstr.sgl flreg base offset code*)]
-              [(store-double) (emit vstr.dbl flreg base offset code*)]
-              [else (sorry! who "unrecognized op ~s" op)]))))))
+  (define-who asm-fl-cvt
+    (lambda (op)
+      (lambda (code* dest-reg src-reg)
+        (case op
+          [(single->double)
+           (emit vcvt.sgl->dbl dest-reg src-reg code*)]
+          [(double->single)
+           (emit vcvt.dbl->sgl dest-reg src-reg code*)]
+          [else (sorry! who "unrecognized op ~s" op)]))))
 
   (define-who asm-load
     (lambda (type)
@@ -1884,40 +2052,80 @@
                       [else (sorry! who "unexpected mref type ~s" type)]))]
                 [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))
 
-  (define-who asm-flop-2
+  (define-who asm-fpop-2
     (lambda (op)
-      (lambda (code* src1 src2 dest)
-        (Trivit (src1 src2 dest)
-          (emit vldr.dbl %flreg1 src1 0
-            (emit vldr.dbl %flreg2 src2 0
-              (let ([code* (emit vstr.dbl %flreg1 dest 0 code*)])
-                (case op
-                  [(fl+) (emit vadd %flreg1 %flreg1 %flreg2 code*)]
-                  [(fl-) (emit vsub %flreg1 %flreg1 %flreg2 code*)]
-                  [(fl*) (emit vmul %flreg1 %flreg1 %flreg2 code*)]
-                  [(fl/) (emit vdiv %flreg1 %flreg1 %flreg2 code*)]
-                  [else (sorry! who "unrecognized op ~s" op)]))))))))
-
-  (define asm-flsqrt
-    (lambda (code* src dest)
-      (Trivit (src dest)
-        (emit vldr.dbl %flreg1 src 0
-          (emit vsqrt %flreg1 %flreg1
-            (emit vstr.dbl %flreg1 dest 0 code*))))))
-
-  (define asm-trunc
-    (lambda (code* dest flonumreg)
-      (Trivit (dest flonumreg)
-        (emit vldr.dbl %flreg1 flonumreg 0
-          (emit vcvt.dbl->s32 %flreg1 %flreg1
-            (emit vmov.s32->gpr %flreg1 dest code*))))))
-
-  (define asm-flt
-    (lambda (code* src flonumreg)
-      (Trivit (src flonumreg)
-        (emit vmov.gpr->s32 %flreg1 src
-          (emit vcvt.s32->dbl %flreg1 %flreg1
-            (emit vstr.dbl %flreg1 flonumreg 0 code*))))))
+      (lambda (code* dest src1 src2)
+        (case op
+          [(fp+) (emit vadd dest src1 src2 code*)]
+          [(fp-) (emit vsub dest src1 src2 code*)]
+          [(fp*) (emit vmul dest src1 src2 code*)]
+          [(fp/) (emit vdiv dest src1 src2 code*)]
+          [else (sorry! who "unrecognized op ~s" op)]))))
+
+  (define asm-fpsqrt
+    (lambda (code* dest src)
+      (emit vsqrt dest src code*)))
+
+  (define asm-fptrunc
+    (lambda (code* dest flonumreg tmpreg)
+      (Trivit (dest)
+        (emit vcvt.dbl->s32 tmpreg flonumreg
+            (emit vmov.s32->gpr tmpreg 0 dest code*)))))
+
+  (define asm-fpt
+    (lambda (code* dest src tmpreg)
+      (Trivit (src)
+        (emit vmov.gpr->s32 tmpreg 0 src
+          (emit vcvt.s32->dbl dest tmpreg code*))))) 
+
+  (define-who asm-fpmove
+    ;; fpmove pseudo instruction is used by set! case in
+    ;; select-instructions! and generate-code; at most one of src or
+    ;; dest can be an mref, and then the offset is double-aligned
+    (lambda (code* dest src)
+      (gen-fpmove who code* dest src #t)))
+
+  (define-who asm-fpmove-single
+    ;; fpmove pseudo instruction is used by set! case in
+    ;; select-instructions! and generate-code; at most one of src or
+    ;; dest can be an mref, and then the offset is double-aligned
+    (lambda (code* dest src)
+      (gen-fpmove who code* dest src #f)))
+
+  (define gen-fpmove
+    (lambda (who code* dest src double?)
+      (let ([dest-it dest]
+            [src-it src])
+        (Trivit (dest-it src-it)
+          (record-case dest-it
+            [(disp) (imm reg)
+             (safe-assert (fx= 0 (fxand imm #b11)))
+             (if double?
+                 (emit vstr.dbl src (cons 'reg reg) imm code*)
+                 (emit vstr.sgl src (cons 'reg reg) imm code*))]
+            [(index) (n ireg breg) (sorry! who "cannot handle indexed fp dest ref")]
+            [else
+             (record-case src-it
+               [(disp) (imm reg)
+                (safe-assert (fx= 0 (fxand imm #b11)))
+                (if double?
+                    (emit vldr.dbl dest (cons 'reg reg) imm code*)
+                    (emit vldr.sgl dest (cons 'reg reg) imm code*))]
+               [(index) (n ireg breg) (sorry! who "cannot handle indexed fp src ref")]
+               [else (emit vmov.fpr dest src code*)])])))))
+
+  (define asm-fpcastto
+    (lambda (part)
+      (lambda (code* dest src)
+        (Trivit (dest)
+          (if (eq? part 'lo)
+              (emit vmov.s32->gpr src 0 dest code*)
+              (emit vmov.s32->gpr src 1 dest code*))))))
+
+  (define asm-fpcastfrom
+    (lambda (code* dest lo-src hi-src)
+      (Trivit (lo-src hi-src)
+        (emit vmov.gprgpr->s64 dest lo-src hi-src code*))))
 
   (define-who asm-swap
     (lambda (type)
@@ -1931,19 +2139,21 @@
               [else (sorry! who "unexpected asm-swap type argument ~s" type)]))))))
 
   (define asm-lock
-    ;  tmp = ldrex src
-    ;  cmp tmp, 0
+    ;  tmp = 1 # in case load result is not 0
+    ;  tmp2 = ldrex src
+    ;  cmp tmp2, 0
     ;  bne L1 (+2)
-    ;  tmp = 1
-    ;  tmp = strex tmp, src
+    ;  tmp2 = 1
+    ;  tmp = strex tmp2, src
     ;L1:
-    (lambda (code* src tmp)
-      (Trivit (src tmp)
-        (emit ldrex tmp src
-          (emit cmpi tmp 0
-            (emit bnei 1
-              (emit movi1 tmp 1
-                (emit strex tmp tmp src code*))))))))
+    (lambda (code* src tmp tmp2)
+      (Trivit (src tmp tmp2)
+        (emit movi1 tmp 1
+          (emit ldrex tmp2 src
+            (emit cmpi tmp2 0
+              (emit bnei 1
+                (emit movi1 tmp2 1
+                  (emit strex tmp tmp2 src code*)))))))))
 
   (define-who asm-lock+/-
     ; L:
@@ -1982,16 +2192,22 @@
                 (emit cmpi tmp2 0
                    code*))))))))
 
-  (define asm-fl-relop
+  ;; Based in part on https://www.cl.cam.ac.uk/~pes20/cpp/cpp0xmappings.html
+  (define-who asm-fence
+    (lambda (kind)
+      (lambda (code*)
+        (case kind
+          [(store-store) (emit dmbishst code*)]
+          [(acquire) (emit dmbish code*)]
+          [(release) (emit dmbish code*)]
+          [else (sorry! who "unexpected kind ~s" kind)]))))
+
+  (define asm-fp-relop
     (lambda (info)
       (lambda (l1 l2 offset x y)
-        (Trivit (x y)
-          (values
-            (emit vldr.dbl %flreg1 x 0
-              (emit vldr.dbl %flreg2 y 0
-                (emit vcmp %flreg1 %flreg2
-                  (emit fpscr->apsr '()))))
-            (asm-conditional-jump info l1 l2 offset))))))
+        (values
+          (emit vcmp x y (emit fpscr->apsr '()))
+          (asm-conditional-jump info l1 l2 offset)))))
 
   (define-who asm-relop
     (lambda (info)
@@ -2027,6 +2243,11 @@
       (lambda (code*)
         (emit vpushm reg n code*))))
 
+  (define asm-vpop-multiple
+    (lambda (reg n)
+      (lambda (code*)
+        (emit vpopm reg n code*))))
+
   (define asm-save-flrv
     (lambda (code*)
       (let ([sp (cons 'reg %sp)])
@@ -2087,7 +2308,8 @@
 
   (define asm-direct-jump
     (lambda (l offset)
-      (asm-helper-jump '() (make-funcrel 'arm32-jump l offset))))
+      (let ([offset (adjust-return-point-offset offset l)])
+        (asm-helper-jump '() (make-funcrel 'arm32-jump l offset)))))
 
   (define asm-literal-jump
     (lambda (info)
@@ -2123,23 +2345,39 @@
       (lambda (code* dest jmp-tmp . ignore) ; dest is ignored, since it is always Cretval
         (asm-helper-call code* target #f jmp-tmp))))
 
+  (define asm-activate-thread
+    (let ([target `(arm32-call 0 (entry ,(lookup-c-entry activate-thread)))])
+      (lambda (code* dest jmp-tmp . ignore)
+        (asm-helper-call code* target #t jmp-tmp))))
+
+  (define asm-deactivate-thread
+    (let ([target `(arm32-call 0 (entry ,(lookup-c-entry deactivate-thread)))])
+      (lambda (code* jmp-tmp . ignore)
+        (asm-helper-call code* target #f jmp-tmp))))
+
+  (define asm-unactivate-thread
+    (let ([target `(arm32-call 0 (entry ,(lookup-c-entry unactivate-thread)))])
+      (lambda (code* arg-reg jmp-tmp . ignore)
+        (asm-helper-call code* target #f jmp-tmp))))
+
   (define-who asm-return-address
     (lambda (dest l incr-offset next-addr)
       (make-rachunk dest l incr-offset next-addr
         (or (cond
               [(local-label-offset l) =>
                (lambda (offset)
-                 (let ([disp (fx- next-addr (fx- offset incr-offset) 4)])
-                   (cond
-                     [(funky12 disp)
-                      (Trivit (dest)
-                        ; aka adr, encoding A1
-                        (emit addi #f dest `(reg . ,%pc) disp '()))]
-                     [(funky12 (- disp))
-                      (Trivit (dest)
-                        ; aka adr, encoding A2
-                        (emit subi #f dest `(reg . ,%pc) (- disp) '()))]
-                     [else #f])))]
+                 (let ([incr-offset (adjust-return-point-offset incr-offset l)])
+                   (let ([disp (fx- next-addr (fx- offset incr-offset) 4)])
+                     (cond
+                       [(funky12 disp)
+                        (Trivit (dest)
+                          ; aka adr, encoding A1
+                          (emit addi #f dest `(reg . ,%pc) disp '()))]
+                       [(funky12 (- disp))
+                        (Trivit (dest)
+                          ; aka adr, encoding A2
+                          (emit subi #f dest `(reg . ,%pc) (- disp) '()))]
+                      [else #f]))))]
               [else #f])
             (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))))))
 
@@ -2231,9 +2469,9 @@
               [(overflow) (i? bvc bvs)]
               [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if oveflow
               [(carry) (i? bcc bcs)]
-              [(fl<) (i? (r? ble bcs) (r? bgt bcc))]
-              [(fl<=) (i? (r? blt bhi) (r? bge bls))]
-              [(fl=) (i? bne beq)]))))))
+              [(fp<) (i? (r? ble bcs) (r? bgt bcc))]
+              [(fp<=) (i? (r? blt bhi) (r? bge bls))]
+              [(fp=) (i? bne beq)]))))))
 
   (define asm-data-label
     (lambda (code* l offset func code-size)
@@ -2378,23 +2616,50 @@
 		    (or (andmap double-member? members)
 			(andmap float-member? members)))))]
 	[else #f]))
+    (define num-int-regs 4) ; number of integer registers normally usd by the ABI
+    (define num-dbl-regs 8) ; number of `double` registers normally usd by the ABI
     (define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b
 				      %Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b)))
+    (define save-and-restore
+      (lambda (regs e)
+        (safe-assert (andmap reg? regs))
+	(with-output-language (L13 Effect)
+          (let ([save-and-restore-gp
+		 (lambda (regs e)
+                   (let* ([regs (filter (lambda (r) (not (eq? (reg-type r) 'fp))) regs)]
+                          [regs (if (fxodd? (length regs))
+                                    (cons %tc regs) ; keep doubleword aligned
+                                    regs)])
+                     (cond
+                      [(null? regs) e]
+                      [else
+                       (%seq
+			(inline ,(make-info-kill*-live* '() regs) ,%push-multiple)
+			,e
+			(inline ,(make-info-kill*-live* regs '()) ,%pop-multiple))])))]
+		[save-and-restore-fp
+		 (lambda (regs e)
+                   (let ([fp-regs (filter (lambda (r) (eq? (reg-type r) 'fp)) regs)])
+                     (cond
+                      [(null? fp-regs) e]
+                      [else
+                       (let ([info (make-info-vpush (car fp-regs) (length fp-regs))])
+                         (%seq
+			  (inline ,info ,%vpush-multiple)
+			  ,e
+			  (inline ,info ,%vpop-multiple)))])))])
+            (save-and-restore-gp regs (save-and-restore-fp regs e))))))
     (define-who asm-foreign-call
       (with-output-language (L13 Effect)
         (define int-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4)))
         (letrec ([load-double-stack
                    (lambda (offset)
-                     (lambda (x) ; requires var
-                       (%seq
-                         (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
-                         (inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
+                     (lambda (x) ; unboxed
+                      `(set! ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                  [load-single-stack
                    (lambda (offset)
-                     (lambda (x) ; requires var
-                       (%seq
-			 (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
-                         (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
+                     (lambda (x) ; unboxed
+                      (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                  [load-int-stack
                    (lambda (offset)
                      (lambda (rhs) ; requires rhs
@@ -2425,13 +2690,29 @@
 			(set! ,(%mref ,%sp ,offset) ,(%mref ,x ,from-offset))
 			(set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x ,(fx+ from-offset 4))))))]
                  [load-double-reg
-                   (lambda (fpreg fp-disp)
-                     (lambda (x) ; requires var
-                       `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp))))]
+                   (lambda (fpreg)
+                     (lambda (x) ; unboxed
+                       `(set! ,fpreg ,x)))]
                  [load-single-reg
+                   (lambda (fpreg single?)
+                     (lambda (x) ; unboxed
+                       (let ([%op (if single? %load-single %double->single)])
+                         `(set! ,fpreg (inline ,null-info ,%op ,x)))))]
+                 [load-double-int-reg
+                   (lambda (loreg hireg)
+                     (lambda (x) ; unboxed
+                       (%seq
+                        (set! ,loreg ,(%inline fpcastto/lo ,x))
+                        (set! ,hireg ,(%inline fpcastto/hi ,x)))))]
+                 [load-boxed-double-reg
+                   (lambda (fpreg fp-disp)
+                     (lambda (x) ; address (always a var) of a flonum
+                       `(set! ,fpreg ,(%mref ,x ,%zero ,fp-disp fp))))]
+                 [load-boxed-single-reg
                    (lambda (fpreg fp-disp single?)
-                     (lambda (x) ; requires var
-                       `(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))]
+                     (lambda (x) ; address (always a var) of a flonum
+                       (let ([%op (if single? %load-single %double->single)])
+                         `(set! ,fpreg (inline ,null-info ,%op ,(%mref ,x ,%zero ,fp-disp fp))))))]
                  [load-int-reg
                    (lambda (ireg)
                      (lambda (x)
@@ -2465,34 +2746,46 @@
                          (set! ,loreg ,(%mref ,x ,from-offset))
                          (set! ,hireg ,(%mref ,x ,(fx+ from-offset 4))))))]
                  [do-args
-                  (lambda (types)
+                  (lambda (types varargs?)
                     ; sgl* is always of even-length, i.e., has a sgl/dbl reg first
                     ; bsgl is set to "b" single (second half of double) if we have one to fill
-                    (let loop ([types types] [locs '()] [live* '()] [int* (int-regs)] [sgl* (sgl-regs)] [bsgl #f] [isp 0])
+                    (let loop ([types types] [locs '()] [live* '()] [int* (int-regs)] [sgl* (if varargs? '() (sgl-regs))] [bsgl #f] [isp 0])
                       (if (null? types)
                           (values isp locs live*)
                           (nanopass-case (Ltype Type) (car types)
                             [(fp-double-float)
-                             (if (null? sgl*)
-                                 (let ([isp (align 8 isp)])
-                                   (loop (cdr types)
+                             (cond
+                               [(and varargs?
+                                     ;; For varargs, treat a double like a 64-bit integer
+                                     (let ([int* (if (even? (length int*)) int* (cdr int*))])
+                                       (and (pair? int*)
+                                            int*)))
+                                => (lambda (int*)
+                                     (loop (cdr types)
+                                       (cons (load-double-int-reg (car int*) (cadr int*)) locs)
+                                       (cons* (car int*) (cadr int*) live*) (cddr int*) sgl* bsgl isp))]
+                               [(null? sgl*)
+                                (let ([isp (align 8 isp)])
+                                  (loop (cdr types)
                                      (cons (load-double-stack isp) locs)
-                                     live* int* '() #f (fx+ isp 8)))
-                                 (loop (cdr types)
-                                   (cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs)
-                                   live* int* (cddr sgl*) bsgl isp))]
+                                     live* int* '() #f (fx+ isp 8)))]
+                               [else
+                                (loop (cdr types)
+                                  (cons (load-double-reg (car sgl*)) locs)
+                                  (cons (car sgl*) live*) int* (cddr sgl*) bsgl isp)])]
                             [(fp-single-float)
+                             (safe-assert (not varargs?))
                              (if bsgl
                                  (loop (cdr types)
-                                   (cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs)
-                                   live* int* sgl* #f isp)
+                                   (cons (load-single-reg bsgl #f) locs)
+                                   (cons bsgl live*) int* sgl* #f isp)
                                  (if (null? sgl*)
                                      (loop (cdr types)
                                        (cons (load-single-stack isp) locs)
                                        live* int* '() #f (fx+ isp 4))
                                      (loop (cdr types)
-                                       (cons (load-single-reg (car sgl*) (constant flonum-data-disp) #f) locs)
-                                       live* int* (cddr sgl*) (cadr sgl*) isp)))]
+                                       (cons (load-single-reg (car sgl*) #f) locs)
+                                       (cons (car sgl*) live*) int* (cddr sgl*) (cadr sgl*) isp)))]
 			    [(fp-ftd& ,ftd)
 			     (let ([size ($ftd-size ftd)]
 				   [members ($ftd->members ftd)]
@@ -2504,20 +2797,21 @@
 				 [(8)
 				  (let* ([int* (if (even? (length int*)) int* (cdr int*))]
 					 [num-members (length members)]
-					 [doubles? (and (fx<= num-members 4)
+					 [doubles? (and (not varargs?)
+                                                        (fx<= num-members 4)
 							(andmap double-member? members))])
 				    ;; Sequence of up to 4 doubles that fits in registers?
 				    (cond
 				     [(and doubles?
 					   (fx>= (length sgl*) (fx* 2 num-members)))
 				      ;; Allocate each double to a register
-				      (let dbl-loop ([size size] [offset 0] [sgl* sgl*] [loc #f])
+				      (let dbl-loop ([size size] [offset 0] [live* live*] [sgl* sgl*] [loc #f])
 					(cond
 					 [(fx= size 0)
 					  (loop (cdr types) (cons loc locs) live* int* sgl* #f isp)]
 					 [else
-					  (dbl-loop (fx- size 8) (fx+ offset 8) (cddr sgl*)
-						    (combine-loc loc (load-double-reg (car sgl*) offset)))]))]
+					  (dbl-loop (fx- size 8) (fx+ offset 8) (cons (car sgl*) live*) (cddr sgl*)
+						    (combine-loc loc (load-boxed-double-reg (car sgl*) offset)))]))]
 				     [else
 				      ;; General case; for non-doubles, use integer registers while available,
 				      ;;  possibly splitting between registers and stack
@@ -2537,14 +2831,15 @@
 							(cons* (car int*) (cadr int*) live*) (cddr int*) isp))]))]))]
 				 [else
 				    (let* ([num-members (length members)]
-					   [floats? (and (fx<= num-members 4)
+					   [floats? (and (not varargs?)
+                                                         (fx<= num-members 4)
 							 (andmap float-member? members))])
 				      ;; Sequence of up to 4 floats that fits in registers?
 				      (cond
 				       [(and floats?
 					     (fx>= (fx+ (length sgl*) (if bsgl 1 0)) num-members))
 					;; Allocate each float to register
-					(let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f])
+					(let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f] [live* live*])
 					  (cond
 					   [(fx= size 0)
 					    (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
@@ -2552,7 +2847,8 @@
 					    (flt-loop (fx- size 4) (fx+ offset 4)
 						      (if bsgl sgl* (cddr sgl*))
 						      (if bsgl #f (cadr sgl*))
-						      (combine-loc loc (load-single-reg (or bsgl (car sgl*)) offset #t)))]))]
+						      (combine-loc loc (load-boxed-single-reg (or bsgl (car sgl*)) offset #t))
+                                                      (cons (or bsgl (car sgl*)) live*))]))]
 				       [else
 					;; General case; use integer registers while available,
 					;;  possibly splitting between registers and stack
@@ -2616,8 +2912,9 @@
 					 (fx+ offset (if double? 8 4))
 					 `(seq
 					   ,e
-					   (inline ,(make-info-loadfl (car sgl*)) ,(if double? %store-double %store-single)
-						   ,dest-x ,%zero (immediate ,offset))))])))]
+                                           ,(if double?
+                                                `(set! ,(%mref ,dest-x ,%zero ,offset fp) ,(car sgl*))
+                                                (%inline store-single ,(%mref ,dest-x ,%zero ,offset fp) ,(car sgl*)))))])))]
 			    [else
 			     ;; result is in %Cretval and maybe %r1
 			     `(seq
@@ -2633,13 +2930,71 @@
 				  [(8) `(seq
 					 (set! ,(%mref ,dest-x ,0) ,%Cretval)
 					 (set! ,(%mref ,dest-x ,4) ,%r1))]))]))])]
-		     [else e]))])
+		     [else e]))]
+                 [get-result-regs
+                  (lambda (result-type varargs?)
+                    (nanopass-case (Ltype Type) result-type
+                      [(fp-double-float)
+                       (if varargs?
+                           (list %r1 %Cretval)
+                           (list %Cfpretval))]
+                      [(fp-single-float)
+                       (if varargs?
+                           (list %Cretval)
+                           (list %Cfpretval))]
+                      [(fp-integer ,bits)
+                       (case bits
+                         [(64) (list %r1 %Cretval)]
+                         [else (list %Cretval)])]
+                      [(fp-unsigned ,bits)
+                       (case bits
+                         [(64) (list %r1 %Cretval)]
+                         [else (list %Cretval)])]
+		      [(fp-ftd& ,ftd)
+		       (let* ([members ($ftd->members ftd)]
+			      [num-members (length members)])
+			 (cond
+			  [(and (fx<= num-members 4)
+				(or (andmap double-member? members)
+				    (andmap float-member? members)))
+			   ;; double/float results are in floating-point registers
+			   (let ([double? (and (pair? members) (double-member? (car members)))])
+			     (let loop ([members members] [sgl* (sgl-regs)])
+			       (cond
+				[(null? members) '()]
+				[double?
+				 (cons (car sgl*) (loop (cdr members) (cddr sgl*)))]
+				[else
+				 (cons (car sgl*) (if (null? (cdr members))
+						      '()
+						      (loop (cddr members) (cddr sgl*))))])))]
+			    [else
+			     ;; result is in %Cretval and maybe %r1
+			     (case ($ftd-size ftd)
+			       [(8) (list %Cretval %r1)]
+			       [else (list %Cretval)])]))]
+                      [else (list %r0)]))]
+                 [add-deactivate
+                  (lambda (adjust-active? t0 live* result-live* k)
+                    (cond
+                      [adjust-active?
+                       (%seq
+			(set! ,%ac0 ,t0)
+                        ,(save-and-restore live* (%inline deactivate-thread))
+                        ,(k %ac0)
+                        ,(save-and-restore result-live* `(set! ,%Cretval ,(%inline activate-thread))))]
+                      [else (k t0)]))])
           (lambda (info)
             (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
             (let* ([arg-type* (info-foreign-arg-type* info)]
+                   [conv* (info-foreign-conv* info)]
+                   [varargs? (memq 'varargs conv*)]
 		   [result-type (info-foreign-result-type info)]
-		   [fill-result-here? (indirect-result-that-fits-in-registers? result-type)])
-              (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
+                   [result-reg* (get-result-regs result-type varargs?)]
+		   [fill-result-here? (indirect-result-that-fits-in-registers? result-type)]
+                   [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
+              (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*)
+                                    varargs?)
                 (lambda (args-frame-size locs live*)
                   (let* ([frame-size (align 8 (+ args-frame-size
 						 (if fill-result-here?
@@ -2658,18 +3013,27 @@
 			  ;; stash extra argument on the stack to be retrieved after call and filled with the result:
 			  (cons (load-int-stack args-frame-size) locs)]
 			 [else locs]))
-                      (lambda (t0)
+                      (lambda (t0 not-varargs?)
 			(add-fill-result fill-result-here? result-type args-frame-size
-			  `(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0)))
+                         (add-deactivate adjust-active? t0 live* result-reg*
+			  (lambda (t0)
+ 			    `(inline ,(make-info-kill*-live* (add-caller-save-registers result-reg*) live*) ,%c-call ,t0)))))
                       (nanopass-case (Ltype Type) result-type
                         [(fp-double-float)
-                         (lambda (lvalue)
-                           `(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
-                              ,(%constant flonum-data-disp)))]
+                         (if varargs?
+                             (lambda (lvalue) ; unboxed
+                               `(set! ,lvalue ,(%inline fpcastfrom ,%r1 ,%Cretval)))
+                             (lambda (lvalue) ; unboxed
+                               `(set! ,lvalue ,%Cfpretval)))]
                         [(fp-single-float)
-                         (lambda (lvalue)
-                           `(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero
-                              ,(%constant flonum-data-disp)))]
+                         (if varargs?
+                             (lambda (lvalue) ; unboxed
+                               (let ([t %Cfpretval]) ; should be ok as a temporary register
+                                 `(seq
+                                   (set! ,t ,(%inline fpcastfrom ,%r1 ,%Cretval)) ; we don't actually care about the hi/%r1 part
+                                   (set! ,lvalue ,(%inline single->double ,t)))))
+                             (lambda (lvalue) ; unboxed
+                               `(set! ,lvalue ,(%inline single->double ,%Cfpretval))))]
                         [(fp-integer ,bits)
                          (case bits
                            [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%r0)))]
@@ -2700,31 +3064,31 @@
                    +---------------------------+
                    |                           |
                    |    incoming stack args    |
-  sp+36+R+X+Y+Z+W: |                           |
+  sp+52+R+X+Y+Z+W: |                           |
                    +---------------------------+<- 8-byte boundary
                    |                           | 
                    |    saved int reg args     | 0-4 words
-    sp+36+R+X+Y+Z: |                           |
+    sp+52+R+X+Y+Z: |                           |
                    +---------------------------+
                    |                           | 
                    |   pad word if necessary   | 0-1 words
-      sp+36+R+X+Y: |                           |
+      sp+52+R+X+Y: |                           |
                    +---------------------------+<- 8-byte boundary
                    |                           | 
                    |   saved float reg args    | 0-16 words
-        sp+36+R+X: |                           |
+        sp+52+R+X: |                           |
                    +---------------------------+<- 8-byte boundary
                    |                           | 
                    |      &-return space       | up to 8 words
-          sp+36+R: |                           |
+          sp+52+R: |                           |
                    +---------------------------+<- 8-byte boundary
-                   |                           | 
-                   |   pad word if necessary   | 0-1 words
-            sp+36: |                           |
+                   |     activatation state    | 
+                   |          and/or           | 0-2 words
+            sp+52: |   pad word if necessary   |
                    +---------------------------+
                    |                           |
-                   |   callee-save regs + lr   | 9 words
-             sp+0: |                           | 
+                   |   callee-save regs + lr   | 13 words
+             sp+0: |   callee-save fpregs      |
                    +---------------------------+<- 8-byte boundary
 
       X = 0 or 4 (depending on whether pad is present)
@@ -2736,15 +3100,13 @@
           (define load-double-stack
             (lambda (offset)
               (lambda (x) ; requires var
-                (%seq
-                  (inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
-                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%mref ,%sp ,%zero ,offset fp)))))
           (define load-single-stack
             (lambda (offset)
               (lambda (x) ; requires var
-                (%seq
-                  (inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
-                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
           (define load-int-stack
             (lambda (type offset)
               (lambda (lvalue)
@@ -2773,16 +3135,19 @@
 	      (lambda (lvalue)
 		`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
           (define count-reg-args
-            (lambda (types synthesize-first?)
+            (lambda (types synthesize-first? varargs?)
               ; bsgl? is #t iff we have a "b" single (second half of double) float reg to fill
               (let f ([types types] [iint (if synthesize-first? -1 0)] [idbl 0] [bsgl? #f])
                 (if (null? types)
                     (values iint idbl)
                     (nanopass-case (Ltype Type) (car types)
                       [(fp-double-float)
-                       (if (fx< idbl 8)
-                           (f (cdr types) iint (fx+ idbl 1) bsgl?)
-                           (f (cdr types) iint idbl #f))]
+                       (if varargs?
+                           (let ([iint (align 2 iint)])
+                             (f (cdr types) (if (fx< iint num-int-regs) (fx+ iint 2) iint) idbl bsgl?))
+                           (if (fx< idbl 8)
+                               (f (cdr types) iint (fx+ idbl 1) bsgl?)
+                               (f (cdr types) iint idbl #f)))]
                       [(fp-single-float)
                        (if bsgl?
                            (f (cdr types) iint idbl #f)
@@ -2823,8 +3188,8 @@
                              [(fp-unsigned ,bits) (fx= bits 64)]
                              [else #f])
                            (let ([iint (align 2 iint)])
-                             (f (cdr types) (if (fx< iint 4) (fx+ iint 2) iint) idbl bsgl?))
-                           (f (cdr types) (if (fx< iint 4) (fx+ iint 1) iint) idbl bsgl?))])))))
+                             (f (cdr types) (if (fx< iint num-int-regs) (fx+ iint 2) iint) idbl bsgl?))
+                           (f (cdr types) (if (fx< iint num-int-regs) (fx+ iint 1) iint) idbl bsgl?))])))))
           (define do-stack
             ; all of the args are on the stack at this point, though not contiguous since
             ; we push all of the int reg args with one push instruction and all of the
@@ -2832,7 +3197,7 @@
 	    ; continue on into the stack variables, which is convenient when a struct
 	    ; argument is split across registers and the stack
             (lambda (types saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
-			   synthesize-first?)
+			   synthesize-first? varargs?)
               (let* ([return-space-offset (fx+ saved-reg-bytes pre-pad-bytes)]
                      [float-reg-offset (fx+ return-space-offset return-bytes)]
                      [int-reg-offset (fx+ float-reg-offset float-reg-bytes post-pad-bytes)]
@@ -2853,20 +3218,36 @@
                             locs))
                       (nanopass-case (Ltype Type) (car types)
                         [(fp-double-float)
-                         (if (< idbl 8)
-                             (loop (cdr types)
-                               (cons (load-double-stack float-reg-offset) locs)
-                               iint (fx+ idbl 1) bsgl-offset int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)
-                             (let ([stack-arg-offset (align 8 stack-arg-offset)])
-                               (loop (cdr types)
-                                 (cons (load-double-stack stack-arg-offset) locs)
-                                 iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))))]
+                         (cond
+                           [(and varargs?
+                                 ;; For varargs, treat a double like a 64-bit integer
+                                 (let ([iint (align 2 iint)])
+                                   (and (fx< iint num-int-regs)
+                                        iint)))
+                            => (lambda (new-iint)
+                                 (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
+                                       [iint new-iint])
+                                   (loop (cdr types)
+                                     (cons (load-double-stack int-reg-offset) locs)
+                                     (fx+ iint 2) idbl bsgl-offset (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)))]
+                           [(and (not varargs?)
+                                 (< idbl num-dbl-regs))
+                            (loop (cdr types)
+                              (cons (load-double-stack float-reg-offset) locs)
+                              iint (fx+ idbl 1) bsgl-offset int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)]
+                           [else
+                            (let ([stack-arg-offset (align 8 stack-arg-offset)]
+                                  [iint (if varargs? (align 2 iint) iint)]) ; use up register if argument didn't fit
+                              (loop (cdr types)
+                                (cons (load-double-stack stack-arg-offset) locs)
+                                iint num-dbl-regs #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))])]
                         [(fp-single-float)
+                         (safe-assert (not varargs?))
                          (if bsgl-offset
                              (loop (cdr types)
                                (cons (load-single-stack bsgl-offset) locs)
                                iint idbl #f int-reg-offset float-reg-offset stack-arg-offset)
-                             (if (< idbl 8)
+                             (if (< idbl num-dbl-regs)
                                  (loop (cdr types)
                                    ; with big-endian ARM might need to adjust offset +/- 4 since pair of
                                    ; single floats in a pushed double float might be reversed
@@ -2874,28 +3255,30 @@
                                    iint (fx+ idbl 1) (fx+ float-reg-offset 4) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)
                                  (loop (cdr types)
                                    (cons (load-single-stack stack-arg-offset) locs)
-                                   iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))]
+                                   iint num-dbl-regs #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))]
 			[(fp-ftd& ,ftd)
 			 (let* ([size ($ftd-size ftd)]
 				[members ($ftd->members ftd)]
 				[num-members (length members)])
 			   (cond
-			    [(and (fx<= num-members 4)
+			    [(and (not varargs?)
+                                  (fx<= num-members 4)
 				  (andmap double-member? members))
 			     ;; doubles are either in registers or all on stack
-			     (if (fx<= (fx+ idbl num-members) 8)
+			     (if (fx<= (fx+ idbl num-members) num-dbl-regs)
 				 (loop (cdr types)
                                    (cons (load-stack-address float-reg-offset) locs)
 				   iint (fx+ idbl num-members) #f int-reg-offset (fx+ float-reg-offset size) stack-arg-offset)
 				 (let ([stack-arg-offset (align 8 stack-arg-offset)])
 				   (loop (cdr types)
                                      (cons (load-stack-address stack-arg-offset) locs)
-                                     iint 8 #f int-reg-offset #f (fx+ stack-arg-offset size))))]
-			    [(and (fx<= num-members 4)
+                                     iint num-dbl-regs #f int-reg-offset #f (fx+ stack-arg-offset size))))]
+			    [(and (not varargs?)
+                                  (fx<= num-members 4)
 				  (andmap float-member? members))
 			     ;; floats are either in registers or all on stack
 			     (let ([amt (fxsrl (align 2 (fx- num-members (if bsgl-offset 1 0))) 1)])
-			       (if (fx<= (fx+ idbl amt) 8)
+			       (if (fx<= (fx+ idbl amt) num-dbl-regs)
 				   (let ([odd-floats? (fxodd? num-members)])
 				     (if bsgl-offset
 					 (let ([dbl-size (align 8 (fx- size 4))])
@@ -2910,15 +3293,15 @@
 					     (fx+ float-reg-offset dbl-size) stack-arg-offset))))
 				   (loop (cdr types)
                                      (cons (load-stack-address stack-arg-offset) locs)
-                                     iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]
+                                     iint num-dbl-regs #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]
 			    [(fx= 8 ($ftd-alignment ftd))
                              (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
 				   [iint (align 2 iint)]
 				   [amt (fxsrl size 2)])
-                               (if (fx< iint 4) ; argument starts in registers, may continue on stack
+                               (if (fx< iint num-int-regs) ; argument starts in registers, may continue on stack
                                    (loop (cdr types)
                                      (cons (load-stack-address int-reg-offset) locs)
-                                     (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
+                                     (fxmin num-int-regs (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
 				     (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
                                    (let ([stack-arg-offset (align 8 stack-arg-offset)])
                                      (loop (cdr types)
@@ -2927,10 +3310,10 @@
 			    [else
 			     (let* ([size (align 4 size)]
 				    [amt (fxsrl size 2)])
-			       (if (fx< iint 4) ; argument starts in registers, may continue on stack
+			       (if (fx< iint num-int-regs) ; argument starts in registers, may continue on stack
 				   (loop (cdr types)
                                      (cons (load-stack-address int-reg-offset) locs)
-				     (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
+				     (fxmin num-int-regs (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
 				     (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
 				   (loop (cdr types)
 				     (cons (load-stack-address stack-arg-offset) locs)
@@ -2942,7 +3325,7 @@
                                [else #f])
                              (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
 				   [iint (align 2 iint)])
-                               (if (fx= iint 4)
+                               (if (fx= iint num-int-regs)
                                    (let ([stack-arg-offset (align 8 stack-arg-offset)])
                                      (loop (cdr types)
                                        (cons (load-int64-stack stack-arg-offset) locs)
@@ -2950,7 +3333,7 @@
                                    (loop (cdr types)
                                      (cons (load-int64-stack int-reg-offset) locs)
                                      (fx+ iint 2) idbl bsgl-offset (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)))
-                             (if (fx= iint 4)
+                             (if (fx= iint num-int-regs)
                                  (loop (cdr types)
                                    (cons (load-int-stack (car types) stack-arg-offset) locs)
                                    iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))
@@ -2958,13 +3341,14 @@
                                    (cons (load-int-stack (car types) int-reg-offset) locs)
                                    (fx+ iint 1) idbl bsgl-offset (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset)))]))))))
           (define do-result
-            (lambda (result-type synthesize-first? return-stack-offset)
+            (lambda (result-type synthesize-first? varargs? return-stack-offset)
 	      (nanopass-case (Ltype Type) result-type
                 [(fp-ftd& ,ftd)
 		 (let* ([members ($ftd->members ftd)]
 			[num-members (length members)])
 		   (cond
-		    [(and (fx<= 1 num-members 4)
+		    [(and (not varargs?)
+                          (fx<= 1 num-members 4)
 			  (or (andmap double-member? members)
 			      (andmap float-member? members)))
 		     ;; double/float results returned in floating-point registers
@@ -2979,10 +3363,18 @@
 				    (if double? (cddr sgl*) (cdr sgl*))
 				    (fx+ offset (if double? 8 4))
 				    (let ([new-e
-					   `(inline ,(make-info-loadfl (car sgl*)) ,(if double? %load-double %load-single)
-						    ,%sp ,%zero (immediate ,offset))])
+                                           (if double?
+                                               `(set! ,(car sgl*) ,(%mref ,%sp ,%zero ,offset fp))
+                                               `(set! ,(car sgl*) ,(%inline load-single ,(%mref ,%sp ,%zero ,offset fp))))])
 				      (if e `(seq ,e ,new-e) new-e)))]))))
-		      '()
+		      (let ([double? (and (pair? members) (double-member? (car members)))])
+			(let loop ([members members] [sgl* (sgl-regs)] [aligned? #t])
+			  (cond
+			   [(null? members) '()]
+			   [else (let ([regs (loop (cdr members)
+						   (if double? (cddr sgl*) (cdr sgl*))
+						   (or double? (not aligned?)))])
+				   (if aligned? (cons (car sgl*) regs) regs))])))
 		      ($ftd-size ftd))]
 		    [else
 		     (case ($ftd-size ftd)
@@ -2995,20 +3387,42 @@
 				8)]
 		       [else
 			(values (lambda ()
-				  `(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset)))
-				(list %Cretval %r1)
+                                  (case ($ftd-size ftd)
+                                    [(1)
+                                     (let ([rep (if ($ftd-unsigned? ftd) 'unsigned-8 'integer-8)])
+                                       `(set! ,%Cretval (inline ,(make-info-load rep #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset))))]
+                                    [(2)
+                                     (let ([rep (if ($ftd-unsigned? ftd) 'unsigned-16 'integer-16)])
+                                       `(set! ,%Cretval (inline ,(make-info-load rep #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset))))]
+                                    [else `(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))]))
+				(list %Cretval)
 				4)])]))]
 		[(fp-double-float)
-		 (values (lambda (rhs)
-			   `(inline ,(make-info-loadfl %Cfpretval) ,%load-double
-				    ,rhs ,%zero ,(%constant flonum-data-disp)))
-			 '()
+		 (values (if varargs?
+                             (lambda (rhs)
+                               (let-values ([(endreg otherreg) (constant-case native-endianness
+                                                                 [(little) (values %Cretval %r1)]
+                                                                 [(big) (values %r1 %Cretval)])])
+                                 `(seq
+                                   (set! ,endreg ,(%mref ,rhs ,(constant flonum-data-disp)))
+                                   (set! ,otherreg ,(%mref ,rhs ,(fx+ 4 (constant flonum-data-disp)))))))
+                             (lambda (rhs)
+                               `(set! ,%Cfpretval ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp))))
+			 (if varargs?
+                             (list %Cretval %r1)
+                             (list %Cfpretval))
 			 0)]
 		[(fp-single-float)
-		 (values (lambda (rhs)
-			   `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single
-				    ,rhs ,%zero ,(%constant flonum-data-disp)))
-			 '()
+		 (values (if varargs?
+                             (lambda (rhs)
+                               `(seq
+                                 (set! ,%Cfpretval ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp)))
+                                 (set! ,%Cretval ,(%inline fpcastto/lo ,%Cfpretval))))
+                             (lambda (rhs)
+                               `(set! ,%Cfpretval ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp)))))
+                         (if varargs?
+                             (list %Cretval)
+                             (list %Cfpretval))
 			 0)]
                 [(fp-void)
                  (values (lambda () `(nop))
@@ -3029,21 +3443,34 @@
 		  [else
 		   (values (lambda (x)
 			     `(set! ,%Cretval ,x))
-			   (list %Cretval %r1)
+			   (list %Cretval)
 			   0)])])))
           (lambda (info)
             (define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr))
+            (define callee-save-fpregs  (list %fp1 %fp2)) ; must be consecutive
             (define isaved (length callee-save-regs+lr))
+            (define fpsaved (length callee-save-fpregs))
+            (safe-assert (andmap (lambda (r)
+                                   (or (not (reg-callee-save? r))
+                                       (if (eq? (reg-type r) 'fp)
+                                           (memq r callee-save-fpregs)
+                                           (memq r callee-save-regs+lr))))
+                                 (vector->list regvec)))
             (let* ([arg-type* (info-foreign-arg-type* info)]
+                   [conv* (info-foreign-conv* info)]
+		   [varargs? (memq 'varargs conv*)]
 		   [result-type (info-foreign-result-type info)]
-		   [synthesize-first? (indirect-result-that-fits-in-registers? result-type)])
-              (let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first?)])
-                (let ([saved-reg-bytes (fx* isaved 4)]
-                      [pre-pad-bytes (if (fxeven? isaved) 0 4)]
+                   [synthesize-first? (indirect-result-that-fits-in-registers? result-type)]
+                   [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
+              (let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first? varargs?)])
+                (let ([saved-reg-bytes (fx+ (fx* isaved 4) (fx* fpsaved 8))]
+                      [pre-pad-bytes (if (fxeven? isaved) 
+                                         (if adjust-active? 8 0)
+                                         4)]
                       [int-reg-bytes (fx* iint 4)]
                       [post-pad-bytes (if (fxeven? iint) 0 4)]
                       [float-reg-bytes (fx* idbl 8)])
-                  (let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first?
+                  (let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first? varargs?
 										 (fx+ saved-reg-bytes pre-pad-bytes))])
                     (let ([return-bytes (align 8 return-bytes)])
                       (values
@@ -3057,9 +3484,16 @@
                                (if (fx= len 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,len)))))
                             ,(if (fx= idbl 0) `(nop) `(inline ,(make-info-vpush %Cfparg1 idbl) ,%vpush-multiple))
                             ; pad if necessary to force 8-byte boundardy after saving callee-save-regs+lr
-                            ,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4))))
+                            ,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,pre-pad-bytes))))
                             ; save the callee save registers & return address
                             (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple)
+                            (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpush-multiple)
+                            ; maybe activate
+                            ,(if adjust-active?
+                                 `(seq
+                                   (set! ,%Cretval ,(%inline activate-thread))
+                                   (set! ,(%mref ,%sp ,saved-reg-bytes) ,%Cretval))
+                                 `(nop))
                             ; set up tc for benefit of argument-conversion code, which might allocate
                             ,(if-feature pthreads
                                (%seq 
@@ -3069,15 +3503,29 @@
                         ; list of procedures that marshal arguments from their C stack locations
                         ; to the Scheme argument locations
                         (do-stack arg-type* saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
-                                  synthesize-first?)
+                                  synthesize-first? varargs?)
                         get-result
                         (lambda ()
                           (in-context Tail
                             (%seq
+                              ,(if adjust-active?
+                                   (%seq
+                                    ;; We need *(sp+saved-reg-bytes) in %Carg1,
+                                    ;; but that can also be a return register.
+                                    ;; Meanwhle, sp may change before we call unactivate.
+                                    ;; So, move to %r2 for now, then %Carg1 later:
+                                    (set! ,%r2 ,(%mref ,%sp ,saved-reg-bytes))
+                                    ,(save-and-restore
+                                      result-regs
+                                      `(seq
+                                        (set! ,%Carg1 ,%r2)
+                                        ,(%inline unactivate-thread ,%Carg1))))
+                                   `(nop))
                               ; restore the callee save registers
+                              (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpop-multiple)
                               (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple)
                               ; deallocate space for pad & arg reg values
-                              (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes post-pad-bytes float-reg-bytes))))
+                              (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes return-bytes post-pad-bytes float-reg-bytes))))
                               ; done
                               (asm-c-return ,null-info ,callee-save-regs+lr ... ,result-regs ...)))))))))))))))
 )
diff --git a/src/ChezScheme/s/arm32le.def b/src/ChezScheme/s/arm32le.def
index e9657b4381..cb03c253ab 100644
--- a/src/ChezScheme/s/arm32le.def
+++ b/src/ChezScheme/s/arm32le.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/arm64.ss b/src/ChezScheme/s/arm64.ss
new file mode 100644
index 0000000000..119ab1944f
--- /dev/null
+++ b/src/ChezScheme/s/arm64.ss
@@ -0,0 +1,3414 @@
+;;; arm64.ss
+
+;;; SECTION 1: registers
+;;; ABI:
+;;;  Register usage:
+;;;   r0-r7: C argument/result registers, caller-save
+;;;   r8: indirect-result register, caller-save
+;;;   r9-18: caller-save
+;;;   r19-28: callee-save
+;;;   r29: frame pointer, callee-save
+;;;   r30: a.k.a. lr, link register
+;;;   sp: stack pointer or (same register number) zero register
+;;;   --------
+;;;   v0-v7: FP registers used for C arguments/results, caller-save
+;;;   v8-v15: callee-save for low 64 bits
+;;;   v16-v31: caller-save
+;;;  Alignment:
+;;;   stack must be 16-byte aligned, essentially always
+
+(define-registers
+  (reserved
+    [%tc  %r19                  #t 19 uptr]
+    [%sfp %r20                  #t 20 uptr]
+    [%ap  %r21                  #t 21 uptr]
+    [%trap %r22                 #t 22 uptr])
+  (allocable
+    [%ac0 %r23                  #t 23 uptr]
+    [%xp  %r24                  #t 24 uptr]
+    [%ts  %r8                   #f  8 uptr]
+    [%td  %r25                  #t 25 uptr]
+    [%cp  %r26                  #t 26 uptr]
+    [     %r0  %Carg1 %Cretval  #f  0 uptr]
+    [     %r1  %Carg2           #f  1 uptr]
+    [     %r2  %Carg3 %reify1   #f  2 uptr]
+    [     %r3  %Carg4 %reify2   #f  3 uptr]
+    [     %r4  %Carg5           #f  4 uptr]
+    [     %r5  %Carg6           #f  5 uptr]
+    [     %r6  %Carg7           #f  6 uptr]
+    [     %r7  %Carg8           #f  7 uptr]
+    [     %lr                   #f 30 uptr] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room
+    [%fp1           %v8         #f  8 fp]
+    [%fp2           %v9         #f  9 fp]
+  )
+  (machine-dependent
+    [%jmptmp %argtmp            #f 10 uptr]
+    [%argtmp2                   #f 11 uptr]
+    [%sp %real-zero             #t 31 uptr]
+    [%Cfparg1 %Cfpretval      %v0   #f  0 fp]
+    [%Cfparg2                 %v1   #f  1 fp]
+    [%Cfparg3                 %v2   #f  2 fp]
+    [%Cfparg4                 %v3   #f  3 fp]
+    [%Cfparg5                 %v4   #f  4 fp]
+    [%Cfparg6                 %v5   #f  5 fp]
+    [%Cfparg7                 %v6   #f  6 fp]
+    [%Cfparg8                 %v7   #f  7 fp]
+    ;; etc., but FP registers v8-v15 are preserved
+    ))
+
+;;; SECTION 2: instructions
+(module (md-handle-jump) ; also sets primitive handlers
+  (import asm-module)
+
+  (define-syntax seq
+    (lambda (x)
+      (syntax-case x ()
+        [(_ e ... ex)
+         (with-syntax ([(t ...) (generate-temporaries #'(e ...))])
+           #'(let ([t e] ...)
+               (with-values ex
+                 (case-lambda
+                   [(x*) (cons* t ... x*)]
+                   [(x* p) (values (cons* t ... x*) p)]))))])))
+
+  ; don't bother with literal@? check since lvalues can't be literals
+  (define lmem? mref?)
+
+  (define mem?
+    (lambda (x)
+      (or (lmem? x) (literal@? x))))
+
+  (define fpmem?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
+        [else #f])))
+
+  (define imm-funkymask?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(immediate ,imm) (and (funkymask imm) #t)]
+        [else #f])))
+
+  (define imm-unsigned12?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(immediate ,imm) (unsigned12? imm)]
+        [else #f])))
+
+  (define imm-neg-unsigned12?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(immediate ,imm) (unsigned12? (- imm))]
+        [else #f])))
+
+  (define imm-constant?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(immediate ,imm) #t]
+        [else #f])))
+
+  (define-pass imm->negate-imm : (L15c Triv) (ir) -> (L15d Triv) ()
+    (Triv : Triv (ir) -> Triv ()
+      [(immediate ,imm) `(immediate ,(- imm))]
+      [else (sorry! who "~s is not an immediate" ir)]))
+
+  (define-syntax mem-of-type?
+    (lambda (stx)
+      (syntax-case stx (mem fpmem)
+        [(_ mem e) #'(lmem? e)]
+        [(_ fpmem e) #'(fpmem? e)])))
+
+  (define lvalue->ur
+    (lambda (x k)
+      (if (mref? x)
+          (let ([u (make-tmp 'u)])
+            (seq
+              (set-ur=mref u x)
+              (k u)))
+          (k x))))
+
+  (define mref->mref
+    (lambda (a k)
+      (define return
+        (lambda (x0 x1 imm type)
+          ; arm load & store instructions support index or offset but not both
+          (safe-assert (or (eq? x1 %zero) (eqv? imm 0)))
+          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))
+      (nanopass-case (L15c Triv) a
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type)
+         (lvalue->ur lvalue0
+           (lambda (x0)
+             (lvalue->ur lvalue1
+               (lambda (x1)
+                 (cond
+                   [(and (eq? x1 %zero) (or (signed9? imm)
+                                            (aligned-offset? imm)))
+                    (return x0 %zero imm type)]
+                   [(and (not (eq? x1 %zero)) (unsigned12? imm))
+                    (let ([u (make-tmp 'u)])
+                      (seq
+                       (build-set! ,u (asm ,null-info ,(asm-add #f) ,x1 (immediate ,imm)))
+                       (return x0 u 0 type)))]
+                   [(and (not (eq? x1 %zero)) (unsigned12? (- imm)))
+                    (let ([u (make-tmp 'u)])
+                      (seq
+                       (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x1 (immediate ,imm)))
+                       (return x0 u 0 type)))]
+                   [else
+                    (let ([u (make-tmp 'u)])
+                      (seq
+                        (build-set! ,u (immediate ,imm))
+                        (if (eq? x1 %zero)
+                            (return x0 u 0 type)
+                            (seq
+                              (build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1))
+                              (return x0 u 0 type)))))])))))])))
+
+  (define mem->mem
+    (lambda (a k)
+      (cond
+        [(literal@? a)
+         (let ([u (make-tmp 'u)])
+           (seq
+             (build-set! ,u ,(literal@->literal a))
+             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
+        [else (mref->mref a k)])))
+
+  (define fpmem->fpmem mem->mem)
+
+  (define-syntax coercible?
+    (syntax-rules ()
+      [(_ ?a ?aty*)
+       (let ([a ?a] [aty* ?aty*])
+         (or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
+             (and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
+             (and (memq 'unsigned12 aty*) (imm-unsigned12? a))
+             (and (memq 'neg-unsigned12 aty*) (imm-neg-unsigned12? a))
+             (and (memq 'funkymask aty*) (imm-funkymask? a))
+             (and (memq 'imm-constant aty*) (imm-constant? a))
+             (and (memq 'mem aty*) (mem? a))
+             (and (memq 'fpmem aty*) (fpmem? a))))]))
+
+  (define-syntax coerce-opnd ; passes k something compatible with aty*
+    (syntax-rules ()
+      [(_ ?a ?aty* ?k)
+       (let ([a ?a] [aty* ?aty*] [k ?k])
+         (cond
+           [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
+           [(and (memq 'fpmem aty*) (fpmem? a)) (fpmem->fpmem a k)]
+           [(and (memq 'unsigned12 aty*) (imm-unsigned12? a)) (k (imm->imm a))]
+           [(and (memq 'neg-unsigned12 aty*) (imm-neg-unsigned12? a)) (k (imm->negate-imm a))]
+           [(and (memq 'funkymask aty*) (imm-funkymask? a)) (k (imm->imm a))]
+           [(and (memq 'imm-constant aty*) (imm-constant? a)) (k (imm->imm a))]
+           [(memq 'ur aty*)
+            (cond
+              [(ur? a) (k a)]
+              [(imm? a)
+               (let ([u (make-tmp 'u)])
+                 (seq
+                   (build-set! ,u ,(imm->imm a))
+                   (k u)))]
+              [(mem? a)
+               (mem->mem a
+                 (lambda (a)
+                   (let ([u (make-tmp 'u)])
+                     (seq
+                       (build-set! ,u ,a)
+                       (k u)))))]
+              [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
+           [(memq 'fpur aty*)
+            (cond
+              [(fpur? a) (k a)]
+              [(fpmem? a)
+               (fpmem->fpmem a
+                 (lambda (a)
+                   (let ([u (make-tmp 'u 'fp)])
+                     (seq
+                       (build-set! ,u ,a)
+                       (k u)))))]
+              [else
+               (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
+           [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
+
+  (define set-ur=mref
+    (lambda (ur mref)
+      (mref->mref mref
+        (lambda (mref)
+          (build-set! ,ur ,mref)))))
+
+  (define md-handle-jump
+    (lambda (t)
+      (with-output-language (L15d Tail)
+        (define long-form
+          (lambda (e)
+            (let ([tmp (make-tmp 'utmp)])
+              (values
+                (in-context Effect `(set! ,(make-live-info) ,tmp ,e))
+                `(jump ,tmp)))))
+        (nanopass-case (L15c Triv) t
+          [,lvalue
+           (if (mem? lvalue)
+               (mem->mem lvalue (lambda (e) (values '() `(jump ,e))))
+               (values '() `(jump ,lvalue)))]
+          [(literal ,info)
+           (guard (and (not (info-literal-indirect? info))
+                       (memq (info-literal-type info) '(entry library-code))))
+           (values '() `(jump (literal ,info)))]
+          [(label-ref ,l ,offset)
+           (values '() `(jump (label-ref ,l ,offset)))]
+          [else (long-form t)]))))
+
+  (define-syntax define-instruction
+    (lambda (x)
+      (define make-value-clause
+        (lambda (fmt)
+          (syntax-case fmt (mem fpmem ur fpur)
+            [(op (c mem) (a aty ...) ...)
+             #`(lambda (c a ...)
+                 (if (and (lmem? c) (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (cond
+                           [(null? a*)
+                            #'(mem->mem c
+                               (lambda (c)
+                                 (rhs c a ...)))]
+                           [else
+                            #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                (lambda (#,(car a*))
+                                  #,(f (cdr a*) (cdr aty**))))]))
+                     (next c a ...)))]
+            [(op (c fpmem) (a aty ...) ...)
+             #`(lambda (c a ...)
+                 (if (and (fpmem? c) (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (cond
+                           [(null? a*)
+                            #'(fpmem->fpmem c
+                               (lambda (c)
+                                 (rhs c a ...)))]
+                           [else
+                            #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                (lambda (#,(car a*))
+                                  #,(f (cdr a*) (cdr aty**))))]))
+                     (next c a ...)))]
+            [(op (c ur) (a aty ...) ...)
+             #`(lambda (c a ...)
+                 (if (and (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (if (null? a*)
+                             #'(if (ur? c)
+                                   (rhs c a ...)
+                                   (let ([u (make-tmp 'u)])
+                                     (seq
+                                       (rhs u a ...)
+                                       (mref->mref c
+                                         (lambda (c)
+                                           (build-set! ,c ,u))))))
+                             #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
+                     (next c a ...)))]
+            [(op (c fpur) (a aty ...) ...)
+             #`(lambda (c a ...)
+                 (if (and (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (if (null? a*)
+                             #'(if (fpur? c)
+                                   (rhs c a ...)
+                                   (let ([u (make-tmp 'u 'fp)])
+                                     (seq
+                                       (rhs u a ...)
+                                       (fpmem->fpmem c
+                                         (lambda (c)
+                                           (build-set! ,c ,u))))))
+                             #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
+                     (next c a ...)))])))
+
+      (define-who make-pred-clause
+        (lambda (fmt)
+          (syntax-case fmt ()
+            [(op (a aty ...) ...)
+             #`(lambda (a ...)
+                 (if (and (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (if (null? a*)
+                             #'(rhs a ...)
+                             #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
+                     (next a ...)))])))
+
+      (define-who make-effect-clause
+        (lambda (fmt)
+          (syntax-case fmt ()
+            [(op (a aty ...) ...)
+             #`(lambda (a ...)
+                 (if (and (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (if (null? a*)
+                             #'(rhs a ...)
+                             #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
+                     (next a ...)))])))
+
+      (syntax-case x (definitions)
+        [(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
+         ; potentially unnecessary level of checking, but the big thing is to make sure
+         ; the number of operands expected is the same on every clause of define-intruction
+         (and (not (null? #'(op ...)))
+              (andmap identifier? #'(sym ...))
+              (andmap identifier? #'(op ...))
+              (andmap identifier? #'(a ... ...))
+              (andmap identifier? #'(aty ... ... ...)))
+         (with-implicit (k info return with-output-language)
+           (with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
+             (define make-proc
+               (lambda (make-clause)
+                 (let f ([op* #'(op ...)]
+                         [fmt* #'((op (a aty ...) ...) ...)]
+                         [arg* #'((a ...) ...)]
+                         [rhs* #'((?rhs0 ?rhs1 ...) ...)])
+                   (if (null? op*)
+                       #'(lambda (opnd* ...)
+                           (sorry! name "no match found for ~s" (list opnd* ...)))
+                       #`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
+                               [rhs (lambda #,(car arg*)
+                                      (let ([#,(car op*) name])
+                                        #,@(car rhs*)))])
+                           #,(make-clause (car fmt*)))))))
+             (unless (let ([a** #'((a ...) ...)])
+                       (let* ([a* (car a**)] [len (length a*)])
+                         (andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
+               (syntax-error x "mismatched instruction arities"))
+             (cond
+               [(free-identifier=? #'context #'value)
+                #`(let ([fvalue (lambda (name)
+                                  (lambda (info opnd* ...)
+                                    defn ...
+                                    (with-output-language (L15d Effect)
+                                      (#,(make-proc make-value-clause) opnd* ...))))])
+                    (begin
+                      (safe-assert (eq? (primitive-type (%primitive sym)) 'value))
+                      (primitive-handler-set! (%primitive sym) (fvalue 'sym)))
+                    ...)]
+               [(free-identifier=? #'context #'pred)
+                #`(let ([fpred (lambda (name)
+                                 (lambda (info opnd* ...)
+                                   defn ...
+                                   (with-output-language (L15d Pred)
+                                     (#,(make-proc make-pred-clause) opnd* ...))))])
+                    (begin
+                      (safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
+                      (primitive-handler-set! (%primitive sym) (fpred 'sym)))
+                    ...)]
+               [(free-identifier=? #'context #'effect)
+                #`(let ([feffect (lambda (name)
+                                   (lambda (info opnd* ...)
+                                     defn ...
+                                     (with-output-language (L15d Effect)
+                                       (#,(make-proc make-effect-clause) opnd* ...))))])
+                    (begin
+                      (safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
+                      (primitive-handler-set! (%primitive sym) (feffect 'sym)))
+                    ...)]
+               [else (syntax-error #'context "unrecognized context")])))]
+        [(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
+        [(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))
+
+  (define info-cc-eq (make-info-condition-code 'eq? #f #t))
+  (define asm-eq (asm-relop info-cc-eq #f))
+
+  ; x is not the same as z in any clause that follows a clause where (x z)
+  ; and y is coercible to one of its types, however:
+  ; WARNING: do not assume that if x isn't the same as z then x is independent
+  ; of z, since x might be an mref with z as it's base or index
+
+  (define-instruction value (- -/ovfl -/eq)
+    [(op (z ur) (x ur) (y unsigned12))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))]
+    [(op (z ur) (x ur) (y neg-unsigned12))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(-/ovfl -/eq))) ,x ,y))]
+    [(op (z ur) (x ur) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))])
+
+  (define-instruction value (+ +/ovfl +/carry)
+    [(op (z ur) (x ur) (y unsigned12))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]
+    [(op (z ur) (x ur) (y neg-unsigned12))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,x ,y))]
+    [(op (z ur) (x unsigned12) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))]
+    [(op (z ur) (x ur) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))])
+
+  (define-instruction value (*)
+    ; no imm form available
+    [(op (z ur) (x ur) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,asm-mul ,x ,y))])
+
+  (define-instruction value (*/ovfl) ; z flag set iff no overflow
+    ; no imm form available
+    [(op (z ur) (x ur) (y ur))
+     (let ([u (make-tmp 'u)])
+       (seq
+         `(set! ,(make-live-info) ,u (asm ,null-info ,asm-smulh ,x ,y))
+         `(set! ,(make-live-info) ,z (asm ,null-info ,asm-mul ,x ,y))
+         `(asm ,null-info ,asm-cmp/asr63 ,u ,z)))])
+
+  (define-instruction value (/)
+    [(op (z ur) (x ur) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,asm-div ,x ,y))])
+
+  (define-instruction value (logand)
+    [(op (z ur) (x ur) (y funkymask))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))]
+    [(op (z ur) (x funkymask) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,y ,x))]
+    [(op (z ur) (x ur) (y ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))])
+
+  (let ()
+    (define select-op (lambda (op) (if (eq? op 'logor) asm-logor asm-logxor)))
+    (define-instruction value (logor logxor)
+      [(op (z ur) (x funkymask) (y ur))
+       `(set! ,(make-live-info) ,z (asm ,info ,((select-op op) #f) ,y ,x))]
+      [(op (z ur) (x ur) (y funkymask ur))
+       `(set! ,(make-live-info) ,z (asm ,info ,((select-op op) #f) ,x ,y))]))
+
+  (define-instruction value (lognot)
+    [(op (z ur) (x ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,x))])
+
+  (define-instruction value (sll srl sra)
+    [(op (z ur) (x ur) (y imm-constant ur))
+     `(set! ,(make-live-info) ,z (asm ,info ,(asm-shiftop op) ,x ,y))])
+
+  (define-instruction value (move)
+    [(op (z mem) (x ur))
+     `(set! ,(make-live-info) ,z ,x)]
+    [(op (z ur) (x ur mem imm-constant))
+     `(set! ,(make-live-info) ,z ,x)])
+
+  (let ()
+    (define build-lea1
+      (lambda (info z x)
+        (let ([offset (info-lea-offset info)])
+          (with-output-language (L15d Effect)
+            (cond
+              [(unsigned12? offset)
+               `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x (immediate ,offset)))]
+              [(unsigned12? (- offset))
+               `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub #f) ,x (immediate ,(- offset))))]
+              [else
+               (let ([u (make-tmp 'u)])
+                 (seq
+                  `(set! ,(make-live-info) ,u (immediate ,offset))
+                  `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x ,u))))])))))
+          
+    (define-instruction value lea1
+      ;; NB: would be simpler if offset were explicit operand
+      ;; NB: why not one version of lea with %zero for y in lea1 case?
+      [(op (z ur) (x ur)) (build-lea1 info z x)])
+
+    (define-instruction value lea2
+      ;; NB: would be simpler if offset were explicit operand
+      [(op (z ur) (x ur) (y ur))
+       (let ([u (make-tmp 'u)])
+         (seq
+          (build-lea1 info u x)
+          `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,y ,u))))]))
+
+  (define-instruction value (sext8 sext16 sext32 zext8 zext16 zext32)
+    [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-move/extend op) ,x))])
+
+  (let ()
+    (define imm-zero (with-output-language (L15d Triv) `(immediate 0)))
+    (define load/store
+      (lambda (x y w type k) ; x ur, y ur, w ur or imm
+        (with-output-language (L15d Effect)
+          (if (ur? w)
+              (if (eq? y %zero)
+                  (k x w imm-zero)
+                  (let ([u (make-tmp 'u)])
+                    (seq
+                      `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w))
+                      (k x u imm-zero))))
+              (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])])
+                (cond
+                  [(and (eq? y %zero)
+                        (aligned-offset? n (case type
+                                             [(unsigned-32 integer-32) 2]
+                                             [(unsigned-16 integer-16) 1]
+                                             [(unsigned-8 integer-8) 0]
+                                             [else 3])))
+                   (let ([w (in-context Triv `(immediate ,n))])
+                     (k x y w))]
+                  [(and (eq? y %zero) (signed9? n))
+                   (let ([w (in-context Triv `(immediate ,n))])
+                     (k x y w))]
+                  [(and (not (eq? y %zero)) (unsigned12? n))
+                   (let ([w (in-context Triv `(immediate ,n))])
+                     (let ([u (make-tmp 'u)])
+                       (seq
+                        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w))
+                        (k x u imm-zero))))]
+                  [(and (not (eq? y %zero)) (unsigned12? (- n)))
+                   (let ([w (in-context Triv `(immediate ,(- n)))])
+                     (let ([u (make-tmp 'u)])
+                       (seq
+                        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-sub #f) ,y ,w))
+                        (k x u imm-zero))))]
+                  [else 
+                   (let ([u (make-tmp 'u)])
+                     (seq
+                       `(set! ,(make-live-info) ,u (immediate ,n))
+                       (if (eq? y %zero)
+                           (k x u imm-zero)
+                           (seq
+                            `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,u))
+                            (k u y imm-zero)))))]))))))
+    (define-instruction value (load)
+      [(op (z ur) (x ur) (y ur) (w ur imm-constant))
+       (let ([type (info-load-type info)])
+         (load/store x y w type
+           (lambda (x y w)
+             (let ([instr `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-load type) ,x ,y ,w))])
+               (if (info-load-swapped? info)
+                   (seq
+                     instr
+                     `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-swap type) ,z)))
+                   instr)))))])
+    (define-instruction effect (store)
+      [(op (x ur) (y ur) (w ur imm-constant) (z ur))
+       (let ([type (info-load-type info)])
+         (load/store x y w type
+           (lambda (x y w)
+             (if (info-load-swapped? info)
+                 (let ([u (make-tmp 'unique-bob)])
+                   (seq
+                     `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-swap type) ,z))
+                     `(asm ,null-info ,(asm-store type) ,x ,y ,w ,u)))
+                 `(asm ,null-info ,(asm-store type) ,x ,y ,w ,z)))))]))
+
+  (define-instruction value (load-single->double)
+    [(op (x fpur) (y fpmem))
+     (let ([u (make-tmp 'u 'fp)])
+       (seq
+        `(set! ,(make-live-info) ,u (asm ,null-info ,asm-fpmove-single ,y))
+        `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,u))))])
+
+  (define-instruction effect (store-double->single)
+    [(op (x fpmem) (y fpur))
+     (let ([u (make-tmp 'u 'fp)])
+       (seq
+        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
+        `(asm ,info ,asm-fpmove-single ,x ,u)))])
+
+  (define-instruction effect (store-single)
+    [(op (x fpmem) (y fpur))
+     `(asm ,info ,asm-fpmove-single ,x ,y)])
+
+  (define-instruction value (load-single)
+    [(op (x fpur) (y fpmem fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove-single ,y))])
+
+  (define-instruction value (single->double double->single)
+    [(op (x fpur) (y fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))])
+
+  (define-instruction value (fpt)
+    [(op (x fpur) (y ur))
+     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])
+
+  (define-instruction value (fptrunc)
+    [(op (x ur) (y fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,asm-fptrunc ,y))])
+
+  (define-instruction value (fpmove)
+    [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
+    [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)])
+
+  (let ()
+    (define (mem->mem mem new-type)
+      (nanopass-case (L15d Triv) mem
+        [(mref ,x0 ,x1 ,imm ,type)
+         (with-output-language (L15d Lvalue) `(mref ,x0 ,x1 ,imm ,new-type))]))
+
+    (define-instruction value (fpcastto)
+      [(op (x mem) (y fpur)) `(set! ,(make-live-info) ,(mem->mem x 'fp) ,y)]
+      [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastto ,y))])
+    
+    (define-instruction value (fpcastfrom)
+      [(op (x fpmem) (y ur)) `(set! ,(make-live-info) ,(mem->mem x 'uptr) ,y)]
+      [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,y))]))
+
+  (define-instruction value (fp+ fp- fp/ fp*)
+    [(op (x fpur) (y fpur) (z fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
+
+  (define-instruction value (fpsqrt)
+    [(op (x fpur) (y fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
+
+  (define-instruction pred (fp= fp< fp<=)
+    [(op (x fpur) (y fpur))
+     (let ([info (make-info-condition-code op #f #f)])
+       (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
+
+  (define-instruction effect (inc-cc-counter)
+    [(op (x ur) (w unsigned12) (z ur unsigned12))
+     (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
+       (seq
+        `(set! ,(make-live-info) ,u1 (asm ,null-info ,(asm-add #f) ,x ,w))
+        `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
+        `(asm ,null-info ,asm-inc-cc-counter ,u1 ,z ,u2)))])
+
+  (define-instruction effect (inc-profile-counter)
+    [(op (x mem) (y unsigned12))
+     (let ([u (make-tmp 'u)])
+       (seq
+         `(set! ,(make-live-info) ,u ,x)
+         `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,u ,y))
+         `(set! ,(make-live-info) ,x ,u)))])
+
+  (define-instruction value (read-time-stamp-counter)
+    [(op (z ur)) `(set! ,(make-live-info) ,z (asm ,null-info
+                                                  ;; CNTPCT_EL0
+                                                  ,(asm-read-counter #b11 #b011 #b1110 #b0000 #b001)))])
+
+  (define-instruction value (read-performance-monitoring-counter)
+    [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (immediate 0))])
+
+  ;; no kills since we expect to be called when all necessary state has already been saved
+  (define-instruction value (get-tc)
+    [(op (z ur))
+     (safe-assert (eq? z %Cretval))
+     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc ,ulr))))])
+
+  (define-instruction value activate-thread
+    [(op (z ur))
+     (safe-assert (eq? z %Cretval))
+     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread ,ulr))))])
+
+  (define-instruction effect deactivate-thread
+    [(op)
+     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(asm ,info ,asm-deactivate-thread ,ulr)))])
+
+  (define-instruction effect unactivate-thread
+    [(op (x ur))
+     (safe-assert (eq? x %Carg1))
+     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(asm ,info ,asm-unactivate-thread ,x ,ulr)))])
+
+  (define-instruction value (asmlibcall)
+    [(op (z ur)) 
+     (if (info-asmlib-save-ra? info)
+         `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info) #t) ,(info-kill*-live*-live* info) ...))
+         (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+           (seq
+            `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+            `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info) #f) ,ulr ,(info-kill*-live*-live* info) ...)))))])
+
+  (define-instruction effect (asmlibcall!)
+    [(op)
+     (if (info-asmlib-save-ra? info)
+         (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+           `(asm ,info ,(asm-library-call! (info-asmlib-libspec info) #t) ,(info-kill*-live*-live* info) ...))
+         (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+           (seq
+            `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+            `(asm ,info ,(asm-library-call! (info-asmlib-libspec info) #f) ,ulr ,(info-kill*-live*-live* info) ...))))])
+
+  (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
+  (define-instruction effect (c-simple-call)
+    [(op)
+     (if (info-c-simple-call-save-ra? info)
+         `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info) #t))
+         (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+           (seq
+            `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+            `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info) #f) ,ulr))))])
+
+  (define-instruction pred (eq? u< < > <= >=)
+    [(op (y unsigned12) (x ur))
+     (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #t #t))])
+       (values '() `(asm ,info ,(asm-relop info #f) ,x ,y)))]
+    [(op (y neg-unsigned12) (x ur))
+     (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #t #t))])
+       (values '() `(asm ,info ,(asm-relop info #t) ,x ,y)))]
+    [(op (x ur) (y ur unsigned12))
+     (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #f #t))])
+       (values '() `(asm ,info ,(asm-relop info #f) ,x ,y)))]
+    [(op (x ur) (y neg-unsigned12))
+     (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #f #t))])
+       (values '() `(asm ,info ,(asm-relop info #t) ,x ,y)))])
+
+  (define-instruction pred (condition-code)
+    [(op) (values '() `(asm ,info ,(asm-condition-code info)))])
+
+  (define-instruction pred (type-check?)
+    [(op (x ur) (mask funkymask ur) (type unsigned12 ur))
+     (let ([tmp (make-tmp 'u)])
+       (values
+         (with-output-language (L15d Effect)
+           `(set! ,(make-live-info) ,tmp (asm ,null-info ,(asm-logand #f) ,x ,mask)))
+         `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))])
+
+  (define-instruction pred (logtest log!test)
+    [(op (x funkymask) (y ur))
+     (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))]
+    [(op (x ur) (y ur funkymask))
+     (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))])
+
+  (let ()
+    (define lea->reg
+      (lambda (x y w k)
+        (with-output-language (L15d Effect)
+          (define add-offset
+            (lambda (r)
+              (if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0)
+                  (k r)
+                  (let ([u (make-tmp 'u)])
+                    (seq
+                      `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w))
+                      (k u))))))
+          (if (eq? y %zero)
+              (add-offset x)
+              (let ([u (make-tmp 'u)])
+                (seq
+                  `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y))
+                  (add-offset u)))))))
+    ;; NB: compiler implements init-lock! and unlock! as word store of zero 
+    (define-instruction pred (lock!)
+      [(op (x ur) (y ur) (w unsigned12))
+       (let ([u (make-tmp 'u)]
+             [u2 (make-tmp 'u2)])
+         (values
+           (lea->reg x y w
+             (lambda (r)
+               (with-output-language (L15d Effect)
+                 (seq
+                   `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
+                   `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
+                   `(asm ,null-info ,asm-lock ,r ,u ,u2)))))
+           `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))])
+    (define-instruction effect (locked-incr! locked-decr!)
+      [(op (x ur) (y ur) (w unsigned12))
+       (lea->reg x y w
+         (lambda (r)
+           (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
+             (seq
+               `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
+               `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
+               `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))])
+    (define-instruction effect (cas)
+      [(op (x ur) (y ur) (w unsigned12) (old ur) (new ur))
+       (lea->reg x y w
+         (lambda (r)
+	   (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
+             (seq
+               `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
+               `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
+	       `(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))]))
+
+  (define-instruction effect (store-store-fence)
+    [(op)
+     `(asm ,info ,(asm-fence 'store-store))])
+
+  (define-instruction effect (acquire-fence)
+    [(op)
+     `(asm ,info ,(asm-fence 'acquire))])
+
+  (define-instruction effect (release-fence)
+    [(op)
+     `(asm ,info ,(asm-fence 'release))])
+
+  (define-instruction effect (pause)
+    ;; NB: use sqrt or something like that?
+    [(op) '()])
+
+  (define-instruction effect (c-call)
+    [(op (x ur))
+     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
+       (seq
+         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
+         `(asm ,info ,asm-indirect-call ,x ,ulr ,(info-kill*-live*-live* info) ...)))])
+
+  (define-instruction effect (pop-multiple)
+    [(op) `(asm ,info ,(asm-pop-multiple (info-kill*-kill* info)))])
+
+  (define-instruction effect (push-multiple)
+    [(op) `(asm ,info ,(asm-push-multiple (info-kill*-live*-live* info)))])
+
+  (define-instruction effect (pop-fpmultiple)
+    [(op) `(asm ,info ,(asm-pop-fpmultiple (info-kill*-kill* info)))])
+
+  (define-instruction effect (push-fpmultiple)
+    [(op) `(asm ,info ,(asm-push-fpmultiple (info-kill*-live*-live* info)))])
+
+  (define-instruction effect save-flrv
+    [(op) `(asm ,info ,(asm-push-fpmultiple (list %Cfpretval)))])
+
+  (define-instruction effect restore-flrv
+    [(op) `(asm ,info ,(asm-pop-fpmultiple (list %Cfpretval)))])
+
+  (define-instruction effect (invoke-prelude)
+    [(op) `(set! ,(make-live-info) ,%tc ,%Carg1)])
+)
+
+;;; SECTION 3: assembler
+(module asm-module (; required exports
+                     asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump
+                     asm-mul asm-smulh asm-div asm-add asm-sub asm-logand asm-logor asm-logxor
+                     asm-pop-multiple asm-shiftop asm-logand asm-lognot asm-cmp/asr63
+                     asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-push-fpmultiple asm-pop-fpmultiple
+                     asm-indirect-jump asm-literal-jump
+                     asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
+                     asm-rp-header asm-rp-compact-header
+                     asm-indirect-call asm-condition-code
+                     asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc 
+                     asm-lock asm-lock+/- asm-cas asm-fence
+                     asm-fpop-2 asm-fpsqrt asm-c-simple-call
+                     asm-return asm-c-return asm-size
+                     asm-enter asm-foreign-call asm-foreign-callable
+                     asm-read-counter
+                     asm-inc-cc-counter
+                     signed9? unsigned12? aligned-offset? funkymask shifted16
+                     ; threaded version specific
+                     asm-get-tc
+                     asm-activate-thread asm-deactivate-thread asm-unactivate-thread
+                     ; machine dependent exports
+                     asm-kill)
+
+  (define ax-register?
+    (case-lambda
+      [(x) (record-case x [(reg) r #t] [else #f])]
+      [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])]))
+
+  (define-who ax-ea-reg-code
+    (lambda (ea)
+      (record-case ea
+        [(reg) r (reg-mdinfo r)]
+        [else (sorry! who "ea=~s" ea)])))
+
+  (define ax-register-list
+    (lambda (r*)
+      (fold-left
+        (lambda (a r) (fx+ a (fxsll 1 (reg-mdinfo r))))
+        0 r*)))
+
+  (define ax-reg?
+    (lambda (ea)
+      (record-case ea
+        [(reg) ignore #t]
+        [else #f])))
+
+  (define ax-imm?
+    (lambda (ea)
+      (record-case ea
+        [(imm) ignore #t]
+        [else #f])))
+
+  (define-who ax-imm-data
+    (lambda (ea)
+      (record-case ea
+        [(imm) (n) n]
+        [else (sorry! who "ax-imm-data ea=~s" ea)])))
+
+  ; define-op sets up assembly op macros--
+  ; the opcode and all other expressions are passed to the specified handler--
+  (define-syntax define-op
+    (lambda (x)
+      (syntax-case x ()
+        [(k op handler e ...)
+         (with-syntax ([op (construct-name #'k "asmop-" #'op)])
+           #'(define-syntax op
+               (syntax-rules ()
+                 [(_ mneu arg (... ...))
+                  (handler 'mneu e ... arg (... ...))])))])))
+
+  (define-syntax emit
+    (lambda (x)
+      (syntax-case x ()
+        [(k op x ...)
+         (with-syntax ([emit-op (construct-name #'k "asmop-" #'op)])
+           #'(emit-op op x ...))])))
+
+  ;;; note that the assembler isn't clever--you must be very explicit about
+  ;;; which flavor you want, and there are a few new varieties introduced
+  ;;; (commented-out opcodes are not currently used by the assembler--
+  ;;; spaces are left to indicate possible size extensions)
+
+  (define-op movzi   movzi-op #b10) ; 16-bit immediate, shifted
+  (define-op movki   movzi-op #b11) ; 16-bit immediate, shifted
+  (define-op movi    movi-op)  ; immediate encoded as a mask
+
+  (define-op addi  add-imm-op  #b0) ; selector is at bit 30 (op)
+  (define-op subi  add-imm-op  #b1)
+
+  (define-op andi  logical-imm-op  #b00)
+  (define-op orri  logical-imm-op  #b01)
+  (define-op eori  logical-imm-op  #b10)
+
+  (define-op add   binary-op  #b0)
+  (define-op sub   binary-op  #b1)
+  
+  (define-op and   logical-op  #b00)
+  (define-op orr   logical-op  #b01)
+  (define-op eor   logical-op  #b10)
+
+  (define-op cmp        cmp-op  #b1101011 #b00 0)
+  (define-op tst        cmp-op  #b1101010 #b00 0)
+  (define-op cmp/asr63  cmp-op  #b1101011 #b10 63)
+  
+  (define-op cmpi  cmp-imm-op #b1) ; selector is at bit 30 (op)
+  (define-op cmni  cmp-imm-op #b0)
+  (define-op tsti  logical-imm-op #b11 #f `(reg . ,%real-zero))
+
+  (define-op mov   mov-op  #b1 #b0) ; selectors are a bit 31 (sf) and 21 (N)
+  (define-op movw  mov-op  #b0 #b0)
+  (define-op mvn   mov-op  #b1 #b1)
+
+  (define-op lsli  shifti-op #b10 'l) ; selector is at bit 29 (opc)
+  (define-op lsri  shifti-op #b10 'r) 
+  (define-op asri  shifti-op #b00 'r)
+
+  (define-op lsl  shift-op #b00) ; selector is at bit 10 (op2)
+  (define-op lsr  shift-op #b01) 
+  (define-op asr  shift-op #b10)
+
+  (define-op sxtb extend-op  #b100 #b1 #b000111) ; selectors are at bits 29 (sfc+opc), 22 (N), and 10 (imms)
+  (define-op sxth extend-op  #b100 #b1 #b001111)
+  (define-op sxtw extend-op  #b100 #b1 #b011111)
+  (define-op uxtb extend-op  #b010 #b0 #b000111)
+  (define-op uxth extend-op  #b010 #b0 #b001111)
+
+  (define-op mul   mul-op  #b000) ; selector is at bit 21
+  (define-op smulh mul-op  #b010)
+
+  (define-op sdiv  div-op)
+
+  ;; scaled variants (offset must be aligned):
+  (define-op ldri    load-imm-op  3 #b11 #b0 #b01) ; selectors are at bits 30 (size), 26, and 22 (opc)
+  (define-op ldrbi   load-imm-op  0 #b00 #b0 #b01)
+  (define-op ldrhi   load-imm-op  1 #b01 #b0 #b01)
+  (define-op ldrwi   load-imm-op  2 #b10 #b0 #b01)
+  (define-op ldrfi   load-imm-op  3 #b11 #b1 #b01)
+  (define-op ldrfsi  load-imm-op  2 #b10 #b1 #b01) ; single-precision
+
+  (define-op ldrsbi  load-imm-op  0 #b00 #b0 #b10)
+  (define-op ldrshi  load-imm-op  1 #b01 #b0 #b10)
+  (define-op ldrswi  load-imm-op  2 #b10 #b0 #b10)
+
+  (define-op stri    load-imm-op  3 #b11 #b0 #b00)
+  (define-op strbi   load-imm-op  0 #b00 #b0 #b00)
+  (define-op strhi   load-imm-op  1 #b01 #b0 #b00)
+  (define-op strwi   load-imm-op  2 #b10 #b0 #b00)
+  (define-op strfi   load-imm-op  3 #b11 #b1 #b00)
+  (define-op strfsi  load-imm-op  2 #b10 #b1 #b00) ; single-precision
+
+  ;; unscaled variants (offset must be signed9):
+  (define-op lduri    load-unscaled-imm-op  #b11 #b0 #b01) ; selectors are at bits 30 (size), 26, and 22 (opc)
+  (define-op ldurbi   load-unscaled-imm-op  #b00 #b0 #b01)
+  (define-op ldurhi   load-unscaled-imm-op  #b01 #b0 #b01)
+  (define-op ldurwi   load-unscaled-imm-op  #b10 #b0 #b01)
+  (define-op ldurfi   load-unscaled-imm-op  #b11 #b1 #b01)
+  (define-op ldurfsi  load-unscaled-imm-op  #b10 #b1 #b01) ; single-precision
+
+  (define-op ldursbi  load-unscaled-imm-op  #b00 #b0 #b10)
+  (define-op ldurshi  load-unscaled-imm-op  #b01 #b0 #b10)
+  (define-op ldurswi  load-unscaled-imm-op  #b10 #b0 #b10)
+
+  (define-op sturi    load-unscaled-imm-op  #b11 #b0 #b00)
+  (define-op sturbi   load-unscaled-imm-op  #b00 #b0 #b00)
+  (define-op sturhi   load-unscaled-imm-op  #b01 #b0 #b00)
+  (define-op sturwi   load-unscaled-imm-op  #b10 #b0 #b00)
+  (define-op sturfi   load-unscaled-imm-op  #b11 #b1 #b00)
+  (define-op sturfsi  load-unscaled-imm-op  #b10 #b1 #b00) ; single-precision
+  
+  (define-op ldr     load-op     #b11 #b0 #b01)  ; selectors are at bits 30 (size), 26, and 22 (opc)
+  (define-op ldrw    load-op     #b10 #b0 #b01)
+  (define-op ldrh    load-op     #b01 #b0 #b01)
+  (define-op ldrb    load-op     #b00 #b0 #b01)
+  (define-op ldrf    load-op     #b11 #b1 #b01)
+  (define-op ldrfs   load-op     #b10 #b1 #b01)
+
+  (define-op ldrsw   load-op     #b10 #b0 #b10)
+  (define-op ldrsh   load-op     #b01 #b0 #b10)
+  (define-op ldrsb   load-op     #b00 #b0 #b10)
+
+  (define-op str     load-op     #b11 #b0 #b00)
+  (define-op strw    load-op     #b10 #b0 #b00)
+  (define-op strh    load-op     #b01 #b0 #b00)
+  (define-op strb    load-op     #b00 #b0 #b00)
+  (define-op strf    load-op     #b11 #b1 #b00)
+  (define-op strfs   load-op     #b10 #b1 #b00)
+
+  (define-op ldr/postidx  load-idx-op  #b01 #b0 #b01) ; selectors are at bits 22 (opc), 26, and 10
+  (define-op str/preidx   load-idx-op  #b00 #b0 #b11)
+
+  (define-op ldrf/postidx load-idx-op  #b01 #b1 #b01)
+  (define-op strf/preidx  load-idx-op  #b00 #b1 #b11)
+
+  (define-op ldrp/postidx loadp-idx-op  #b10 #b0 #b001 #b1) ; selectors are at bits 30 (opc), 26, 23, and 22 (L)
+  (define-op strp/preidx  loadp-idx-op  #b10 #b0 #b011 #b0)
+
+  (define-op ldrpf/postidx loadp-idx-op  #b01 #b1 #b001 #b1)
+  (define-op strpf/preidx  loadp-idx-op  #b01 #b1 #b011 #b0)
+
+  (define-op ldxr   ldxr-op      #b1 `(reg . ,%real-zero))
+  (define-op stxr   ldxr-op      #b0)
+
+  (define-op dmbst    dmb-op #b1110)
+  (define-op dmbish   dmb-op #b1011)
+  (define-op dmbishld dmb-op #b1001)
+  (define-op dmbishst dmb-op #b1010)
+
+  (define-op bnei  branch-imm-op       (ax-cond 'ne))
+  (define-op beqi  branch-imm-op       (ax-cond 'eq))
+  (define-op brai  branch-imm-op       (ax-cond 'al))
+
+  (define-op br    branch-reg-op       #b00)
+  (define-op blr   branch-reg-op       #b01)
+
+  (define-op b     branch-always-label-op)
+
+  (define-op beq   branch-label-op     (ax-cond 'eq))
+  (define-op bne   branch-label-op     (ax-cond 'ne))
+  (define-op blt   branch-label-op     (ax-cond 'lt))
+  (define-op ble   branch-label-op     (ax-cond 'le))
+  (define-op bgt   branch-label-op     (ax-cond 'gt))
+  (define-op bge   branch-label-op     (ax-cond 'ge))
+  (define-op bcc   branch-label-op     (ax-cond 'cc))
+  (define-op bcs   branch-label-op     (ax-cond 'cs))
+  (define-op bvc   branch-label-op     (ax-cond 'vc))
+  (define-op bvs   branch-label-op     (ax-cond 'vs))
+  (define-op bls   branch-label-op     (ax-cond 'ls))
+  (define-op bhi   branch-label-op     (ax-cond 'hi))
+
+  (define-op adr   adr-op)
+  (define-op ret   ret-op)
+
+  (define-op fcvt.s->d  fcvt-op  #b00 #b01)
+  (define-op fcvt.d->s  fcvt-op  #b01 #b00)
+
+  (define-op fcvtzs  fdcvt-op  #b11 #b000) ; selectors are at bits 19 (mode) and 1 6(opcode)
+  (define-op scvtf   fdcvt-op  #b00 #b010)
+
+  (define-op fmov       fmov-op  #b0 #b000 #b1) ; selectors are at bits 31, 16, and 14
+  (define-op fmov.f->g  fmov-op  #b1 #b110 #b0)
+  (define-op fmov.g->f  fmov-op  #b1 #b111 #b0)
+
+  (define-op fcmp fcmp-op)
+
+  (define-op rev    rev-op  #b11) ; selector is at bit 10 (opc)
+  (define-op rev16  rev-op  #b01)
+  (define-op rev32  rev-op  #b10)
+
+  (define-op mrs  mrs-op)
+
+  (define-op fadd  f-arith-op  #b0010) ; selector is at bit 12
+  (define-op fsub  f-arith-op  #b0011)
+  (define-op fmul  f-arith-op  #b0000)
+  (define-op fdiv  f-arith-op  #b0001)
+
+  (define-op fsqrt fsqrt-op)
+
+  (define movzi-op
+    (lambda (op opc dest imm shift code*)
+      (emit-code (op dest imm shift code*)
+        [31 #b1]
+        [29 opc]
+        [23 #b100101]
+        [21 shift] ; `shift` is implicitly multiplied by 16
+        [5  imm]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define movi-op
+    (lambda (op dest imm n+immr+imms code*)
+      (let ([n (car n+immr+imms)]
+            [immr (cadr n+immr+imms)]
+            [imms (caddr n+immr+imms)])
+        (emit-code (op dest imm n+immr+imms code*)
+          [23 #b101100100]
+          [22 n]
+          [16 immr]
+          [10 imms]
+          [5  #b11111]
+          [0  (ax-ea-reg-code dest)]))))
+
+  (define add-imm-op
+    (lambda (op opcode set-cc? dest src imm code*)
+      (emit-code (op dest src imm (and set-cc? #t) code*)
+        [31 #b1]
+        [30 opcode]
+        [29 (if set-cc? #b1 #b0)]
+        [24 #b10001]
+        [22 #b00] ; shift
+        [10 imm]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define logical-imm-op
+    (lambda (op opcode set-cc? dest src imm code*)
+      (safe-assert (not set-cc?)) ; but opcode may imply setting condition codes
+      (let ([n+immr+imms (funkymask imm)])
+        (let ([n (car n+immr+imms)]
+              [immr (cadr n+immr+imms)]
+              [imms (caddr n+immr+imms)])
+          (emit-code (op dest src imm code*)
+            [31 #b1]
+            [29 opcode]
+            [23 #b100100]
+            [22 n]
+            [16 immr]
+            [10 imms]
+            [5  (ax-ea-reg-code src)]
+            [0  (ax-ea-reg-code dest)])))))
+
+  (define binary-op
+    (lambda (op opcode set-cc? dest src0 src1 code*)
+      (emit-code (op dest src0 src1 (and set-cc? #t) code*)
+        [31 #b1]
+        [30 opcode]
+        [29 (if set-cc? #b1 #b0)]
+        [24 #b01011]
+        [22 #b00] ; shift type (applied to src1)
+        [21 #b0]
+        [16 (ax-ea-reg-code src1)]
+        [10 #b000000] ; shift amount
+        [5  (ax-ea-reg-code src0)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define logical-op
+    (lambda (op opcode set-cc? dest src0 src1 code*)
+      (safe-assert (not set-cc?))
+      (emit-code (op dest src0 src1 code*)
+        [31 #b1]
+        [29 opcode]
+        [24 #b01010]
+        [22 #b00] ; shift type (applied to src1)
+        [21 #b0]
+        [16 (ax-ea-reg-code src1)]
+        [10 #b000000] ; shift amount
+        [5  (ax-ea-reg-code src0)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define cmp-op
+    (lambda (op opcode shift-type shift-amt src0 src1 code*)
+      (emit-code (op src0 src1 code*)
+        [31 #b1]
+        [24 opcode]
+        [22 shift-type] ; applied to src1
+        [21 #b0]
+        [16 (ax-ea-reg-code src1)]
+        [10 shift-amt]
+        [5  (ax-ea-reg-code src0)]
+        [0  #b11111])))
+
+  (define cmp-imm-op
+    (lambda (op opc src imm code*)
+      (safe-assert (unsigned12? imm))
+      (emit-code (op src imm code*)
+        [31 #b1]
+        [30 opc]
+        [24 #b110001]
+        [22 #b00] ; shift amount (applied to immediate)
+        [10 imm]
+        [5  (ax-ea-reg-code src)]
+        [0  #b11111])))
+
+  (define mov-op
+    (lambda (op sz neg dest src code*)
+      (emit-code (op dest src code*)
+        [31 sz]
+        [22 #b010101000]
+        [21 neg]
+        [16 (ax-ea-reg-code src)]
+        [5  #b11111]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define shifti-op
+    (lambda (op opcode dir dest src imm code*)
+      (emit-code (op dest src imm code*)
+        [31 #b1]
+        [29 opcode]
+        [22 #b1001101]
+        [16 (if (eq? dir 'l)
+                (fx- 64 imm)
+                imm)]
+        [10 (if (eq? dir 'l)
+                (fx- 63 imm)
+                63)]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define shift-op
+    (lambda (op opcode dest src0 src1 code*)
+      (emit-code (op dest src0 src1 code*)
+        [29 #b100]
+        [21 #b11010110]
+        [16 (ax-ea-reg-code src1)]
+        [12 #b0010]
+        [10 opcode]
+        [5  (ax-ea-reg-code src0)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define extend-op
+    (lambda (op sf+opc n imms-as-op2 dest src code*)
+      (emit-code (op dest src code*)
+        [29 sf+opc]
+        [23 #b100110]
+        [22 n]
+        [16 #b000000]
+        [10 imms-as-op2]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define mul-op
+    (lambda (op opcode dest src0 src1 code*)
+      (emit-code (op dest src0 src1 code*)
+        [29 #b100]
+        [24 #b11011]
+        [21 opcode]
+        [16 (ax-ea-reg-code src1)]
+        [10 #b011111]
+        [5  (ax-ea-reg-code src0)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define div-op
+    (lambda (op dest src0 src1 code*)
+      (emit-code (op dest src0 src1 code*)
+        [29 #b100]
+        [21 #b11010110]
+        [16 (ax-ea-reg-code src1)]
+        [10 #b000011]
+        [5  (ax-ea-reg-code src0)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define load-imm-op
+    (lambda (op scale size kind opc dest src imm code*)
+      (emit-code (op dest src imm code*)
+        [30 size]
+        [27 #b111]
+        [26 kind]
+        [24 #b01]
+        [22 opc]
+        [10 (fxsrl imm scale)]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define load-unscaled-imm-op
+    (lambda (op size kind opc dest src imm code*)
+      (emit-code (op dest src imm code*)
+        [30 size]
+        [27 #b111]
+        [26 kind]
+        [24 #b00]
+        [22 opc]
+        [21 #b0]
+        [12 (fxand imm #x1FF)]
+        [10 #b00]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define load-op
+    (lambda (op size kind opc dest src0 src1 code*)
+      (emit-code (op dest src0 src1 code*)
+        [30 size]
+        [27 #b111]
+        [26 kind]
+        [24 #b00]
+        [22 opc]
+        [21 #b1]
+        [16 (ax-ea-reg-code src1)]
+        [13 #b011] ; option, where #x011 => 64-bit source address
+        [12 #b0] ; shift
+        [10 #b10]
+        [5  (ax-ea-reg-code src0)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define load-idx-op
+    (lambda (op opc mode idx dest src imm code*)
+      (emit-code (op dest src imm code*)
+        [30 #b11]
+        [27 #b111]
+        [26 mode]
+        [24 #b00]
+        [22 opc]
+        [21 #b0]
+        [12 (fxand imm (fx- (fxsll 1 9) 1))]
+        [10 idx]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+    (define loadp-idx-op
+      (lambda (op opc mode opx l dest0 dest1 src imm code*)
+        (emit-code (op dest0 dest1 src imm code*)
+          [30 opc]
+          [27 #b101]
+          [26 mode]
+          [23 opx]
+          [22 l]
+          [15 (fxand (fxsrl imm 3) (fx- (fxsll 1 7) 1))]
+          [10 (ax-ea-reg-code dest1)]
+          [5  (ax-ea-reg-code src)]
+          [0 (ax-ea-reg-code dest0)])))
+
+  (define ldxr-op
+    (lambda (op mode dest2 dest src code*)
+      (emit-code (op dest2 dest src code*)
+        [30 #b11]
+        [23 #b0010000]
+        [22 mode]
+        [21 0]
+        [16 (ax-ea-reg-code dest2)]
+        [15 #b0]
+        [10 #b11111]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define dmb-op
+    (lambda (op mode code*)
+      (emit-code (op code*)
+        [22 #b1101010100]
+        [16 #b000011]
+        [12 #b0011]
+        [8  mode]
+        [5  #b101]
+        [0  #b11111])))
+
+  (define branch-imm-op
+    (lambda (op cond-bits imm code*)
+      (safe-assert (branch-disp? imm))
+      (emit-code (op imm code*)
+        [24 #b01010100]
+        [5  (fxand (fxsra imm 2) (fx- (fxsll 1 19) 1))]
+        [4  #b0]
+        [0  cond-bits])))
+
+  (define branch-reg-op
+    (lambda (op opcode reg code*)
+      (emit-code (op reg code*)
+        [24 #b11010110]
+        [23 #b0]
+        [21 opcode]
+        [16 #b11111]
+        [12 #b0000]
+        [10 #b00]
+        [5  (ax-ea-reg-code reg)]
+        [0  #b00000])))
+
+  (define-who branch-always-label-op
+    (lambda (op dest code*)
+      (record-case dest
+        [(label) (offset l)
+         (safe-assert (uncond-branch-disp? (+ offset 4)))
+         (emit-code (op dest code*)
+           [26 #b000101]
+           [0  (fxand (fxsra (fx+ offset 4) 2) (fx- (fxsll 1 26) 1))])]
+        [else (sorry! who "unexpected dest ~s" dest)])))
+
+  (define-who branch-label-op
+    (lambda (op cond-bits dest code*)
+      (define (emit-branch offset)
+	(safe-assert (branch-disp? (+ offset 4)))
+	(emit-code (op dest code*)
+          [24 #b01010100]
+	  [5  (fxand (fxsra (fx+ offset 4) 2) (fx- (fxsll 1 19) 1))]
+	  [4  #b0]
+	  [0  cond-bits]))
+      (record-case dest
+        [(label) (offset l) (emit-branch offset)]
+	[(imm) (n) (emit-branch n)] ; generated for long branches
+        [else (sorry! who "unexpected dest ~s" dest)])))
+
+  (define adr-op
+    (lambda (op dest imm code*)
+      (emit-code (op dest imm code*)
+        [31 #b0]
+        [29 (fxand imm #b11)]
+        [24 #b10000]
+        [5  (fxand (fxsra imm 2) (fx- (fxsll 1 19) 1))]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define ret-op
+    (lambda (op src code*)
+      (emit-code (op src code*)
+        [25 #b1101011]
+        [21 #b0010]
+        [16 #b11111]
+        [12 #b0000]
+        [10 #b00]
+        [5  (ax-ea-reg-code src)]
+        [0  #b00000])))
+
+  (define fcvt-op
+    (lambda (op type opc dest src code*)
+      (emit-code (op dest src code*)
+        [24 #b00011110]
+        [22 type]
+        [17 #b10001]
+        [15 opc]
+        [10 #b10000]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define fdcvt-op
+    (lambda (op mode opcode dest src code*)
+      (emit-code (op dest src code*)
+        [29 #b100]
+        [24 #b11110]
+        [22 #b01] ; type
+        [21 #b1]
+        [19 mode]
+        [16 opcode]
+        [10 #b000000]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define fmov-op
+    (lambda (op sf opcode opsel dest src code*)
+      (emit-code (op dest src code*)
+        [31 sf]
+        [24 #b0011110]
+        [22 #b01] ; type
+        [21 #b1]
+        [19 #b00]
+        [16 opcode]
+        [15 #b0]
+        [14 opsel]
+        [10 #b0000]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define f-arith-op
+    (lambda (op opcode dest src0 src1 code*)
+      (emit-code (op dest src0 src1 code*)
+        [29 #b000]
+        [24 #b11110]
+        [22 #b01] ; type
+        [21 #b1]
+        [16 (ax-ea-reg-code src1)]
+        [12 opcode]
+        [10 #b10]
+        [5  (ax-ea-reg-code src0)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define fsqrt-op
+    (lambda (op dest src code*)
+      (emit-code (op dest src code*)
+        [29 #b000]
+        [24 #b11110]
+        [22 #b01] ; type
+        [21 #b1]
+        [17 #b0000]
+        [15 #b11] ; opc
+        [10 #b10000]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define fcmp-op
+    (lambda (op src0 src1 code*)
+      (emit-code (op src0 src1 code*)
+        [24 #b00011110]
+        [22 #b01]
+        [21 #b1]
+        [16 (ax-ea-reg-code src1)]
+        [10 #b001000]
+        [5  (ax-ea-reg-code src0)]
+        [3  #b00] ; opc
+        [0  #b000])))
+
+  (define rev-op
+    (lambda (op opc dest src code*)
+      (emit-code (op dest src code*)
+        [29 #b110]
+        [21 #b11010110]
+        [16 #b00000]
+        [12 #b0000]
+        [10 opc]
+        [5  (ax-ea-reg-code src)]
+        [0  (ax-ea-reg-code dest)])))
+
+  (define mrs-op
+    (lambda (op op0 op1 crn crm op2 dest code*)
+      (emit-code (op dest code*)
+        [22 #b1101010100]
+        [20 #b11]
+        [19 op0]
+        [16 op1]
+        [12 crn]
+        [8  crm]
+        [5  op2]
+        [0 (ax-ea-reg-code dest)])))
+
+  ;; asm helpers
+
+  (define-who ax-cond
+    (lambda (x)
+      (case x
+        [(eq) #b0000] ; fl=
+        [(ne) #b0001]
+        [(cs) #b0010] ; u<
+        [(cc) #b0011] ; u>=, fl< (for fl<, do we need this and mi?)
+        [(mi) #b0100] ; fl< (for fl<, do we need this and cc?)
+        [(pl) #b0101]
+        [(vs) #b0110]
+        [(vc) #b0111]
+        [(hi) #b1000] ; u>
+        [(ls) #b1001] ; u<=, fl<=
+        [(ge) #b1010] ; fl>=
+        [(lt) #b1011]
+        [(gt) #b1100] ; fl>
+        [(le) #b1101]
+        [(al) #b1110]
+        [else (sorry! who "unrecognized cond name ~s" x)])))
+
+  (define-syntax emit-code
+    (lambda (x)
+      ; NB: probably won't need emit-code to weed out #f
+      (define build-maybe-cons*
+        (lambda (e* e-ls)
+          (if (null? e*)
+              e-ls
+              #`(let ([t #,(car e*)] [ls #,(build-maybe-cons* (cdr e*) e-ls)])
+                  (if t (cons t ls) ls)))))
+      (syntax-case x ()
+        [(_ (op opnd ... ?code*) chunk ...)
+         (let ([safe-check (lambda (e)
+                             (if (fx= (debug-level) 0)
+                                 e
+                                 #`(let ([code #,e])
+                                     (unless (<= 0 code (sub1 (expt 2 32)))
+                                       (sorry! 'emit-code "bad result ~s for ~s"
+                                               code
+                                               (list op opnd ...)))
+                                     code)))])
+           (build-maybe-cons* #`((build long #,(safe-check #`(byte-fields chunk ...))))
+             #'(aop-cons* `(asm ,op ,opnd ...) ?code*)))])))
+
+  (define-syntax build
+    (syntax-rules ()
+      [(_ x e)
+       (and (memq (datum x) '(byte word long)) (integer? (datum e)))
+       (begin
+         (safe-assert (fixnum? (datum e)))
+         (quote (x . e)))]
+      [(_ x e)
+       (memq (datum x) '(byte word long))
+       (cons 'x e #;(let ([x e]) (safe-assert (not (eqv? x #x53401c17))) x))]))
+
+  (define-syntax byte-fields
+    ; NB: make more efficient for fixnums
+    (syntax-rules ()
+      [(byte-fields (n e) ...)
+       (andmap fixnum? (datum (n ...)))
+       (+ (bitwise-arithmetic-shift-left e n) ...)]))
+
+  (define signed9?
+    (lambda (imm)
+      (and (fixnum? imm) (fx<= (fx- (expt 2 8)) imm (fx- (expt 2 8) 1)))))
+
+  (define unsigned12?
+    (lambda (imm)
+      (and (fixnum? imm)  ($fxu< imm (expt 2 12)))))
+
+  (define aligned-offset?
+    (case-lambda
+     [(imm) (aligned-offset? imm (constant log2-ptr-bytes))]
+     [(imm log2-bytes)
+      (and (fixnum? imm)
+           (eqv? 0 (fxand imm (fx- (fxsll 1 log2-bytes) 1)))
+           ($fxu< imm (expt 2 (fx+ 12 log2-bytes))))]))
+
+  (define funkymask
+    (lambda (imm)
+      ;; encode as `(list N immr imms)`, based on the LLVM implementation.
+      (cond
+        [(eqv? imm 0) #f]  ; can't do all 0s
+        [(eqv? imm -1) #f] ; can't do all 1s
+        [(>= imm (sub1 (expt 2 63))) #f]  ; can't do all 1s or more
+        [(<= imm (- (expt 2 63))) #f] ; can't less than most negative
+        [else
+         ;; Immediate is representable in 64 bits without being 0 or -1.
+         ;; First, find the smallest width that can be replicated to match `imm`:
+         (let* ([imm (bitwise-and imm (sub1 (expt 2 64)))] ; view as positive
+                [width (let loop ([width 32])
+                        (let ([mask (sub1 (bitwise-arithmetic-shift-left 1 width))])
+                          (if (= (bitwise-and imm mask)
+                                 (bitwise-and (bitwise-arithmetic-shift-right imm width) mask))
+                              (if (fx= width 2)
+                                  2
+                                  (loop (fxsrl width 1)))
+                              (fx* width 2))))])
+           (let ([v (bitwise-and imm (sub1 (bitwise-arithmetic-shift-left 1 width)))])
+             ;; The encoding will work if v matches 1*0*1* or 0*1*0*
+             (let* ([count-trailing (lambda (val v)
+                                      (let loop ([v v])
+                                        (if (= val (bitwise-and v 1))
+                                            (fx+ 1 (loop (bitwise-arithmetic-shift-right v 1)))
+                                            0)))]
+                    [0s (count-trailing 0 v)]
+                    [1s (count-trailing 1 (bitwise-arithmetic-shift-right v 0s))]
+                    [vx (bitwise-arithmetic-shift-right v (fx+ 0s 1s))])
+               (let-values ([(rotate total-1s)
+                             (cond
+                               [(eqv? 0 vx)
+                                (if (fx= 0s 0)
+                                    ;; No rotation needed
+                                    (values 0 1s)
+                                    ;; Rotate left to fill in `0s` zeros, and the encoding works
+                                    (values (fx- width 0s) 1s))]
+                               [(eqv? 0 0s)
+                                ;; There could be more 1s at the top that we can rotate around
+                                (let* ([0s (count-trailing 0 vx)])
+                                  ;; Assert: 0s < width - 1s
+                                  (cond
+                                    [(= (bitwise-arithmetic-shift vx 0s)
+                                        (sub1 (bitwise-arithmetic-shift-left 1 (fx- width 0s 1s))))
+                                     ;; All 1s are in lowest bits or highest bits, so rotate
+                                     (values (fx- width 0s 1s)
+                                             (fx- width 0s))]
+                                    [else (values #f #f)]))]
+                               [else (values #f #f)])])
+                 (and rotate
+                      (list (if (fx= width 64) 1 0)
+                            rotate
+                            (bitwise-ior (case width
+                                           [(2)  #b111100]
+                                           [(4)  #b111000]
+                                           [(8)  #b110000]
+                                           [(16) #b100000]
+                                           [else 0])
+                                         (fx- total-1s 1))))))))])))
+
+  (define shifted16
+    (lambda (imm)
+      (let loop ([shift 0])
+        (and (fx< shift 4)
+             (if (= imm (bitwise-and (bitwise-arithmetic-shift-left #xFFFF (fx* shift 16)) imm))
+                 (cons (bitwise-arithmetic-shift-right imm (fx* shift 16)) shift)
+                 (loop (fx+ shift 1)))))))
+
+  (define branch-disp?
+    (lambda (x)
+      (and (fixnum? x) 
+           (fx<= (- (expt 2 20)) x (- (expt 2 20) 1))
+           (not (fxlogtest x #b11)))))
+
+  (define uncond-branch-disp?
+    (lambda (x)
+      (and (fixnum? x) 
+           (fx<= (- (expt 2 26)) x (- (expt 2 20) 1))
+           (not (fxlogtest x #b11)))))
+  
+  (define asm-size
+    (lambda (x)
+      (case (car x)
+        [(asm arm64-abs arm64-jump arm64-call) 0]
+        [(long) 4]
+        [else 8])))
+
+  (define ax-mov64
+    (lambda (dest n code*)
+      (emit movzi dest (logand n #xffff) 0
+        (emit movki dest (logand (bitwise-arithmetic-shift-right n 16) #xffff) 1
+          (emit movki dest (logand (bitwise-arithmetic-shift-right n 32) #xffff) 2
+            (emit movki dest (logand (bitwise-arithmetic-shift-right n 48) #xffff) 3
+               code*))))))
+
+  (define ax-movi
+    (lambda (dest n code*) 
+      (cond
+        [(shifted16 n) =>
+         (lambda (imm+shift)
+           (emit movzi dest (car imm+shift) (cdr imm+shift) code*))]
+        [(funkymask n) =>
+         (lambda (n+immr+imms)
+           (emit movi dest n n+immr+imms code*))]
+        [(unsigned12? n)
+         (emit movzi dest 0 0
+           (emit addi #f dest dest n code*))]
+        [(unsigned12? (- n))
+         (emit movzi dest 0 0
+           (emit subi #f dest dest (- n) code*))]
+        [else
+         (let loop ([n n] [shift 0] [init? #t])
+           (cond
+             [(or (eqv? n 0) (fx= shift 4)) code*]
+             [else
+              (let ([m (logand n #xFFFF)])
+                (cond
+                  [(eqv? m 0)
+                   (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) init?)]
+                  [else
+                   (let ([code* (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) #f)])
+                     (if init?
+                         (emit movzi dest m shift code*)
+                         (emit movki dest m shift code*)))]))]))])))
+
+  (define-who asm-move
+    (lambda (code* dest src)
+      ;; move pseudo instruction used by set! case in select-instruction
+      ;; guarantees dest is a reg and src is reg, mem, or imm OR dest is
+      ;; mem and src is reg.
+      (Trivit (dest src)
+        (define (bad!) (sorry! who "unexpected combination of src ~s and dest ~s" src dest))
+        (cond
+          [(ax-reg? dest)
+           (record-case src
+             [(reg) ignore (emit mov dest src code*)]
+             [(imm) (n)
+              (ax-movi dest n code*)]
+             [(literal) stuff
+              (ax-mov64 dest 0
+                (asm-helper-relocation code* (cons 'arm64-abs stuff)))]
+             [(disp) (n breg)
+              (cond
+                [(aligned-offset? n)
+                 (emit ldri dest `(reg . ,breg) n code*)]
+                [else
+                 (assert (signed9? n))
+                 (emit lduri dest `(reg . ,breg) n code*)])]
+             [(index) (n ireg breg)
+              (safe-assert (eqv? n 0))
+              (emit ldr dest `(reg . ,breg) `(reg . ,ireg) code*)]
+             [else (bad!)])]
+          [(ax-reg? src)
+           (record-case dest
+             [(disp) (n breg)
+              (cond
+                [(aligned-offset? n)
+                 (emit stri src `(reg . ,breg) n code*)]
+                [else
+                 (assert (signed9? n))
+                 (emit sturi src `(reg . ,breg) n code*)])]
+             [(index) (n ireg breg)
+              (safe-assert (eqv? n 0))
+              (emit str src `(reg . ,breg) `(reg . ,ireg) code*)]
+             [else (bad!)])]
+          [else (bad!)]))))
+
+  (define-who asm-move/extend
+    (lambda (op)
+      (lambda (code* dest src)
+        (Trivit (dest src)
+          (case op
+            [(sext8) (emit sxtb dest src code*)]
+            [(sext16) (emit sxth dest src code*)]
+            [(sext32) (emit sxtw dest src code*)]
+            [(zext8) (emit uxtb dest src code*)]
+            [(zext16) (emit uxth dest src code*)]
+            [(zext32) (emit movw dest src code*)] ; movw zero-extends
+            [else (sorry! who "unexpected op ~s" op)])))))
+
+  (module (asm-add asm-sub asm-logand asm-logor asm-logxor)
+    (define-syntax asm-binop
+      (syntax-rules ()
+        [(_ opi op)
+         (lambda (set-cc?)
+           (lambda (code* dest src0 src1)
+             (Trivit (dest src0 src1)
+               (record-case src1
+                 [(imm) (n) (emit opi set-cc? dest src0 n code*)]
+                 [else (emit op set-cc? dest src0 src1 code*)]))))]))
+
+    (define asm-add (asm-binop addi add))
+    (define asm-sub (asm-binop subi sub))
+    (define asm-logand (asm-binop andi and))
+    (define asm-logor (asm-binop orri orr))
+    (define asm-logxor (asm-binop eori eor)))
+
+  (define asm-mul
+    (lambda (code* dest src0 src1)
+      (Trivit (dest src0 src1)
+        (emit mul dest src0 src1 code*))))
+
+  (define asm-div
+    (lambda (code* dest src0 src1)
+      (Trivit (dest src0 src1)
+        (emit sdiv dest src0 src1 code*))))
+
+  (define asm-smulh
+    (lambda (code* dest src0 src1)
+      (Trivit (dest src0 src1)
+        (emit smulh dest src0 src1 code*))))
+
+  (define-who asm-cmp/asr63
+    (lambda (code* src0 src1)
+      (Trivit (src0 src1)
+        (emit cmp/asr63 src0 src1 code*))))
+
+  (define-who asm-fl-cvt
+    (lambda (op)
+      (lambda (code* dest src)
+        (Trivit (dest src)
+          (case op
+            [(single->double)
+             (emit fcvt.s->d dest src code*)]
+            [(double->single)
+             (emit fcvt.d->s dest src code*)]
+            [else (sorry! who "unrecognized op ~s" op)])))))
+
+  (define-who asm-load
+    (lambda (type)
+      (rec asm-load-internal
+        (lambda (code* dest base index offset)
+          (let ([n (nanopass-case (L16 Triv) offset
+                     [(immediate ,imm) imm]
+                     [else (sorry! who "unexpected non-immediate offset ~s" offset)])])
+            ;; Assuming that `n` is either aligned and in range (fits
+            ;; unsigned in 12 bits after shifting by type bits) or unaligned
+            ;; and small (fits in 9 bits)
+            (Trivit (dest base)
+              (cond
+                [(eq? index %zero)
+                 (cond
+                   [(signed9? n)
+                    (case type
+                      [(integer-64 unsigned-64) (emit lduri dest base n code*)]
+                      [(integer-32) (emit ldurswi dest base n code*)]
+                      [(unsigned-32) (emit ldurwi dest base n code*)]
+                      [(integer-16) (emit ldurshi dest base n code*)]
+                      [(unsigned-16) (emit ldurhi dest base n code*)]
+                      [(integer-8) (emit ldursbi dest base n code*)]
+                      [(unsigned-8) (emit ldurbi dest base n code*)]
+                      [else (sorry! who "unexpected mref type ~s" type)])]
+                   [else
+                    (case type
+                      [(integer-64 unsigned-64) (emit ldri dest base n code*)]
+                      [(integer-32) (emit ldrswi dest base n code*)]
+                      [(unsigned-32) (emit ldrwi dest base n code*)]
+                      [(integer-16) (emit ldrshi dest base n code*)]
+                      [(unsigned-16) (emit ldrhi dest base n code*)]
+                      [(integer-8) (emit ldrsbi dest base n code*)]
+                      [(unsigned-8) (emit ldrbi dest base n code*)]
+                      [else (sorry! who "unexpected mref type ~s" type)])])]
+                [(eqv? n 0)
+                  (Trivit (index)
+                    (case type
+                      [(integer-64 unsigned-64) (emit ldr dest base index code*)]
+                      [(integer-32) (emit ldrsw dest base index code*)]
+                      [(unsigned-32) (emit ldrw dest base index code*)]
+                      [(integer-16) (emit ldrsh dest base index code*)]
+                      [(unsigned-16) (emit ldrh dest base index code*)]
+                      [(integer-8) (emit ldrsb dest base index code*)]
+                      [(unsigned-8) (emit ldrb dest base index code*)]
+                      [else (sorry! who "unexpected mref type ~s" type)]))]
+                [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))
+
+  (define-who asm-store
+    (lambda (type)
+      (rec asm-store-internal
+        (lambda (code* base index offset src)
+          (let ([n (nanopass-case (L16 Triv) offset
+                     [(immediate ,imm) imm]
+                     [else (sorry! who "unexpected non-immediate offset ~s" offset)])])
+            ;; Assuming that `n` is aligned and in range (fits
+            ;; unsigned in 12 bits after shifting by type bits)
+            (Trivit (src base)
+              (cond
+                [(eq? index %zero)
+                 (cond
+                   [(signed9? n)
+                    (case type
+                      [(integer-64 unsigned-64) (emit sturi src base n code*)]
+                      [(integer-32 unsigned-32) (emit sturwi src base n code*)]
+                      [(integer-16 unsigned-16) (emit sturhi src base n code*)]
+                      [(integer-8 unsigned-8) (emit sturbi src base n code*)]
+                      [else (sorry! who "unexpected mref type ~s" type)])]
+                   [else
+                    (case type
+                      [(integer-64 unsigned-64) (emit stri src base n code*)]
+                      [(integer-32 unsigned-32) (emit strwi src base n code*)]
+                      [(integer-16 unsigned-16) (emit strhi src base n code*)]
+                      [(integer-8 unsigned-8) (emit strbi src base n code*)]
+                      [else (sorry! who "unexpected mref type ~s" type)])])]
+                [(eqv? n 0)
+                  (Trivit (index)
+                    (case type
+                      [(integer-64 unsigned-64) (emit str src base index code*)]
+                      [(integer-32 unsigned-32) (emit strw src base index code*)]
+                      [(integer-16 unsigned-16) (emit strh src base index code*)]
+                      [(integer-8 unsigned-8) (emit strb src base index code*)]
+                      [else (sorry! who "unexpected mref type ~s" type)]))]
+                [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))
+
+  (define-who asm-fpop-2
+    (lambda (op)
+      (lambda (code* dest src1 src2)
+        (Trivit (dest src1 src2)
+          (case op
+            [(fp+) (emit fadd dest src1 src2 code*)]
+            [(fp-) (emit fsub dest src1 src2 code*)]
+            [(fp*) (emit fmul dest src1 src2 code*)]
+            [(fp/) (emit fdiv dest src1 src2 code*)]
+            [else (sorry! who "unrecognized op ~s" op)])))))
+
+  (define asm-fpsqrt
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit fsqrt dest src code*))))
+
+  (define asm-fptrunc
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit fcvtzs dest src code*))))
+
+  (define asm-fpt
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit scvtf dest src code*))))
+
+  (define-who asm-fpmove
+    ;; fpmove pseudo instruction is used by set! case in
+    ;; select-instructions! and generate-code; at most one of src or
+    ;; dest can be an mref, and then the offset is double-aligned
+    (lambda (code* dest src)
+      (gen-fpmove who code* dest src #t)))
+
+  (define-who asm-fpmove-single
+    (lambda (code* dest src)
+      (gen-fpmove who code* dest src #f)))
+
+  (define gen-fpmove
+    (lambda (who code* dest src double?)
+      (Trivit (dest src)
+        (record-case dest
+          [(disp) (imm reg)
+           (if double?
+               (cond
+                 [(aligned-offset? imm)
+                  (emit strfi src (cons 'reg reg) imm code*)]
+                 [else
+                  (safe-assert (signed9? imm))
+                  (emit sturfi src (cons 'reg reg) imm code*)])
+               (cond
+                 [(aligned-offset? imm 2)
+                  (emit strfsi src (cons 'reg reg) imm code*)]
+                 [else
+                  (safe-assert (signed9? imm))
+                  (emit sturfsi src (cons 'reg reg) imm code*)]))]
+          [(index) (n ireg breg)
+           (cond
+             [(fx= n 0)
+              (if double?
+                  (emit strf src (cons 'reg ireg) (cons 'reg breg) code*)
+                  (emit strfs src (cons 'reg ireg) (cons 'reg breg) code*))]
+             [else
+              (sorry! who "cannot handle indexed fp dest ref")])]
+          [else
+           (record-case src
+             [(disp) (imm reg)
+              (if double?
+                  (cond
+                    [(aligned-offset? imm)
+                     (emit ldrfi dest (cons 'reg reg) imm code*)]
+                    [else
+                     (safe-assert (signed9? imm))
+                     (emit ldurfi dest (cons 'reg reg) imm code*)])
+                  (cond
+                    [(aligned-offset? imm 2)
+                     (emit ldrfsi dest (cons 'reg reg) imm code*)]
+                    [else
+                     (safe-assert (signed9? imm))
+                     (emit ldurfsi dest (cons 'reg reg) imm code*)]))]
+             [(index) (n ireg breg)
+              (cond
+                [(fx= n 0)
+                 (if double?
+                     (emit ldrf dest (cons 'reg ireg) (cons 'reg breg) code*)
+                     (emit ldrfs dest (cons 'reg ireg) (cons 'reg breg) code*))]
+                [else
+                 (sorry! who "cannot handle indexed fp src ref")])]
+             [else (emit fmov dest src code*)])]))))
+
+  (define asm-fpcastto
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit fmov.f->g dest src code*))))  
+
+  (define asm-fpcastfrom
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit fmov.g->f dest src code*))))
+
+  (define-who asm-swap
+    (lambda (type)
+      (rec asm-swap-internal
+        (lambda (code* dest src)
+          (Trivit (dest src)
+            (case type
+              [(integer-16) (emit rev16 dest src
+                              (emit sxth dest dest code*))]
+              [(unsigned-16) (emit rev16 dest src
+                               (emit uxth dest dest code*))]
+              [(integer-32) (emit rev32 dest src
+                              (emit sxtw dest dest code*))]
+              [(unsigned-32) (emit rev32 dest src
+                               (emit movw dest dest code*))]
+              [(integer-64 unsigned-64) (emit rev dest src code*)]
+              [else (sorry! who "unexpected asm-swap type argument ~s" type)]))))))
+
+  (define asm-lock
+    ;  tmp = 1 # in case load result is not 0
+    ;  tmp2 = ldxr src
+    ;  cmp tmp2, 0
+    ;  bne L1
+    ;  tmp2 = 1
+    ;  tmp = stxr tmp2, src
+    ;L1:
+    (lambda (code* src tmp tmp2)
+      (Trivit (src tmp tmp2)
+        (emit movzi tmp 1 0
+          (emit ldxr tmp2 src
+            (emit cmpi tmp2 0
+              (emit bnei 12
+                (emit movzi tmp2 1 0
+                  (emit stxr tmp tmp2 src code*)))))))))
+
+  (define-who asm-lock+/-
+    ; L:
+    ;   tmp1 = ldxr src
+    ;   tmp1 = tmp1 +/- 1
+    ;   tmp2 = stxr tmp1, src
+    ;   cmp tmp2, 0
+    ;   bne L
+    ;   cmp tmp1, 0
+    (lambda (op)
+      (lambda (code* src tmp1 tmp2)
+        (Trivit (src tmp1 tmp2)
+          (emit ldxr tmp1 src
+            (let ([code* (emit stxr tmp2 tmp1 src
+                           (emit cmpi tmp2 0
+                             (emit bnei -16
+                               (emit cmpi tmp1 0 code*))))])
+              (case op
+                [(locked-incr!) (emit addi #f tmp1 tmp1 1 code*)]
+                [(locked-decr!) (emit subi #f tmp1 tmp1 1 code*)]
+                [else (sorry! who "unexpected op ~s" op)])))))))
+
+  (define-who asm-cas
+    ;   tmp = ldxr src
+    ;   cmp tmp, old
+    ;   bne L
+    ;   tmp2 = stxr new, src
+    ;   cmp tmp2, 0
+    ; L:
+    (lambda (code* src old new tmp1 tmp2)
+      (Trivit (src old new tmp1 tmp2)
+        (emit ldxr tmp1 src
+          (emit cmp tmp1 old
+            (emit bnei 12
+              (emit stxr tmp2 new src
+                (emit cmpi tmp2 0
+                   code*))))))))
+
+  ;; Based in part on https://www.cl.cam.ac.uk/~pes20/cpp/cpp0xmappings.html
+  (define-who asm-fence
+    (lambda (kind)
+      (lambda (code*)
+        (case kind
+          [(store-store) (emit dmbishst code*)]
+          [(acquire) (emit dmbishld code*)]
+          [(release) (emit dmbish code*)]
+          [else (sorry! who "unexpected kind ~s" kind)]))))
+
+  (define asm-fp-relop
+    (lambda (info)
+      (lambda (l1 l2 offset x y)
+        (Trivit (x y)
+          (values
+           (emit fcmp x y '())
+           (asm-conditional-jump info l1 l2 offset))))))
+
+  (define-who asm-relop
+    (lambda (info negated-imm?)
+      (rec asm-relop-internal
+        (lambda (l1 l2 offset x y)
+          (Trivit (x y)
+            (unless (ax-reg? x) (sorry! who "unexpected first operand ~s" x))
+            (values
+              (record-case y
+                [(imm) (n) (if negated-imm?
+                               (emit cmni x n '())
+                               (emit cmpi x n '()))]
+                [(reg) ignore (safe-assert (not negated-imm?)) (emit cmp x y '())]
+                [else (sorry! who "unexpected second operand ~s" y)])
+              (asm-conditional-jump info l1 l2 offset)))))))
+
+  (define asm-condition-code
+    (lambda (info)
+      (rec asm-check-flag-internal
+        (lambda (l1 l2 offset)
+          (values '() (asm-conditional-jump info l1 l2 offset))))))
+
+  (define asm-pop-multiple
+    (lambda (regs)
+      (lambda (code*)
+        (asm-multiple regs #t code*
+                      (lambda (sp reg code*)
+                        (emit ldr/postidx reg sp 16 code*))
+                      (lambda (sp reg1 reg2 code*)
+                        (emit ldrp/postidx reg1 reg2 sp 16 code*))))))
+
+  (define asm-push-multiple
+    (lambda (regs)
+      (lambda (code*)
+        (asm-multiple regs #f code*
+                      (lambda (sp reg code*)
+                        (emit str/preidx reg sp -16 code*))
+                      (lambda (sp reg1 reg2 code*)
+                        (emit strp/preidx reg1 reg2 sp -16 code*))))))
+
+  (define asm-pop-fpmultiple
+    (lambda (regs)
+      (lambda (code*)
+        (asm-multiple regs #t code*
+                      (lambda (sp reg code*)
+                        (emit ldrf/postidx reg sp 16 code*))
+                      (lambda (sp reg1 reg2 code*)
+                        (emit ldrpf/postidx reg1 reg2 sp 16 code*))))))
+
+  (define asm-push-fpmultiple
+    (lambda (regs)
+      (lambda (code*)
+        (asm-multiple regs #f code*
+                      (lambda (sp reg code*)
+                        (emit strf/preidx reg sp -16 code*))
+                      (lambda (sp reg1 reg2 code*)
+                        (emit strpf/preidx reg1 reg2 sp -16 code*))))))
+
+  (define (asm-multiple regs rev? code* one two)
+    (let ([sp `(reg . ,%sp)])
+      (let loop ([regs regs] [code* code*])
+        (cond
+          [(null? regs) code*]
+          [(null? (cdr regs))
+           (one sp (cons 'reg (car regs)) code*)]
+          [rev?
+           (two sp (cons 'reg (car regs)) (cons 'reg (cadr regs)) (loop (cddr regs) code*))]
+          [else
+           (loop (cddr regs) (two sp (cons 'reg (car regs)) (cons 'reg (cadr regs)) code*))]))))
+
+  (define asm-read-counter
+    (lambda (op0 op1 crn crm op2)
+      (lambda (code* dest)
+        (Trivit (dest)
+          (emit mrs op0 op1 crn crm op2 dest code*)))))
+
+  (define asm-library-jump
+    (lambda (l)
+      (asm-helper-jump '()
+        `(arm64-jump ,(constant code-data-disp) (library-code ,(libspec-label-libspec l))))))
+
+  (define asm-library-call
+    (lambda (libspec save-ra?)
+      (let ([target `(arm64-call ,(constant code-data-disp) (library-code ,libspec))])
+        (rec asm-asm-call-internal
+          (lambda (code* dest . ignore) ; ignore arguments, which must be in fixed locations
+            (asm-helper-call code* target save-ra?))))))
+
+  (define asm-library-call!
+    (lambda (libspec save-ra?)
+      (let ([target `(arm64-call ,(constant code-data-disp) (library-code ,libspec))])
+        (rec asm-asm-call-internal
+          (lambda (code* . ignore) ; ignore arguments, which must be in fixed locations
+            (asm-helper-call code* target save-ra?))))))
+
+  (define asm-c-simple-call
+    (lambda (entry save-ra?)
+      (let ([target `(arm64-call 0 (entry ,entry))])
+        (rec asm-c-simple-call-internal
+          (lambda (code* . ignore)
+            (asm-helper-call code* target save-ra?))))))
+    
+  (define-who asm-indirect-call
+    (lambda (code* dest lr . ignore)
+      (safe-assert (eq? lr %lr))
+      (Trivit (dest)
+        (unless (ax-reg? dest) (sorry! who "unexpected dest ~s" dest))
+        (emit blr dest code*))))
+
+  (define asm-direct-jump
+    (lambda (l offset)
+      (let ([offset (adjust-return-point-offset offset l)])
+        (asm-helper-jump '() (make-funcrel 'arm64-jump l offset)))))
+
+  (define asm-literal-jump
+    (lambda (info)
+      (asm-helper-jump '()
+        `(arm64-jump ,(info-literal-offset info) (,(info-literal-type info) ,(info-literal-addr info))))))
+
+  (define-who asm-indirect-jump
+    (lambda (src)
+      (Trivit (src)
+        (record-case src
+          [(reg) ignore (emit br src '())]
+          [(disp) (n breg)
+           (cond
+             [(signed9? n)
+              (emit lduri `(reg . ,%jmptmp) `(reg . ,breg) n
+                 (emit br `(reg . ,%jmptmp) '()))]
+             [(aligned-offset? n)
+              (emit ldri `(reg . ,%jmptmp) `(reg . ,breg) n
+                 (emit br `(reg . ,%jmptmp) '()))]
+             [else
+              (safe-assert (or (unsigned12? n) (unsigned12? (- n))))
+              (let ([code* (emit ldri `(reg . ,%jmptmp) `(reg . ,%jmptmp) 0
+                             (emit br `(reg . ,%jmptmp) '()))])
+                (if (unsigned12? n)
+                    (emit addi #f `(reg . ,%jmptmp) `(reg . ,breg) n code*)
+                    (emit subi #f `(reg . ,%jmptmp) `(reg . ,breg) (- n) code*)))])]
+          [(index) (n ireg breg)
+           (safe-assert (eqv? n 0))
+           (emit ldr `(reg . ,%jmptmp) `(reg . ,breg) `(reg . ,ireg)
+             (emit br `(reg . ,%jmptmp) '()))]
+          [else (sorry! who "unexpected src ~s" src)]))))
+
+  (define asm-logtest
+    (lambda (i? info)
+      (lambda (l1 l2 offset x y)
+        (Trivit (x y)
+          (values
+            (record-case y
+              [(imm) (n) (emit tsti x n '())]
+              [else (emit tst x y '())])
+            (let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))])
+              (asm-conditional-jump info l2 l1 offset)))))))
+
+  (define asm-get-tc
+    (let ([target `(arm64-call 0 (entry ,(lookup-c-entry get-thread-context)))])
+      (lambda (code* dest . ignore) ; dest is ignored, since it is always Cretval
+        (asm-helper-call code* target #f))))
+
+  (define asm-activate-thread
+    (let ([target `(arm64-call 0 (entry ,(lookup-c-entry activate-thread)))])
+      (lambda (code* dest . ignore)
+        (asm-helper-call code* target #t))))
+
+  (define asm-deactivate-thread
+    (let ([target `(arm64-call 0 (entry ,(lookup-c-entry deactivate-thread)))])
+      (lambda (code* . ignore)
+        (asm-helper-call code* target #f))))
+
+  (define asm-unactivate-thread
+    (let ([target `(arm64-call 0 (entry ,(lookup-c-entry unactivate-thread)))])
+      (lambda (code* arg-reg . ignore)
+        (asm-helper-call code* target #f))))
+
+  (define-who asm-return-address
+    (lambda (dest l incr-offset next-addr)
+      (make-rachunk dest l incr-offset next-addr
+        (or (cond
+              [(local-label-offset l) =>
+               (lambda (offset)
+                 (let ([incr-offset (adjust-return-point-offset incr-offset l)])
+                   (let ([disp (fx+ (fx- next-addr (fx- offset incr-offset)) 4)])
+                     (cond
+                       [($fxu< disp (expt 2 21))
+                        (Trivit (dest)
+                          (emit adr dest disp '()))]
+                      [else #f]))))]
+              [else #f])
+            (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))))))
+
+  (define-who asm-jump
+    (lambda (l next-addr)
+      (make-gchunk l next-addr
+        (cond
+          [(local-label-offset l) =>
+           (lambda (offset)
+             (let ([disp (fx- next-addr offset)])
+               (cond
+                 [(eqv? disp 0) '()]
+                 [(uncond-branch-disp? disp) (emit b `(label ,disp ,l) '())]
+                 [else (sorry! who "no support for code objects > 256MB in length")])))]
+          [else
+            ;; label must be somewhere above.  generate something so that a hard loop
+            ;; doesn't get dropped.  this also has some chance of being the right size
+            ;; for the final branch instruction.
+            (emit b `(label 0 ,l) '())]))))
+
+  (define-who asm-conditional-jump
+    (lambda (info l1 l2 next-addr)
+      (define get-disp-opnd
+        (lambda (next-addr l)
+          (if (local-label? l)
+              (cond
+                [(local-label-offset l) =>
+                 (lambda (offset)
+                   (let ([disp (fx- next-addr offset)])
+                     (values disp `(label ,disp ,l))))]
+                [else (values 0 `(label 0 ,l))])
+              (sorry! who "unexpected label ~s" l))))
+      (let ([type (info-condition-code-type info)]
+            [reversed? (info-condition-code-reversed? info)])
+        (make-cgchunk info l1 l2 next-addr
+          (let ()
+            (define-syntax pred-case
+              (lambda (x)
+                (define b-asm-size 4)
+                (define build-bop-seq
+                  (lambda (bop opnd1 opnd2 l2 body)
+                    #`(let ([code* (emit #,bop #,opnd1 code*)])
+			(safe-assert (= (asm-size* code*) #,b-asm-size))
+                        (let-values ([(ignore #,opnd2) (get-disp-opnd (fx+ next-addr #,b-asm-size) #,l2)])
+                          #,body))))
+                (define ops->code
+                  (lambda (bop opnd)
+                    #`(emit #,bop #,opnd code*)))
+                (define handle-reverse
+                  (lambda (e opnd l)
+                    (syntax-case e (r?)
+                      [(r? c1 c2) #`(if reversed? #,(ops->code #'c1 opnd) #,(ops->code #'c2 opnd))]
+                      [_ (ops->code e opnd)])))
+                (define handle-inverse
+                  (lambda (e)
+                    (syntax-case e (i?)
+                      [(i? c1 c2)
+                       #`(cond
+                           [(and (fx= disp1 0)
+                                 (branch-disp? (fx+ disp2 #,b-asm-size)))
+                            #,(handle-reverse #'c1 #'opnd2 #'l2)]
+                           [(and (fx= disp2 0)
+                                 (branch-disp? (fx+ disp1 #,b-asm-size)))
+                            #,(handle-reverse #'c2 #'opnd1 #'l1)]
+                           [(branch-disp? (fx+ disp1 (fx* 2 #,b-asm-size)))
+                            #,(build-bop-seq #'b #'opnd2 #'opnd1 #'l1
+                                (handle-reverse #'c2 #'opnd1 #'l1))]
+                           [(branch-disp? (fx+ disp2 (fx* 2 #,b-asm-size)))
+                            #,(build-bop-seq #'b #'opnd1 #'opnd2 #'l2
+                                (handle-reverse #'c1 #'opnd2 #'l2))]
+                           [else
+                            (let ([code* #,(build-bop-seq #'b #'opnd1 #'opnd2 #'l2
+					      #'(emit b opnd2 code*))])
+			      #,(handle-reverse #'c2 #``(imm #,b-asm-size) #'step))])]
+                      [_ ($oops 'handle-inverse "expected an inverse in ~s" e)])))
+                (syntax-case x ()
+                  [(_ [(pred ...) cl-body] ...)
+                   (with-syntax ([(cl-body ...) (map handle-inverse #'(cl-body ...))])
+                     #'(let ([code* '()])
+                         (let-values ([(disp1 opnd1) (get-disp-opnd next-addr l1)]
+                                      [(disp2 opnd2) (get-disp-opnd next-addr l2)])
+                           (case type
+                             [(pred ...) cl-body] ...
+                             [else (sorry! who "~s branch type is currently unsupported" type)]))))])))
+            (pred-case
+              [(eq?) (i? bne beq)]
+              [(u<) (i? (r? bls bcs) (r? bhi bcc))]
+              [(<) (i? (r? ble bge) (r? bgt blt))]
+              [(<=) (i? (r? blt bgt) (r? bge ble))]
+              [(>) (i? (r? bge ble) (r? blt bgt))]
+              [(>=) (i? (r? bgt blt) (r? ble bge))]
+              [(overflow) (i? bvc bvs)]
+              [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if oveflow
+              [(carry) (i? bcc bcs)]
+              [(fp<) (i? (r? ble bcs) (r? bgt bcc))]
+              [(fp<=) (i? (r? blt bhi) (r? bge bls))]
+              [(fp=) (i? bne beq)]))))))
+
+  (define asm-data-label
+    (lambda (code* l offset func code-size)
+      (let ([rel (make-funcrel 'abs l offset)])
+        (cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))
+
+  (define asm-helper-jump
+    (lambda (code* reloc)
+      (let ([jmp-tmp (cons 'reg %jmptmp)])
+        (ax-mov64 jmp-tmp 0
+          (emit br jmp-tmp
+            (asm-helper-relocation code* reloc))))))
+
+  (define asm-kill
+    (lambda (code* dest)
+      code*))
+
+  (define ax-save/restore
+    ;; push/pop while maintaining 16-byte alignment
+    (lambda (code* reg-ea p)
+      (let ([sp (cons 'reg %sp)])
+        (emit str/preidx reg-ea sp -16
+          (p (emit ldr/postidx reg-ea sp 16 code*))))))
+
+  (define asm-helper-call
+    (lambda (code* reloc save-ra?)
+      ;; NB: kills %lr
+      (let ([jmp-tmp (cons 'reg %jmptmp)])
+        (define maybe-save-ra
+          (lambda (code* p)
+            (if save-ra?
+                (ax-save/restore code* (cons 'reg %lr) p)
+                (p code*))))
+        (maybe-save-ra code*
+          (lambda (code*)
+            (ax-mov64 jmp-tmp 0
+              (emit blr jmp-tmp
+                (asm-helper-relocation code* reloc))))))))
+
+  (define asm-helper-relocation
+    (lambda (code* reloc)
+      (cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*))))
+
+  (define asm-rp-header
+    (let ([mrv-error `(abs ,(constant code-data-disp)
+                        (library-code ,(lookup-libspec values-error)))])
+      (lambda (code* mrvl fs lpm func code-size)
+        (let* ([code* (cons* `(quad . ,fs)
+                             (aop-cons* `(asm "frame size:" ,fs)
+                                        code*))]
+               [code* (cons* (if (target-fixnum? lpm)
+                                 `(quad . ,(fix lpm))
+                                 `(abs 0 (object ,lpm)))
+                             (aop-cons* `(asm livemask: ,(format "~b" lpm))
+                                        code*))]
+               [code* (if mrvl
+                          (asm-data-label code* mrvl 0 func code-size)
+                          (cons*
+                           mrv-error
+                           (aop-cons* `(asm "mrv point:" ,mrv-error)
+                                      code*)))]
+               [code* (cons*
+                       '(code-top-link)
+                       (aop-cons* `(asm code-top-link)
+                                  code*))])
+          code*))))
+
+  (define asm-rp-compact-header
+    (lambda (code* err? fs lpm func code-size)
+      (let* ([code* (cons* `(quad . ,(fxior (constant compact-header-mask)
+                                            (if err?
+                                                (constant compact-header-values-error-mask)
+                                                0)
+                                            (fxsll fs (constant compact-frame-words-offset))
+                                            (fxsll lpm (constant compact-frame-mask-offset))))
+                           (aop-cons* `(asm "mrv pt:" (,lpm ,fs ,(if err? 'error 'continue)))
+                                      code*))]
+             [code* (cons*
+                     '(code-top-link)
+                     (aop-cons* `(asm code-top-link)
+                                code*))])
+        code*)))
+
+  ; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
+  (define asm-return (lambda () (emit ret (cons 'reg %lr) '())))
+
+  (define asm-c-return (lambda (info) (emit ret (cons 'reg %lr) '())))
+
+  (define-who asm-shiftop
+    (lambda (op)
+      (lambda (code* dest src0 src1)
+        (Trivit (dest src0 src1)
+          (record-case src1
+            [(imm) (n)
+             ;; When `n` fits in a fixnum, the compiler may generate
+             ;; a bad shift that is under a guard, so force it to 63 bits
+             (let ([n (fxand n 63)])
+	       (cond
+		[(fx= n 0)
+		 ;; shift by 0 is just a move
+		 (emit mov dest src0 code*)]
+		[else
+		 (case op
+		   [(sll) (emit lsli dest src0 n code*)]
+		   [(srl) (emit lsri dest src0 n code*)]
+		   [(sra) (emit asri dest src0 n code*)]
+		   [else (sorry! 'shiftop "unrecognized ~s" op)])]))]
+            [else
+             (case op
+               [(sll) (emit lsl dest src0 src1 code*)]
+               [(srl) (emit lsr dest src0 src1 code*)]
+               [(sra) (emit asr dest src0 src1 code*)]
+               [else (sorry! 'shiftop "unrecognized ~s" op)])])))))
+
+  (define asm-lognot
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit mvn dest src code*))))
+
+  (define asm-enter values)
+  
+  (define-who asm-inc-cc-counter
+    (lambda (code* addr val tmp)
+      (Trivit (addr val tmp)
+        (define do-ldr
+          (lambda (offset k code*)
+            (emit ldri tmp addr offset (k (emit stri tmp addr offset code*)))))
+        (define do-add/cc
+          (lambda (code*)
+            (record-case val
+              [(imm) (n) (emit addi #t tmp tmp n code*)]
+              [else (emit add #t tmp tmp val code*)])))
+        (do-ldr 0
+          do-add/cc
+          (emit bnei 16
+            (do-ldr 8
+              (lambda (code*)
+                (emit addi #f tmp tmp 1 code*))
+              code*))))))
+  
+  (module (asm-foreign-call asm-foreign-callable)
+    (define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k)))))
+    (define (double-member? m) (and (eq? (car m) 'float)
+				    (fx= (cadr m) 8)))
+    (define (float-member? m) (and (eq? (car m) 'float)
+				   (fx= (cadr m) 4)))
+    (define (indirect-result-that-fits-in-registers? result-type)
+      (nanopass-case (Ltype Type) result-type
+        [(fp-ftd& ,ftd)
+	 (let* ([members ($ftd->members ftd)]
+		[num-members (length members)])
+	   (or (fx<= ($ftd-size ftd) 4)
+	       (and (fx= num-members 1)
+		    ;; a struct containing only int64 is not returned in a register
+		    (or (not ($ftd-compound? ftd))))
+	       (and (fx<= num-members 4)
+		    (or (andmap double-member? members)
+			(andmap float-member? members)))))]
+	[else #f]))
+    (define int-argument-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4
+                                               %Carg5 %Carg6 %Carg7 %Carg8)))
+    (define fp-argument-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4
+                                              %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8)))
+    (define save-and-restore
+      (lambda (regs e)
+        (safe-assert (andmap reg? regs))
+	(with-output-language (L13 Effect)
+          (let ([save-and-restore-gp
+		 (lambda (regs e)
+                   (let* ([regs (filter (lambda (r) (not (eq? (reg-type r) 'fp))) regs)])
+                     (cond
+                      [(null? regs) e]
+                      [else
+                       (%seq
+			(inline ,(make-info-kill*-live* '() regs) ,%push-multiple)
+			,e
+			(inline ,(make-info-kill*-live* regs '()) ,%pop-multiple))])))]
+		[save-and-restore-fp
+		 (lambda (regs e)
+                   (let ([fp-regs (filter (lambda (r) (eq? (reg-type r) 'fp)) regs)])
+                     (cond
+                      [(null? fp-regs) e]
+                      [else
+                       (%seq
+			(inline ,(make-info-kill*-live* '() fp-regs) ,%push-fpmultiple)
+			,e
+			(inline ,(make-info-kill*-live* fp-regs '()) ,%pop-fpmultiple))])))])
+            (save-and-restore-gp regs (save-and-restore-fp regs e))))))
+
+    (define-record-type cat
+      (nongenerative #{cat jqrttgvpydsbdo0l736l43udu-0})
+      (sealed #t)
+      (fields place            ; 'int, 'fp, or 'stack
+              regs             ; list of registers
+              size             ; size in bytes
+              indirect-bytes)) ; #f or extra bytes on stack for indirect
+    
+    (define categorize-arguments
+      (lambda (types)
+        (let loop ([types types] [int* (int-argument-regs)] [fp* (fp-argument-regs)])
+          (if (null? types)
+              '()
+              (nanopass-case (Ltype Type) (car types)
+                [(fp-double-float)
+                 (cond
+                   [(null? fp*)
+                    (cons (make-cat 'stack '() 8 #f) (loop (cdr types) int* '()))]
+                   [else
+                    (cons (make-cat 'fp (list (car fp*)) 8 #f) (loop (cdr types) int* (cdr fp*)))])]
+                [(fp-single-float)
+                 (cond
+                   [(null? fp*)
+                    (cons (make-cat 'stack '() 8 #f) (loop (cdr types) int* '()))]
+                   [else
+                    (cons (make-cat 'fp (list (car fp*)) 8 #f) (loop (cdr types) int* (cdr fp*)))])]
+                [(fp-ftd& ,ftd)
+                 (let* ([size ($ftd-size ftd)]
+                        [members ($ftd->members ftd)]
+                        [num-members (length members)]
+                        [doubles? (and (fx= 8 ($ftd-alignment ftd))
+                                       (fx<= num-members 4)
+                                       (andmap double-member? members))]
+                        [floats? (and (fx= 4 ($ftd-alignment ftd))
+                                      (fx<= num-members 4)
+                                      (andmap float-member? members))])
+                   (cond
+                     [doubles?
+                      ;; Sequence of up to 4 doubles that may fit in registers
+                      (cond
+                        [(fx>= (length fp*) num-members)
+                         ;; Allocate each double to a register
+                         (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) #f)
+                               (loop (cdr types) int* (list-tail fp* num-members)))]
+                        [else
+                         ;; Stop using fp registers, put on stack
+                         (cons (make-cat 'stack '() size #f)
+                               (loop (cdr types) int* '()))])]
+                     [floats?
+                      ;; Sequence of up to 4 floats that may fit in registers
+                      (cond
+                        [(fx>= (length fp*) num-members)
+                         ;; Allocate each float to a register
+                         (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) #f)
+                               (loop (cdr types) int* (list-tail fp* num-members)))]
+                        [else
+                         ;; Stop using fp registers, put on stack with aligned size
+                         (cons (make-cat 'stack '() (align 8 size) #f)
+                               (loop (cdr types) int* '()))])]
+                     [(fx> size 16)
+                      ;; Indirect; pointer goes in a register or on the stack
+                      (cond
+                        [(null? int*)
+                         ;; Pointer on the stack
+                         (cons (make-cat 'stack '() (constant ptr-bytes) (align 8 size))
+                               (loop (cdr types) '() fp*))]
+                        [else
+                         ;; Pointer in register
+                         (cons (make-cat 'int (list (car int*)) 8 (align 8 size))
+                               (loop (cdr types) (cdr int*) fp*))])]
+                     [else
+                      ;; Maybe put in integer registers
+                      (let* ([size (align 8 size)]
+                             [regs (fxquotient size 8)])
+                        (cond
+                          [(fx<= regs (length int*))
+                           ;; Fits in registers
+                           (cons (make-cat 'int (list-head int* regs) size #f)
+                                 (loop (cdr types) (list-tail int* regs) fp*))]
+                          [else
+                           ;; Stop using int registers, put on stack
+                           (cons (make-cat 'stack '() size #f)
+                                 (loop (cdr types) '() fp*))]))]))]
+                [else
+                 ;; integers, scheme-object, etc.
+                 (cond
+                   [(null? int*)
+                    (cons (make-cat 'stack '() 8 #f) (loop (cdr types) '() fp*))]
+                   [else
+                    (cons (make-cat 'int (list (car int*)) 8 #f) (loop (cdr types) (cdr int*) fp*))])])))))
+
+    (define get-registers
+      (lambda (cats kind)
+        (let loop ([cats cats])
+          (cond
+            [(null? cats) '()]
+            [(or (eq? kind 'all) (eq? kind (cat-place (car cats))))
+             (append (cat-regs (car cats))
+                     (loop (cdr cats)))]
+            [else (loop (cdr cats))]))))
+
+    (define memory-to-reg
+      (lambda (ireg x from-offset size unsigned?)
+        (safe-assert (not (eq? ireg x)))
+        (with-output-language (L13 Effect)
+          (let loop ([ireg ireg] [from-offset from-offset] [size size] [unsigned? unsigned?])
+            (case size
+              [(8) `(set! ,ireg ,(%mref ,x ,from-offset))]
+              [(7 6 5)
+               (let ([tmp %argtmp])
+                 (%seq
+                  ,(loop ireg (fx+ from-offset 4) (fx- size 4) #t)
+                  ,(loop tmp from-offset 4 #t)
+                  (set! ,ireg ,(%inline sll ,ireg (immediate 32)))
+                  (set! ,ireg ,(%inline + ,ireg ,tmp))))]
+              [(3)
+               (let ([tmp %argtmp])
+                 (%seq
+                  ,(loop ireg from-offset 2 #t)
+                  ,(loop tmp (fx+ from-offset 2) 1 #t)
+                  (set! ,tmp ,(%inline sll ,tmp (immediate 16)))
+                  (set! ,ireg ,(%inline + ,ireg ,tmp))))]
+              [else
+               `(set! ,ireg ,(case size
+                               [(1) `(inline ,(make-info-load (if unsigned? 'unsigned-8 'integer-8) #f) ,%load ,x ,%zero (immediate ,from-offset))]
+                               [(2) `(inline ,(make-info-load (if unsigned? 'unsigned-16 'integer-16) #f) ,%load ,x ,%zero (immediate ,from-offset))]
+                               [(4) `(inline ,(make-info-load (if unsigned? 'unsigned-32 'integer-32) #f) ,%load ,x ,%zero (immediate ,from-offset))]
+                               [else (sorry! 'memory-to-reg "unexpected size ~s" size)]))])))))
+    (define reg-to-memory
+      (lambda (dest offset size from-reg)
+        ;; can trash `from-reg`, cannot use `%argtmp`
+        (let loop ([offset offset] [size size])
+          (with-output-language (L13 Effect)
+            (case size
+              [(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,dest ,%zero (immediate ,offset) ,from-reg)]
+              [(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,dest ,%zero (immediate ,offset) ,from-reg)]
+              [(3) (%seq
+                    ,(loop offset 2)
+                    (set! ,from-reg ,(%inline srl ,from-reg (immediate 16)))
+                    ,(loop (fx+ offset 2) 1))]
+              [(4) `(inline ,(make-info-load 'integer-32 #f) ,%store ,dest ,%zero (immediate ,offset) ,from-reg)]
+              [(8) `(set! ,(%mref ,dest ,offset) ,from-reg)]
+              [(7 6 5) (%seq
+                        ,(loop offset 4)
+                        (set! ,from-reg ,(%inline srl ,from-reg (immediate 32)))
+                        ,(loop (fx+ offset 4) (fx- size 4)))])))))
+
+    (define-who asm-foreign-call
+      (with-output-language (L13 Effect)
+        (letrec ([load-double-stack
+                  (lambda (offset)
+                    (lambda (x) ; unboxed
+                      `(set! ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
+                 [load-single-stack
+                  (lambda (offset)
+                    (lambda (x) ; unboxed
+                      (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
+                 [load-int-stack
+                  (lambda (offset)
+                    (lambda (rhs) ; requires rhs
+                      `(set! ,(%mref ,%sp ,offset) ,rhs)))]
+                 [load-indirect-stack
+                  ;; used both for arguments passed on stack and argument passed as a pointer to deeper on the stack
+                  (lambda (offset from-offset size)
+                    (lambda (x) ; requires var
+                      (let loop ([size size] [offset offset] [from-offset from-offset])
+                        (case size
+                          [(8) `(set! ,(%mref ,%sp ,offset) ,(%mref ,x ,from-offset))]
+                          [(7 6 5)
+                           (%seq
+                            ,(loop 4 offset from-offset)
+                            ,(loop (fx- size 4) (fx+ offset 4) (fx+ from-offset 4)))]
+                          [(3)
+                           (%seq
+                            (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset)))
+                            (set! ,(%mref ,%sp ,(fx+ offset 2)) (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))))]
+                          [(1 2 4)
+                           `(set! ,(%mref ,%sp ,offset) ,(case size
+                                                           [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))]
+                                                           [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))]
+                                                           [(4) `(inline ,(make-info-load 'integer-32 #f) ,%load ,x ,%zero (immediate ,from-offset))]))]
+                          [else
+                           (%seq
+                            ,(loop 8 offset from-offset)
+                            ,(loop (fx- size 8) (fx+ offset 8) (fx+ from-offset 8)))]))))]
+                 [load-double-reg
+                  (lambda (fpreg)
+                    (lambda (x) ; unboxed
+                      `(set! ,fpreg ,x)))]
+                 [load-single-reg
+                  (lambda (fpreg)
+                    (lambda (x) ; unboxed
+                      `(set! ,fpreg ,(%inline double->single ,x))))]
+                 [load-boxed-double-reg
+                  (lambda (fpreg fp-disp)
+                    (lambda (x) ; address (always a var) of a flonum
+                      `(set! ,fpreg ,(%mref ,x ,%zero ,fp-disp fp))))]
+                 [load-boxed-single-reg
+                  (lambda (fpreg fp-disp)
+                    (lambda (x) ; address (always a var) of a float
+                      `(set! ,fpreg ,(%inline load-single ,(%mref ,x ,%zero ,fp-disp fp)))))]
+                 [load-int-reg
+                  (lambda (ireg)
+                    (lambda (x)
+                      `(set! ,ireg ,x)))]
+                 [load-int-indirect-reg
+                  (lambda (ireg from-offset size unsigned?)
+                    (lambda (x)
+                      (memory-to-reg ireg x from-offset size unsigned?)))]
+                 [compute-stack-argument-space
+                  ;; We'll save indirect arguments on the stack, too, but they have to be beyond any
+                  ;; arguments that the callee expects. So, calculate how much the callee shoudl expect.
+                  (lambda (cats)
+                    (let loop ([cats cats] [isp 0])
+                      (if (null? cats)
+                          isp
+                          (let ([cat (car cats)])
+                            (if (eq? (cat-place cat) 'stack)
+                                (loop (cdr cats) (fx+ isp (cat-size cat)))
+                                (loop (cdr cats) isp))))))]
+                 [compute-stack-indirect-space
+                  (lambda (cats)
+                    (let loop ([cats cats] [isp 0])
+                      (if (null? cats)
+                          isp
+                          (let ([cat (car cats)])
+                            (loop (cdr cats) (fx+ isp (or (cat-indirect-bytes cat) 0)))))))]
+                 [do-args
+                  (lambda (types cats indirect-start)
+                    (let loop ([types types] [cats cats] [locs '()] [isp 0] [ind-sp indirect-start])
+                      (if (null? types)
+                          locs
+                          (let ([cat (car cats)]
+                                [type (car types)]
+                                [cats (cdr cats)]
+                                [types (cdr types)])
+                            (nanopass-case (Ltype Type) type
+                              [(fp-double-float)
+                               (cond
+                                 [(eq? 'fp (cat-place cat))
+                                  (loop types cats 
+                                        (cons (load-double-reg (car (cat-regs cat))) locs)
+                                        isp ind-sp)]
+                                 [else
+                                  (loop types cats 
+                                        (cons (load-double-stack isp) locs)
+                                        (fx+ isp (cat-size cat)) ind-sp)])]
+                              [(fp-single-float)
+                               (cond
+                                 [(eq? 'fp (cat-place cat))
+                                  (loop types cats 
+                                        (cons (load-single-reg (car (cat-regs cat))) locs)
+                                        isp ind-sp)]
+                                 [else
+                                  (loop types cats 
+                                        (cons (load-single-stack isp) locs)
+                                        (fx+ isp  (cat-size cat)) ind-sp)])]
+                              [(fp-ftd& ,ftd)
+                               (let ([size ($ftd-size ftd)])
+                                 (case (cat-place cat)
+                                   [(int)
+                                    (let ([indirect-bytes (cat-indirect-bytes cat)])
+                                      (cond
+                                        [indirect-bytes
+                                         ;; pointer to an indirect argument
+                                         (safe-assert (fx= 1 (length (cat-regs cat))))
+                                         (loop types cats
+                                               (cons (let ([ind (load-indirect-stack ind-sp 0 size)])
+                                                       (lambda (x)
+                                                         (%seq
+                                                          ,(ind x)
+                                                          (set! ,(car (cat-regs cat)) ,(%inline + ,%sp (immediate ,ind-sp))))))
+                                                     locs)
+                                               isp (fx+ ind-sp indirect-bytes))]
+                                        [else
+                                         ;; argument copied to one or more integer registers
+                                         (let i-loop ([int* (cat-regs cat)] [size size] [offset 0] [proc #f])
+                                           (cond
+                                             [(null? int*)
+                                              (loop types cats
+                                                    (cons proc locs)
+                                                    isp ind-sp)]
+                                             [else
+                                              (i-loop (cdr int*) (fx- size 8) (fx+ offset 8)
+                                                      (let ([new-proc (load-int-indirect-reg (car int*) offset (fxmin size 8) ($ftd-unsigned? ftd))])
+                                                        (if proc
+                                                            (lambda (x) (%seq ,(proc x) ,(new-proc x)))
+                                                            new-proc)))]))]))]
+                                   [(fp)
+                                    (let ([double? (double-member? (car ($ftd->members ftd)))])
+                                      ;; argument copied to one or more integer registers
+                                      (let f-loop ([fp* (cat-regs cat)] [offset 0] [proc #f])
+                                        (cond
+                                          [(null? fp*)
+                                           (loop types cats
+                                                 (cons proc locs)
+                                                 isp ind-sp)]
+                                          [else
+                                           (f-loop (cdr fp*) (fx+ offset (if double? 8 4))
+                                                   (let ([new-proc (if double?
+                                                                       (load-boxed-double-reg (car fp*) offset)
+                                                                       (load-boxed-single-reg (car fp*) offset))])
+                                                     (if proc
+                                                         (lambda (x) (%seq ,(proc x) ,(new-proc x)))
+                                                         new-proc)))])))]
+                                   [else
+                                    (let ([indirect-bytes (cat-indirect-bytes cat)]
+                                          [size-on-stack (cat-size cat)])
+                                      (cond
+                                        [indirect-bytes
+                                         ;; pointer (passed on stack) to an indirect argument (also on stack)
+                                         (safe-assert (fx= size-on-stack 8))
+                                         (loop types cats
+                                               (cons (let ([ind (load-indirect-stack ind-sp 0 size-on-stack)])
+                                                       (lambda (x)
+                                                         (%seq
+                                                          ,(ind x)
+                                                          (set! ,(%mref ,%sp ,isp) ,(%inline + ,%sp ,ind)))))
+                                                     locs)
+                                               (fx+ isp size-on-stack) (fx+ ind-sp indirect-bytes))]
+                                        [else
+                                         ;; argument copied to stack
+                                         (loop types cats
+                                               (cons (load-indirect-stack isp 0 size) locs)
+                                               (fx+ isp size-on-stack) ind-sp)]))]))]
+                              [else
+                               ;; integer, scheme-object, etc.
+                               (cond
+                                 [(eq? 'int (cat-place cat))
+                                  (loop types cats 
+                                        (cons (load-int-reg (car (cat-regs cat))) locs)
+                                        isp ind-sp)]
+                                 [else
+                                  (loop types cats 
+                                        (cons (load-int-stack isp) locs)
+                                        (fx+ isp (cat-size cat)) ind-sp)])])))))]
+		 [add-fill-result
+                  ;; may destroy the values in result registers
+		  (lambda (result-cat result-type args-frame-size e)
+                    (nanopass-case (Ltype Type) result-type
+                      [(fp-ftd& ,ftd)
+                       (let* ([size ($ftd-size ftd)]
+                              [tmp %argtmp])
+                         (case (cat-place result-cat)
+                           [(int)
+                            ;; result is in integer registers
+                            (let loop ([int* (cat-regs result-cat)] [offset 0] [size size])
+                              (cond
+                                [(null? int*) `(seq ,e (set! ,tmp ,(%mref ,%sp ,args-frame-size)))]
+                                [else
+                                 (%seq ,(loop (cdr int*) (fx+ offset 8) (fx- size 8))
+                                       ,(reg-to-memory tmp offset (fxmin size 8) (car int*)))]))]
+                           [(fp)
+                            ;; result is in fp registers, so going to either double or float elements
+                            (let* ([double? (double-member? (car ($ftd->members ftd)))])
+                              (let loop ([fp* (cat-regs result-cat)] [offset 0])
+                                (cond
+                                  [(null? fp*) `(seq ,e (set! ,tmp ,(%mref ,%sp ,args-frame-size)))]
+                                  [double?
+                                   (%seq ,(loop (cdr fp*) (fx+ offset 8))
+                                         (set! ,(%mref ,tmp ,%zero ,offset fp) ,(car fp*)))]
+                                  [else
+                                   (%seq ,(loop (cdr fp*) (fx+ offset 4))
+                                         ,(%inline store-single ,(%mref ,tmp ,%zero ,offset fp) ,(car fp*)))])))]
+                           [else
+                            ;; we passed the pointer to be filled, so nothing more to do here
+                            e]))]
+                      [else
+                       ;; anything else
+                       e]))]
+                 [add-deactivate
+                  (lambda (adjust-active? t0 live* result-live* k)
+                    (cond
+                      [adjust-active?
+                       (%seq
+			(set! ,%ac0 ,t0)
+                        ,(save-and-restore live* (%inline deactivate-thread))
+                        ,(k %ac0)
+                        ,(save-and-restore result-live* `(set! ,%Cretval ,(%inline activate-thread))))]
+                      [else (k t0)]))])
+          (lambda (info)
+            (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
+            (let* ([arg-type* (info-foreign-arg-type* info)]
+                   [result-type (info-foreign-result-type info)]
+                   [ftd-result? (nanopass-case (Ltype Type) result-type
+                                  [(fp-ftd& ,ftd) #t]
+                                  [else #f])]
+                   [arg-type* (if ftd-result?
+                                  (cdr arg-type*)
+                                  arg-type*)]
+                   [arg-cat* (categorize-arguments arg-type*)]
+                   [conv* (info-foreign-conv* info)]
+		   [result-cat (car (categorize-arguments (list result-type)))]
+                   [result-reg* (cat-regs result-cat)]
+		   [fill-result-here? (and ftd-result?
+                                           (not (cat-indirect-bytes result-cat))
+                                           (not (eq? 'stack (cat-place result-cat))))]
+                   [arg-stack-bytes (align 16 (compute-stack-argument-space arg-cat*))]
+                   [indirect-stack-bytes (align 16 (compute-stack-indirect-space arg-cat*))]
+                   [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
+                   [locs (do-args arg-type* arg-cat* arg-stack-bytes)]
+                   [live* (get-registers arg-cat* 'all)]
+                   [live* (if (and ftd-result? (not fill-result-here?))
+                              (cons %r8 live*)
+                              live*)]
+                   [frame-size (align 16 (fx+ arg-stack-bytes
+                                              indirect-stack-bytes
+                                              (if fill-result-here?
+                                                  8
+                                                  0)))]
+                   [adjust-frame (lambda (op)
+                                   (lambda ()
+                                     (if (fx= frame-size 0)
+                                         `(nop)
+                                         `(set! ,%sp (inline ,null-info ,op ,%sp (immediate ,frame-size))))))])
+              (values
+               (adjust-frame %-)
+               (let ([locs (reverse locs)])
+                 (cond
+                   [fill-result-here?
+                    ;; stash extra argument on the stack to be retrieved after call and filled with the result:
+                    (cons (load-int-stack (fx+ arg-stack-bytes indirect-stack-bytes)) locs)]
+                   [ftd-result?
+                    ;; callee expects pointer to fill for return in %r8:
+                    (cons (lambda (rhs) `(set! ,%r8 ,rhs)) locs)]
+                   [else locs]))
+               (lambda (t0 not-varargs?)
+                 (add-fill-result result-cat result-type (fx+ arg-stack-bytes indirect-stack-bytes)
+                                  (add-deactivate adjust-active? t0 live* result-reg*
+                                                  (lambda (t0)
+                                                    `(inline ,(make-info-kill*-live* (add-caller-save-registers result-reg*) live*) ,%c-call ,t0)))))
+               (nanopass-case (Ltype Type) result-type
+                 [(fp-double-float)
+                  (lambda (lvalue) ; unboxed
+                    `(set! ,lvalue ,%Cfpretval))]
+                 [(fp-single-float)
+                  (lambda (lvalue) ; unboxed
+                    `(set! ,lvalue ,(%inline single->double ,%Cfpretval)))]
+                 [(fp-integer ,bits)
+                  (case bits
+                    [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%Cretval)))]
+                    [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%Cretval)))]
+                    [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline sext32 ,%Cretval)))]
+                    [(64) (lambda (lvalue) `(set! ,lvalue ,%Cretval))]
+                    [else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])]
+                 [(fp-unsigned ,bits)
+                  (case bits
+                    [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%Cretval)))]
+                    [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%Cretval)))]
+                    [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline zext32 ,%Cretval)))]
+                    [(64) (lambda (lvalue) `(set! ,lvalue ,%Cretval))]
+                    [else (sorry! who "unexpected asm-foreign-procedures fp-unsigned size ~s" bits)])]
+                 [else (lambda (lvalue) `(set! ,lvalue ,%Cretval))])
+               (adjust-frame %+)))
+            ))))
+
+    (define-who asm-foreign-callable
+      #|
+        Frame Layout
+                   +---------------------------+
+                   |                           |
+                   |    incoming stack args    |
+                   |                           |
+                   +---------------------------+<- 16-byte boundary
+                   |    saved int reg args     | 
+                   |    + %r8 for indirect     |
+                   |    + maybe padding        | 
+                   +---------------------------+<- 16-byte boundary
+                   |                           | 
+                   |   saved float reg args    |
+                   |    + maybe padding        | 
+                   +---------------------------+<- 16-byte boundary
+                   |                           | 
+                   |     activatation state    | 
+                   |       if necessary        |
+                   +---------------------------+<- 16-byte boundary
+                   |                           | 
+                   |      &-return space       |
+                   |       if necessary        |
+                   +---------------------------+<- 16-byte boundary
+                   |                           |
+                   |   callee-save regs + lr   | 
+                   |   callee-save fpregs      |
+                   +---------------------------+<- 16-byte boundary
+      |#
+      (with-output-language (L13 Effect)
+        (let ()
+          (define load-double-stack
+            (lambda (offset)
+              (lambda (x) ; requires var
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%mref ,%sp ,%zero ,offset fp)))))
+          (define load-single-stack
+            (lambda (offset)
+              (lambda (x) ; requires var
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
+          (define load-word-stack
+            (lambda (offset)
+              (lambda (lvalue)
+                `(set! ,lvalue ,(%mref ,%sp ,offset)))))
+          (define load-int-stack
+            (lambda (type offset)
+              (lambda (lvalue)
+                (nanopass-case (Ltype Type) type
+                  [(fp-integer ,bits)
+                   (case bits
+                     [(8) `(set! ,lvalue (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
+                     [(16) `(set! ,lvalue (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
+                     [(32) `(set! ,lvalue (inline ,(make-info-load 'integer-32 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
+                     [(64) `(set! ,lvalue ,(%mref ,%sp ,offset))]
+                     [else (sorry! who "unexpected load-int-stack fp-integer size ~s" bits)])]
+                  [(fp-unsigned ,bits)
+                   (case bits
+                     [(8) `(set! ,lvalue (inline ,(make-info-load 'unsigned-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
+                     [(16) `(set! ,lvalue (inline ,(make-info-load 'unsigned-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
+                     [(32) `(set! ,lvalue (inline ,(make-info-load 'unsigned-32 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
+                     [(64) `(set! ,lvalue ,(%mref ,%sp ,offset))]
+                     [else (sorry! who "unexpected load-int-stack fp-unsigned size ~s" bits)])]
+                  [else `(set! ,lvalue ,(%mref ,%sp ,offset))]))))
+	  (define load-stack-address
+	    (lambda (offset)
+	      (lambda (lvalue)
+		`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
+          (define do-args
+            ;; all of the args are on the stack at this point, though not contiguous since
+            ;; we push all of the int reg args with one set of push instructions and all of the
+            ;; float reg args with another set of push instructions
+            (lambda (arg-type* arg-cat* init-int-reg-offset float-reg-offset stack-arg-offset return-offset
+                               synthesize-first? indirect-result?)
+              (let loop ([types arg-type*]
+                         [cats arg-cat*]
+                         [locs '()]
+                         [int-reg-offset (if indirect-result? (fx+ init-int-reg-offset 8) init-int-reg-offset)]
+                         [float-reg-offset float-reg-offset]
+                         [stack-arg-offset stack-arg-offset])
+                  (if (null? types)
+                      (let ([locs (reverse locs)])
+                        (cond
+                          [synthesize-first?
+                           (cons (load-stack-address return-offset) locs)]
+                          [indirect-result?
+                           (cons (load-word-stack init-int-reg-offset) locs)]
+                          [else locs]))
+                      (let ([cat (car cats)]
+                            [type (car types)]
+                            [cats (cdr cats)]
+                            [types (cdr types)])
+                        (nanopass-case (Ltype Type) type
+                          [(fp-double-float)
+                           (case (cat-place cat)
+                             [(fp)
+                              (loop types cats
+                                    (cons (load-double-stack float-reg-offset) locs)
+                                    int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)]
+                             [else
+                              (loop types cats
+                                    (cons (load-double-stack stack-arg-offset) locs)
+                                    int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))])]
+                          [(fp-single-float)
+                           (case (cat-place cat)
+                             [(fp)
+                              (loop types cats
+                                    (cons (load-single-stack float-reg-offset) locs)
+                                    int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)]
+                             [else
+                              (loop types cats
+                                    (cons (load-single-stack stack-arg-offset) locs)
+                                    int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))])]
+                          
+                          [(fp-ftd& ,ftd)
+                           (case (cat-place cat)
+                             [(int)
+                              (let ([indirect-bytes (cat-indirect-bytes cat)])
+                                (cond
+                                  [indirect-bytes
+                                   ;; pointer to an indirect argument
+                                   (safe-assert (fx= (length (cat-regs cat)) 1))
+                                   (loop types cats
+                                         (cons (load-word-stack int-reg-offset) locs)
+                                         (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)]
+                                  [else
+                                   ;; point to argument on stack
+                                   (loop types cats
+                                         (cons (load-stack-address int-reg-offset) locs)
+                                         (fx+ int-reg-offset (cat-size cat)) float-reg-offset stack-arg-offset)]))]
+                             [(fp)
+                              ;; point to argument, but if they're floats, then we need to
+                              ;; shift double-sized registers into float-sized elements
+                              (loop types cats
+                                    (cons (let ([proc (load-stack-address float-reg-offset)]
+                                                [members ($ftd->members ftd)])
+                                            (cond
+                                              [(or (null? (cdr members))
+                                                   (double-member? (car members)))
+                                               proc]
+                                              [else
+                                               ;; instead of compacting here, it might be nicer to
+                                               ;; save registers in packed form in the first place
+                                               ;; (which means that `(cat-size cat)` would be a multiple of 4)
+                                               (lambda (lvalue)
+                                                 (let loop ([members (cdr members)]
+                                                            [dest-offset (fx+ float-reg-offset 4)]
+                                                            [src-offset (fx+ float-reg-offset 8)])
+                                                   (if (null? members)
+                                                       (proc lvalue)
+                                                       (let ([tmp %argtmp])
+                                                         (%seq
+                                                          (set! ,tmp (inline ,(make-info-load 'unsigned-32 #f) ,%load ,%sp ,%zero (immediate ,src-offset)))
+                                                          (inline ,(make-info-load 'unsigned-32 #f) ,%store ,%sp ,%zero (immediate ,dest-offset) ,%argtmp)
+                                                          ,(loop (cdr members) (fx+ dest-offset 4) (fx+ src-offset 8)))))))]))
+                                          locs)
+                                    int-reg-offset (fx+ float-reg-offset (cat-size cat)) stack-arg-offset)]
+                             [else
+                              (let ([indirect-bytes (cat-indirect-bytes cat)])
+                                (cond
+                                 [indirect-bytes
+                                   ;; pointer (passed on stack) to an indirect argument (also on stack)
+                                   (safe-assert (fx= (cat-size cat) 8))
+                                   (loop types cats
+                                         (cons (load-word-stack stack-arg-offset) locs)
+                                         int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))]
+                                  [else
+                                   ;; point to argument on stack
+                                   (loop types cats
+                                         (cons (load-stack-address stack-arg-offset) locs)
+                                         int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))]))])]
+                          [else
+                           ;; integer, scheme-object, etc.
+                           (case (cat-place cat)
+                             [(int)
+                              (loop types cats
+                                    (cons (load-int-stack type int-reg-offset) locs)
+                                    (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)]
+                             [else
+                              (loop types cats
+                                    (cons (load-int-stack type stack-arg-offset) locs)
+                                    int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat)))])]))))))
+          (define do-result
+            (lambda (result-type result-cat synthesize-first? return-stack-offset)
+	      (nanopass-case (Ltype Type) result-type
+                [(fp-double-float)
+		 (lambda (rhs)
+                   `(set! ,%Cfpretval ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp)))]
+		[(fp-single-float)
+                 (lambda (rhs)
+                   `(set! ,%Cfpretval ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp))))]
+                [(fp-void)
+                 (lambda () `(nop))]
+                [(fp-ftd& ,ftd)
+                 (cond
+                   [(cat-indirect-bytes result-cat)
+                    ;; we passed the pointer to be filled, so nothing more to do here
+                    (lambda () `(nop))]
+                   [else
+                    (case (cat-place result-cat)
+                      [(int)
+                       (let ([to-regs
+                              (lambda (x offset)
+                                (let loop ([int* (cat-regs result-cat)] [offset offset] [size ($ftd-size ftd)])
+                                  (cond
+                                    [(null? int*) `(nop)]
+                                    [else
+                                     (safe-assert (not (eq? (car int*) x)))
+                                     (%seq
+                                      ,(loop (cdr int*) (fx+ offset 8) (fx- size 8))
+                                      ,(memory-to-reg (car int*) x offset (fxmin size 8) ($ftd-unsigned? ftd)))])))])
+                         (if synthesize-first?
+                             (lambda ()
+                               (to-regs %sp return-stack-offset))
+                             (lambda (x)
+                               (to-regs x 0))))]
+                      [(fp)
+                       (let* ([double? (double-member? (car ($ftd->members ftd)))])
+                         (let ([to-regs
+                                (lambda (x offset)
+                                  (let loop ([fp* (cat-regs result-cat)] [offset offset])
+                                    (cond
+                                      [(null? fp*) `(nop)]
+                                      [double?
+                                       (%seq ,(loop (cdr fp*) (fx+ offset 8))
+                                             (set! ,(car fp*) ,(%mref ,x ,%zero ,offset fp)))]
+                                      [else
+                                       (%seq ,(loop (cdr fp*) (fx+ offset 4))
+                                             (set! ,(car fp*) ,(%inline load-single ,(%mref ,x ,%zero ,offset fp))))])))])
+                           (if synthesize-first?
+                               (lambda ()
+                                 (to-regs %sp return-stack-offset))
+                               (lambda (x)
+                                 (to-regs x 0)))))]
+                      [else
+                       ;; we passed the pointer to be filled, so nothing more to do here
+                       (lambda () `(nop))])])]
+                [else
+                 ;; integer, scheme-object, etc.
+                 (lambda (x)
+                   `(set! ,%Cretval ,x))])))
+          (lambda (info)
+            (define get-callee-save-regs (lambda (type)
+                                           (let loop ([i 0])
+                                             (cond
+                                               [(fx= i (vector-length regvec)) '()]
+                                               [else (let ([reg (vector-ref regvec i)])
+                                                       (if (and (reg-callee-save? reg)
+                                                                (eq? type (reg-type reg)))
+                                                           (cons reg (loop (fx+ i 1)))
+                                                           (loop (fx+ i 1))))]))))
+            (define callee-save-regs+lr (cons* %lr
+					       ;; reserved:
+					       %tc %sfp %ap %trap
+					       ;; allocable:
+					       (get-callee-save-regs 'uptr)))
+            (define callee-save-fpregs  (get-callee-save-regs 'fp))
+            (define isaved (length callee-save-regs+lr))
+            (define fpsaved (length callee-save-fpregs))
+            (let* ([arg-type* (info-foreign-arg-type* info)]
+                   [result-type (info-foreign-result-type info)]
+                   [ftd-result? (nanopass-case (Ltype Type) result-type
+                                  [(fp-ftd& ,ftd) #t]
+                                  [else #f])]
+                   [arg-type* (if ftd-result?
+                                  (cdr arg-type*)
+                                  arg-type*)]
+                   [arg-cat* (categorize-arguments arg-type*)]
+                   [result-cat (car (categorize-arguments (list result-type)))]
+                   [synthesize-first? (and ftd-result?
+                                           (not (cat-indirect-bytes result-cat))
+                                           (not (eq? 'stack (cat-place result-cat))))]
+                   [indirect-result? (and ftd-result? (not synthesize-first?))]
+		   [conv* (info-foreign-conv* info)]
+                   [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
+
+                   [arg-regs (let ([regs (get-registers arg-cat* 'int)])
+                               (if indirect-result?
+                                   (cons %r8 regs)
+                                   regs))]
+                   [arg-fp-regs (get-registers arg-cat* 'fp)]
+                   [result-regs (get-registers (list result-cat) 'all)])
+                (let ([int-reg-bytes (fx* (align 2 (length arg-regs)) 8)]
+                      [float-reg-bytes (fx* (align 2 (length arg-fp-regs)) 8)]
+                      [active-state-bytes (if adjust-active? 16 0)]
+                      [return-bytes (if synthesize-first? (align 16 (cat-size result-cat)) 0)]
+                      [callee-save-bytes (fx* 8
+                                              (fx+ (align 2 (length callee-save-regs+lr))
+                                                   (align 2 (length callee-save-fpregs))))])
+                  (let* ([return-offset callee-save-bytes]
+                         [active-state-offset (fx+ return-offset return-bytes)]
+                         [arg-fpregs-offset (fx+ active-state-offset active-state-bytes)]
+                         [arg-regs-offset (fx+ arg-fpregs-offset float-reg-bytes)]
+                         [args-offset (fx+ arg-regs-offset int-reg-bytes)])
+                    (values
+                     (lambda ()
+                       (%seq
+                        ;; save argument register values to the stack so we don't lose the values
+                        ;; across possible calls to C while setting up the tc and allocating memory
+                        ,(if (null? arg-regs) `(nop) `(inline ,(make-info-kill*-live* '() arg-regs) ,%push-multiple))
+                        ,(if (null? arg-fp-regs) `(nop) `(inline ,(make-info-kill*-live* '() arg-fp-regs) ,%push-fpmultiple))
+                        ;; make room for active state and/or return bytes
+                        ,(let ([len (+ active-state-bytes return-bytes)])
+                           (if (fx= len 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,len)))))
+                        ;; save the callee save registers & return address
+                        (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple)
+                        (inline ,(make-info-kill*-live* '() callee-save-fpregs) ,%push-fpmultiple)
+                        ;; maybe activate
+                        ,(if adjust-active?
+                             `(seq
+                               (set! ,%Cretval ,(%inline activate-thread))
+                               (set! ,(%mref ,%sp ,active-state-offset) ,%Cretval))
+                             `(nop))
+                        ;; set up tc for benefit of argument-conversion code, which might allocate
+                        ,(if-feature pthreads
+                           (%seq 
+                            (set! ,%Cretval ,(%inline get-tc))
+                            (set! ,%tc ,%Cretval))
+                           `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
+                     ;; list of procedures that marshal arguments from their C stack locations
+                     ;; to the Scheme argument locations
+                     (do-args arg-type* arg-cat* arg-regs-offset arg-fpregs-offset args-offset return-offset
+                              synthesize-first? indirect-result?)
+                     (do-result result-type result-cat synthesize-first? return-offset)
+                     (lambda ()
+                       (in-context Tail
+                        (%seq
+                         ,(if adjust-active?
+                              (%seq
+                               ;; We need *(sp+active-state-offset) in %Carg1,
+                               ;; but that can also be a return register.
+                               ;; Meanwhle, sp may change before we call unactivate.
+                               ;; So, move to %r2 for now, then %Carg1 later:
+                               (set! ,%argtmp ,(%mref ,%sp ,active-state-offset))
+                               ,(save-and-restore
+                                 result-regs
+                                 `(seq
+                                   (set! ,%Carg1 ,%argtmp)
+                                   ,(%inline unactivate-thread ,%Carg1))))
+                              `(nop))
+                         ;; restore the callee save registers
+                         (inline ,(make-info-kill* callee-save-fpregs) ,%pop-fpmultiple)
+                         (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple)
+                         ;; deallocate space for pad & arg reg values
+                         (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ active-state-bytes return-bytes float-reg-bytes int-reg-bytes))))
+                         ;; done
+                         (asm-c-return ,null-info ,callee-save-regs+lr ... ,callee-save-fpregs ... ,result-regs ...)))))))))))))
+)
diff --git a/src/ChezScheme/s/back.ss b/src/ChezScheme/s/back.ss
index 72e9d39a18..994d784d63 100644
--- a/src/ChezScheme/s/back.ss
+++ b/src/ChezScheme/s/back.ss
@@ -66,6 +66,17 @@
          ($oops who "new release minimum generation must not be be greater than collect-maximum-generation"))
        ($set-release-minimum-generation! g)])))
 
+(define-who in-place-minimum-generation
+  (let ([$get-mark-minimum-generation (foreign-procedure "(cs)minmarkgen" () fixnum)]
+        [$set-mark-minimum-generation! (foreign-procedure "(cs)set_minmarkgen" (fixnum) void)])
+    (case-lambda
+      [() ($get-mark-minimum-generation)]
+      [(g)
+       (unless (and (fixnum? g) (fx>= g 0)) ($oops who "invalid generation ~s" g))
+       (let ([limit (fx- (constant static-generation) 1)])
+         (when (fx> g limit) ($oops who "~s exceeds maximum supported value ~s" g limit)))
+       ($set-mark-minimum-generation! g)])))
+
 (define-who enable-object-counts
   (let ([$get-enable-object-counts (foreign-procedure "(cs)enable_object_counts" () boolean)]
         [$set-enable-object-counts (foreign-procedure "(cs)set_enable_object_counts" (boolean) void)])
diff --git a/src/ChezScheme/s/base-lang.ss b/src/ChezScheme/s/base-lang.ss
index 93db537a02..96941a7fc5 100644
--- a/src/ChezScheme/s/base-lang.ss
+++ b/src/ChezScheme/s/base-lang.ss
@@ -16,8 +16,7 @@
 (module (Lsrc Lsrc? Ltype Ltype? unparse-Ltype unparse-Lsrc count-Lsrc
          lookup-primref primref? primref-name primref-level primref-flags primref-arity
          sorry! make-preinfo preinfo? preinfo-lambda? preinfo-sexpr preinfo-sexpr-set! preinfo-src
-         make-preinfo-lambda preinfo-lambda-name preinfo-lambda-name-set! preinfo-lambda-flags
-         preinfo-lambda-flags-set! preinfo-lambda-libspec
+         make-preinfo-lambda preinfo-lambda-name preinfo-lambda-flags preinfo-lambda-libspec
          make-preinfo-call preinfo-call? preinfo-call-flags preinfo-call-check? preinfo-call-can-inline?
          prelex? make-prelex prelex-name prelex-name-set! prelex-flags prelex-flags-set!
          prelex-source prelex-operand prelex-operand-set! prelex-uname make-prelex*
@@ -170,10 +169,10 @@
           [(src sexpr) (new src sexpr)]))))
 
   (define-record-type preinfo-lambda
-    (nongenerative #{preinfo-lambda e23pkvo5btgapnzomqgegm-5})
+    (nongenerative #{preinfo-lambda hhv0qzgdqfvjgms8nm7y4bf9w-0})
     (parent preinfo)
     (sealed #t)
-    (fields libspec (mutable name) (mutable flags))
+    (fields libspec name flags)
     (protocol
       (lambda (pargs->new)
         (case-lambda
diff --git a/src/ChezScheme/s/bytevector.ss b/src/ChezScheme/s/bytevector.ss
index ce265f055b..be491650ed 100644
--- a/src/ChezScheme/s/bytevector.ss
+++ b/src/ChezScheme/s/bytevector.ss
@@ -511,6 +511,21 @@
          ($oops who "~s is not a valid bytevector length" n))
        (#3%make-bytevector n)]))
 
+  (set-who! make-immobile-bytevector
+    (let ([$make-immobile-bytevector (foreign-procedure "(cs)make_immobile_bytevector" (uptr) ptr)])
+      (case-lambda
+       [(n fill)
+        (unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
+          ($oops who "~s is not a valid bytevector length" n))
+        (unless (fill? fill) (invalid-fill-value who fill))
+        (let ([bv ($make-immobile-bytevector n)])
+          (#3%bytevector-fill! bv fill)
+          bv)]
+       [(n)
+        (unless (and (fixnum? n) (not ($fxu< (constant maximum-bytevector-length) n)))
+          ($oops who "~s is not a valid bytevector length" n))
+        ($make-immobile-bytevector n)])))
+
   (set! bytevector? (lambda (x) (#2%bytevector? x)))
 
   (set! bytevector-length
@@ -717,16 +732,11 @@
 
   (set-who! bytevector-ieee-double-native-ref
     (lambda (v i)
-      (if ($bytevector-ref-check? 64 v i)
-          (#3%bytevector-ieee-double-native-ref v i)
-          (if (bytevector? v)
-              (invalid-index who v i)
-              (not-a-bytevector who v)))))
+      (#2%bytevector-ieee-double-native-ref v i)))
 
   (set-who! bytevector-ieee-single-native-set!
     (lambda (v i x)
       (if ($bytevector-set!-check? 32 v i)
-         ; inline routine checks to make sure x is a real number
           (#3%bytevector-ieee-single-native-set! v i x)
           (if (mutable-bytevector? v)
               (invalid-index who v i)
@@ -734,12 +744,7 @@
 
   (set-who! bytevector-ieee-double-native-set!
     (lambda (v i x)
-      (if ($bytevector-set!-check? 64 v i)
-         ; inline routine checks to make sure x is a real number
-          (#3%bytevector-ieee-double-native-set! v i x)
-          (if (mutable-bytevector? v)
-              (invalid-index who v i)
-              (not-a-mutable-bytevector who v)))))
+      (#2%bytevector-ieee-double-native-set! v i x)))
 
   (set-who! bytevector-copy
     (lambda (v)
diff --git a/src/ChezScheme/s/cmacros.ss b/src/ChezScheme/s/cmacros.ss
index e5463dd157..b720830810 100644
--- a/src/ChezScheme/s/cmacros.ss
+++ b/src/ChezScheme/s/cmacros.ss
@@ -12,6 +12,9 @@
 ;;; See the License for the specific language governing permissions and
 ;;; limitations under the License.
 
+;; ---------------------------------------------------------------------
+;; Initial helper macros and functions:
+
 (define-syntax disable-unbound-warning
   (syntax-rules ()
     ((_ name ...)
@@ -190,6 +193,13 @@
   (lambda (x)
     (syntax-error x "misplaced aux keyword")))
 
+;; ---------------------------------------------------------------------
+;; Libspec representation:
+
+;; A libspec is a description of a runtime function to be represenced
+;; by machine code, where the linker will find the library funtion and
+;; update code to reference it as code is loaded/linked
+
 ;; layout of our flags field:
 ;; bit 0: needs head space?
 ;; bit 1 - 9: upper 9 bits of index (lower bit is the needs head space index
@@ -290,6 +300,9 @@
          (fxlogand (libspec-flags libspec)
            (fxlognot (fxsll 1 (constant libspec-does-not-expect-headroom-index))))))]))
 
+;; ---------------------------------------------------------------------
+;; More helpers:
+
 (define-syntax return-values
   (syntax-rules ()
     ((_ args ...) (values args ...))))
@@ -328,7 +341,14 @@
                  [(_ foo e1 e2) e1] ...
                  [(_ bar e1 e2) e2]))))])))
 
-(define-constant scheme-version #x09050319)
+(define-syntax log2
+  (syntax-rules ()
+    [(_ n) (integer-length (- n 1))]))
+
+;; ---------------------------------------------------------------------
+;; Version and machine types:
+
+(define-constant scheme-version #x09050320)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -363,15 +383,15 @@
   i3qnx     ti3qnx
   arm32le   tarm32le
   ppc32le   tppc32le
+  arm64le   tarm64le
 )
 
 (include "machine.def")
 
 (define-constant machine-type-name (cdr (assv (constant machine-type) (constant machine-type-alist))))
 
-(define-syntax log2
-  (syntax-rules ()
-    [(_ n) (integer-length (- n 1))]))
+;; ---------------------------------------------------------------------
+;; Some object-layout constants:
 
 ; a string-char is a 32-bit equivalent of a ptr char: identical to a
 ; ptr char on 32-bit machines and the low-order half of a ptr char on
@@ -409,6 +429,23 @@
 ; This is safe since we never forward flonums.
 (define-constant byte-alignment
   (max (constant typemod) (* 2 (constant ptr-bytes))))
+(define-constant ptr-alignment
+  (/ (constant byte-alignment) (constant ptr-bytes)))
+
+;; Stack alignment may be needed for unboxed floating-point values:
+(constant-case ptr-bits
+  [(32) (define-constant stack-word-alignment 2)]
+  [(64) (define-constant stack-word-alignment 1)])
+
+;; seginfo offsets, must be consistent with `seginfo` in "types.h"
+(define-constant seginfo-space-disp 0)
+(define-constant seginfo-generation-disp 1)
+(define-constant seginfo-list-bits-disp (constant ptr-bytes))
+
+(define-constant list-bits-mask (- (expt 2 (constant ptr-alignment)) 1))
+
+;; ---------------------------------------------------------------------
+;; Fasl encoding tags:
 
 ;;; fasl codes---see fasl.c for documentation of representation
 
@@ -480,6 +517,12 @@
   (bytevector (constant fasl-type-header) 0 0 0
     (char->integer #\c) (char->integer #\h) (char->integer #\e) (char->integer #\z)))
 
+;; ---------------------------------------------------------------------
+;; Relocation repersentation
+
+;; A recolcation tells the linker where to update machine code to link
+;; in library functions, literal Scheme objects, etc.
+
 (define-syntax define-enumerated-constants
   (lambda (x)
     (syntax-case x ()
@@ -505,6 +548,7 @@
   (ppc reloc-ppccall reloc-ppcload)
   (x86_64 reloc-x86_64-call reloc-x86_64-jump reloc-x86_64-popcount)
   (arm32 reloc-arm32-abs reloc-arm32-call reloc-arm32-jump)
+  (arm64 reloc-arm64-abs reloc-arm64-call reloc-arm64-jump)
   (ppc32 reloc-ppc32-abs reloc-ppc32-call reloc-ppc32-jump))
 
 (constant-case ptr-bits
@@ -527,6 +571,9 @@
 
 (macro-define-structure (reloc type item-offset code-offset long?))
 
+;; ---------------------------------------------------------------------
+;; Some flags to cooperate with the C-implemented kernel:
+
 (define-constant SERROR    #x0000)
 (define-constant STRVNCATE #x0001) ; V for U to avoid msvc errno.h conflict
 (define-constant SREPLACE  #x0002)
@@ -605,9 +652,8 @@
 (define-constant ERROR_VALUES 7)
 (define-constant ERROR_MVLET 8)
 
-;;; allocation spaces
-(define-constant space-locked #x20)         ; lock flag
-(define-constant space-old #x40)            ; oldspace flag
+;; ---------------------------------------------------------------------
+;; GC constants
 
 (define-syntax define-alloc-spaces
   (lambda (x)
@@ -634,10 +680,6 @@
                        [(cchar ...) #'(real-cchar ... unreal-cchar ... last-unreal-cchar)]
                        [(value ...) #'(real-value ... unreal-value ... last-unreal-value)])
            (with-syntax ([(space-name ...) (map (lambda (n) (construct-name n "space-" n)) #'(name ...))])
-             (unless (< (syntax->datum #'last-unreal-value) (constant space-locked))
-               ($oops 'define-alloc-spaces "conflict with space-locked"))
-             (unless (< (syntax->datum #'last-unreal-value) (constant space-old))
-               ($oops 'define-alloc-spaces "conflict with space-old"))
              #'(begin
                  (define-constant space-name value) ...
                  (define-constant real-space-alist '((real-name . real-value) ...))
@@ -663,12 +705,14 @@
       (impure-record "ip-rec" #\s 10)    ;
       (impure-typed-object "ip-tobj" #\t 11) ; as needed (instead of impure) for backtraces
       (closure "closure" #\l 12)         ; as needed (instead of pure/impure) for backtraces
-      (count-pure "count-pure" #\y 13)     ; like pure, but delayed for counting from roots
-      (count-impure "count-impure" #\z 14)); like impure-typed-object, but delayed for counting from roots
+      (immobile-impure "im-impure" #\I 13) ; like impure, but for immobile objects
+      (count-pure "cnt-pure" #\y 14)     ; like pure, but delayed for counting from roots
+      (count-impure "cnt-impure" #\z 15)); like impure-typed-object, but delayed for counting from roots
     (unswept
-      (data "data" #\d 15)))             ; unswept objects allocated here
+      (data "data" #\d 16)               ; unswept objects allocated here
+      (immobile-data "im-data" #\D 17))) ; like data, but non-moving
   (unreal
-    (empty "empty" #\e 16)))             ; available segments
+    (empty "empty" #\e 18)))             ; available segments
 
 ;;; enumeration of types for which gc tracks object counts
 ;;; also update gc.c
@@ -701,9 +745,13 @@
 (define-constant countof-ephemeron 25)
 (define-constant countof-stencil-vector 26)
 (define-constant countof-record 27)
-(define-constant countof-types 28)
+(define-constant countof-phantom 28)
+(define-constant countof-types 29)
 
-;;; type-fixnum is assumed to be all zeros by at least by vector, fxvector,
+;; ---------------------------------------------------------------------
+;; Tags that are part of the pointer represeting an object:
+
+;;; type-fixnum is assumed to be all zeros by at least vector, fxvector,
 ;;; and bytevector index checks
 (define-constant type-fixnum           0) ; #b100/#b000 32-bit, #b000 64-bit
 (define-constant type-pair         #b001)
@@ -714,6 +762,9 @@
 (define-constant type-immediate    #b110)
 (define-constant type-typed-object #b111)
 
+;; ---------------------------------------------------------------------
+;; Immediate values; note that these all end with `type-immediate`:
+
 ;;; note: for type-char, leave at least fixnum-offset zeros at top of
 ;;; type byte to simplify char->integer conversion
 (define-constant type-boolean           #b00000110)
@@ -729,6 +780,10 @@
 (define-constant ptr sbwp               #b01001110)
 (define-constant ptr ftype-guardian-rep #b01010110)
 
+;; ---------------------------------------------------------------------
+;; Initial type word in an object that is represented by a
+;; `type-typed-object` pointer:
+
 ;;; on 32-bit machines, vectors get two primary tag bits, including
 ;;; one for the immutable flag, and so do bytevectors, so their maximum
 ;;; lengths are equal to the most-positive fixnum on 32-bit machines.
@@ -770,6 +825,9 @@
 (define-constant type-phantom          #b01111110)
 (define-constant type-record                #b111)
 
+;; ---------------------------------------------------------------------
+;; Bit and byte offsets for different types of objects:
+
 (define-constant code-flag-system           #b0000001)
 (define-constant code-flag-continuation     #b0000010)
 (define-constant code-flag-template         #b0000100)
@@ -788,6 +846,26 @@
 (define-constant iptr most-negative-fixnum
                  (- (expt 2 (- (constant fixnum-bits) 1))))
 
+(define-constant double too-negative-flonum-for-fixnum
+  (cond
+    ;; 64-bit fixnums: -1.0 is the same flonum
+    [(fl= (exact->inexact (constant most-negative-fixnum))
+          (fl- (exact->inexact (constant most-negative-fixnum)) 1.0))
+     ;; Find the next lower flonum:
+     (let loop ([amt 2.0])
+       (let ([v (fl- (exact->inexact (constant most-negative-fixnum)) amt)])
+         (if (fl= v (exact->inexact (constant most-negative-fixnum)))
+             (loop (fl* 2.0 amt))
+             v)))]
+    [else
+     (fl- (exact->inexact (constant most-negative-fixnum)) 1.0)]))
+
+(define-constant double too-positive-flonum-for-fixnum
+  ;; Although adding 1.0 doesn't change the flonum for
+  ;; 64-bit fixnums, the flonum doesn't fit in a fixnum, so
+  ;; this is the upper bbound we want either way:
+  (fl+ (exact->inexact (constant most-positive-fixnum)) 1.0))
+
 (define-constant fixnum-offset (- (constant ptr-bits) (constant fixnum-bits)))
 
 ; string length field (high bits) + immutabilty is stored with type
@@ -880,6 +958,9 @@
            (fxsll (constant code-flag-single-valued)
                   (constant code-flags-offset))))
 
+;; ---------------------------------------------------------------------
+;; Masks and offsets for checking types:
+
 ;; type checks are generally performed by applying the mask to the object
 ;; then comparing against the type code.  a mask equal to
 ;; (constant byte-constant-mask) implies that the object being
@@ -1010,6 +1091,9 @@
 (define-constant stencil-vector-mask-bits    (fx- (constant ptr-bits)
                                                   (constant stencil-vector-mask-offset)))
 
+;; ---------------------------------------------------------------------
+;; Helpers to define object layouts:
+
 ;;; record-datatype must be defined before we include layout.ss
 ;;; (maybe should move into that file??)
 ;;; We allow Scheme inputs for both signed and unsigned integers to range from
@@ -1233,6 +1317,9 @@
                      (define-constant name-field-disp field-disp)
                      ...))))))])))
 
+;; ---------------------------------------------------------------------
+;; Object layouts:
+
 (define-primitive-structure-disps typed-object type-typed-object
   ([iptr type]))
 
@@ -1249,8 +1336,8 @@
 (define-primitive-structure-disps ephemeron type-pair
   ([ptr car]
    [ptr cdr]
-   [ptr next] ; `next` is needed by the GC to keep track of pending ephemerons
-   [ptr trigger-next])) ; `trigger-next` is similar, but for segment-specific lists
+   [ptr prev-ref] ; `prev-ref` and `next` are used by the GC
+   [ptr next]))
 
 (define-primitive-structure-disps tlc type-typed-object
   ([iptr type]
@@ -1444,7 +1531,8 @@
    [void* lz4-out-buffer]
    [U64 instr-counter]
    [U64 alloc-counter]
-   [ptr parameters]))
+   [ptr parameters]
+   [double fpregs (constant asm-fpreg-max)]))
 
 (define tc-field-list
   (let f ([ls (oblist)] [params '()])
@@ -1583,6 +1671,9 @@
     (with-syntax ([type (datum->syntax #'* (filter-scheme-type 'string-char))])
       #''type)))
 
+;; ---------------------------------------------------------------------
+;; Flags and structures for the compiler's internal communcation:
+
 (define-constant annotation-debug   #b0001)
 (define-constant annotation-profile #b0010)
 (define-constant annotation-all     #b0011)
@@ -1682,6 +1773,7 @@
   (unsafe                   #b00001000000000000000000)
   (unrestricted             #b00010000000000000000000)
   (safeongoodargs           #b00100000000000000000000)
+  (unboxed-arguments        #b10000000000000000000000) ; always accepts unboxed 'flonum arguments, up to inline-args-limit
   (cptypes2                 #b01000000000000000000000)
   (cptypes3                 cptypes2)
   (cptypes2x                cptypes2)
@@ -1690,7 +1782,9 @@
   (alloc                    (or proc discard true))
   ; would be nice to check that these and only these actually have cp0 partial folders
   (partial-folder           (or cp02 cp03))
-)
+  )
+
+(define-constant inline-args-limit 10)
 
 (define-flags cp0-info-mask
   (pure-known                    #b0000000001)
@@ -1800,7 +1894,10 @@
   (syntax-rules ()
     ((_ x)
      (float-type-case
-       [(ieee) (fx= ($flonum-exponent x) #x7ff)]))))
+      [(ieee) (fx= ($flonum-exponent x) #x7ff)]))))
+
+;; #t => incompatibility with older Chez Scheme:
+(define-constant nan-single-comparison-true? #t)
 
 (define-syntax on-reset
   (syntax-rules ()
@@ -1869,7 +1966,8 @@
   (syntax-rules ()
     ((_ x) (let ((t x)) (and (pair? t) (symbol? (car t)))))))
 
-;;; heap/stack mangement constants
+;; ---------------------------------------------------------------------
+;; Heap/stack mangement constants:
 
 (define-constant collect-interrupt-index 1)
 (define-constant timer-interrupt-index 2)
@@ -1979,6 +2077,9 @@
          (lambda () (mutex-release $tc-mutex) (enable-interrupts)))])
     (identifier-syntax critical-section)))
 
+;; ---------------------------------------------------------------------
+;; More object-representation flags and offsets:
+
 (define-constant hashtable-default-size 8)
 
 (define-constant eq-hashtable-subtype-normal 0)
@@ -2008,6 +2109,9 @@
 (define-constant time-collector-cpu 5)
 (define-constant time-collector-real 6)
 
+;; ---------------------------------------------------------------------
+;; General helpers for the compiler and runtime implementation:
+
 (define-syntax default-run-cp0
   (lambda (x)
     (syntax-case x ()
@@ -2379,7 +2483,20 @@
        #`(let ([x arg])
            (unless (pred x)
              ($oops who #,(format "~~s is not a ~a" (datum type)) x)))])))
- 
+
+;; ---------------------------------------------------------------------
+;; Library entries and C entries
+
+;; A library entry connects with a libspec to describe a library
+;; function that can be referenced directly by machine code and that
+;; will need to be updated by the linker. The C-implemented kernel may
+;; also refer to these values.
+
+;; A C entry is a pointer communicated from the C-implemented kernel
+;; to the compiler and runtime system. The linker deals with them in a
+;; similar way --- it's just that the refer to C functions and globals
+;; instead of Scheme-implemented functions.
+
 (eval-when (load eval)
 (define-syntax lookup-libspec
   (lambda (x)
@@ -2499,6 +2616,7 @@
      (cfl/ #f 2 #f #t)
      (negate #f 1 #f #t)
      (flnegate #f 1 #t #t)
+     (flabs #f 1 #t #t)
      (call-error #f 0 #f #f)
      (unsafe-unread-char #f 2 #f #t)
      (map-car #f 1 #f #t)
@@ -2519,6 +2637,7 @@
      (fxsll #f 2 #f #t)
      (fxsrl #f 2 #t #t)
      (fxsra #f 2 #t #t)
+     (fixnum->flonum #f 1 #t #t)
      (append #f 2 #f #t)
      (values-error #f 0 #f #f)
      (dooverflow #f 0 #f #f)
@@ -2636,6 +2755,8 @@
      (bytevector-s8-set! #f 3 #f #t)
      (bytevector-u8-set! #f 3 #f #t)
      (bytevector=? #f 2 #f #f)
+     (bytevector-ieee-double-native-ref #f 2 #t #t)
+     (bytevector-ieee-double-native-set! #f 2 #t #t)
      (real->flonum #f 2 #f #t)
      (unsafe-port-eof? #f 1 #f #t)
      (unsafe-lookahead-u8 #f 1 #f #t)
@@ -2660,6 +2781,23 @@
      (fl>? #f 2 #t #t)
      (fl<=? #f 2 #t #t)
      (fl>=? #f 2 #t #t)
+     (flsqrt #f 1 #t #t)
+     (flround #f 1 #t #t)
+     (flfloor #f 1 #t #t)
+     (flceiling #f 1 #t #t)
+     (fltruncate #f 1 #t #t)
+     (flsin #f 1 #t #t)
+     (flcos #f 1 #t #t)
+     (fltan #f 1 #t #t)
+     (flasin #f 1 #t #t)
+     (flacos #f 1 #t #t)
+     (flatan #f 1 #t #t)
+     (flatan2 #f 2 #t #t)
+     (flexp #f 1 #t #t)
+     (fllog #f 1 #t #t)
+     (fllog2 #f 2 #t #t)
+     (flexpt #f 2 #t #t)
+     (flonum->fixnum #f 1 #t #t)
      (bitwise-and #f 2 #f #t)
      (bitwise-ior #f 2 #f #t)
      (bitwise-xor #f 2 #f #t)
@@ -2777,5 +2915,20 @@
      Scall-any-results
      segment-info
      bignum-mask-test
-     ))
+     flfloor
+     flceiling
+     flround
+     fltruncate
+     flsin
+     flcos
+     fltan
+     flasin
+     flacos
+     flatan
+     flatan2
+     flexp
+     fllog
+     fllog2
+     flexpt
+     flsqrt))
 )
diff --git a/src/ChezScheme/s/compile.ss b/src/ChezScheme/s/compile.ss
index 368c693147..41763d2f32 100644
--- a/src/ChezScheme/s/compile.ss
+++ b/src/ChezScheme/s/compile.ss
@@ -177,6 +177,24 @@
                                   (let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))])
                                     (mkc0 (cdr c*) a (cons r r*) a1 x*))))]
                              [else (c-assembler-output-error c)])]
+                          [(arm64)
+                           (record-case c
+                             [(arm64-abs) (n x)
+                              (let ([a1 (fx- a 16)]) ; movz, movk, movk, movk
+                                (let ([x* (cons (mkcode x) x*)])
+                                  (let ([r ($reloc (constant reloc-arm64-abs) n (fx- a1 ra))])
+                                    (mkc0 (cdr c*) a (cons r r*) a1 x*))))]
+                             [(arm64-call) (n x)
+                              (let ([a1 (fx- a 20)]) ; movz, movk, movk, movk, bl
+                                (let ([x* (cons (mkcode x) x*)])
+                                  (let ([r ($reloc (constant reloc-arm64-call) n (fx- a1 ra))])
+                                    (mkc0 (cdr c*) a (cons r r*) a1 x*))))]
+                             [(arm64-jump) (n x)
+                              (let ([a1 (fx- a 20)]) ; movz, movk, movk, movk, b
+                                (let ([x* (cons (mkcode x) x*)])
+                                  (let ([r ($reloc (constant reloc-arm64-jump) n (fx- a1 ra))])
+                                    (mkc0 (cdr c*) a (cons r r*) a1 x*))))]
+                             [else (c-assembler-output-error c)])]
                           [(ppc32)
                            (record-case c
                              [(ppc32-abs) (n x)
@@ -269,6 +287,10 @@
                           (record-case x
                             [(arm32-abs arm32-call arm32-jump) (n x) (build x d)]
                             [else (void)])]
+                         [(arm64)
+                          (record-case x
+                            [(arm64-abs arm64-call arm64-jump) (n x) (build x d)]
+                            [else (void)])]
                          [(ppc32)
                           (record-case x
                             [(ppc32-abs ppc32-call ppc32-jump) (n x) (build x d)]
@@ -396,6 +418,21 @@
                                (let ([r ($reloc (constant reloc-arm32-jump) n (fx- a1 ra))])
                                  (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
                             [else (c-assembler-output-error c)])]
+                         [(arm64)
+                          (record-case c
+                            [(arm64-abs) (n x)
+                             (let ([a1 (fx- a 16)]) ; movz, movk, movk, movk
+                               (let ([r ($reloc (constant reloc-arm64-abs) n (fx- a1 ra))])
+                                 (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
+                            [(arm64-call) (n x)
+                             (let ([a1 (fx- a 20)]) ; movz, movk, movk, movk, bl
+                               (let ([r ($reloc (constant reloc-arm64-call) n (fx- a1 ra))])
+                                 (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
+                            [(arm64-jump) (n x)
+                             (let ([a1 (fx- a 20)]) ; movz, movk, movk, movk, b
+                               (let ([r ($reloc (constant reloc-arm64-jump) n (fx- a1 ra))])
+                                 (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))]
+                            [else (c-assembler-output-error c)])]
                          [(ppc32)
                           (record-case c
                             [(ppc32-abs) (n x)
diff --git a/src/ChezScheme/s/cp0.ss b/src/ChezScheme/s/cp0.ss
index 977d0cfdb9..74825ca0ae 100644
--- a/src/ChezScheme/s/cp0.ss
+++ b/src/ChezScheme/s/cp0.ss
@@ -211,20 +211,20 @@
                                  (cdr old-ids) 
                                  (and opnds (cdr opnds))
                                  (cons
-                                   (let ([old-id (car old-ids)])
-                                     (make-prelex
-                                       (prelex-name old-id)
-                                       (let ([flags (prelex-flags old-id)])
-                                         (fxlogor
-                                           (fxlogand flags (constant prelex-sticky-mask))
-                                           (fxsll (fxlogand flags (constant prelex-is-mask))
-                                             (constant prelex-was-flags-offset))))
-                                       (prelex-source old-id)
-                                       (and opnds
-                                            (let ([opnd (car opnds)])
-                                              (when (operand? opnd)
-                                                (operand-name-set! opnd (prelex-name old-id)))
-                                              opnd))))
+                                   (let ([old-id (car old-ids)]
+                                         [opnd (and opnds (car opnds))])
+                                     (let ([id (make-prelex
+                                                 (prelex-name old-id)
+                                                 (let ([flags (prelex-flags old-id)])
+                                                   (fxlogor
+                                                     (fxlogand flags (constant prelex-sticky-mask))
+                                                     (fxsll (fxlogand flags (constant prelex-is-mask))
+                                                       (constant prelex-was-flags-offset))))
+                                                 (prelex-source old-id)
+                                                 opnd)])
+                                       (when (operand? opnd)
+                                         (operand-name-set! opnd id))
+                                       id))
                                    rnew-ids))))])
             (values (make-env (list->vector old-ids) (list->vector new-ids) old-env) new-ids))))
       
@@ -262,6 +262,12 @@
           (set-prelex-referenced! t #t)
           t)))
 
+    (define (name->symbol name)
+      (safe-assert (or (prelex? name) (symbol? name)))
+      (if (prelex? name)
+          (prelex-name name)
+          name))
+
     ;;; contexts
 
     ;; 'value - result used, context checks for single-value result,
@@ -497,6 +503,12 @@
                      (loop e2 (if eprof `(seq ,eprof ,e1) e1))]
                     [else (values e eprof)]))
                 (values e #f))))
+        (define (possible-loop? x* body)
+          (and (fx= (length x*) 1)
+               (nanopass-case (Lsrc Expr) body
+                 [(call ,preinfo (ref ,maybe-src ,x) ,e* ...)
+                  (eq? x (car x*))]
+                 [else #f])))
         ; set up to assimilate nested let/letrec/letrec* bindings.
         ; lifting job is completed by cp0-call or letrec/letrec*
         (define (split-value e)
@@ -513,7 +525,7 @@
                [(if (ivory? body) (andmap simple/profile1? e*) (andmap ivory1? e*))
                 ; assocate each lhs with cooked operand for corresponding rhs.  make-record-constructor-descriptor,
                 ; at least, counts on this to allow protocols to be inlined.
-                (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
+                (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
                 (values (make-lifted #f x* e*) body)]
                ; okay, so we don't pass that test.  if body and e* are simple, we can
                ; still lift by making a binding for body and requesting letrec* semantics.
@@ -526,7 +538,7 @@
                #;[(and (simple? body) (andmap simple? e*))
                 (let ([t (cp0-make-temp #f)]) ; mark was-referenced?
                       (let ([x* (append x* (list t))] [e* (append e* (list body))])
-                        (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
+                        (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
                         (values (make-lifted #t x* e*) (build-ref t))))]
                ; otherwise lift out only bindings with unasigned lhs and ivory rhs
                ; we don't presently have any justification (benchmark results or expand/optimize
@@ -542,7 +554,6 @@
                             (begin
                               ; assocate each lhs with cooked operand for corresponding rhs.  see note above.
                               (prelex-operand-set! x (build-cooked-opnd e))
-                              (operand-name-set! opnd (prelex-name x))
                               (loop (cdr x*) (cdr e*) rx* re* (cons x rlx*) (cons e rle*)))
                             (loop (cdr x*) (cdr e*) (cons x rx*) (cons e re*) rlx* rle*)))))]
                [else (values #f e)])]
@@ -550,9 +561,11 @@
             ; pure OR body to be pure, since we can't separate non-pure
             ; RHS and body expressions
             [(letrec ([,x* ,e*] ...) ,body)
-             (guard (or (ivory? body) (andmap ivory1? e*)))
+             (guard (and (or (ivory? body) (andmap ivory1? e*))
+                         ;; don't break apart (potential) loops
+                         (not (possible-loop? x* body))))
              ; assocate each lhs with cooked operand for corresponding rhs.  see note above.
-             (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
+             (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
              (values (make-lifted #f x* e*) body)]
             ; force the issue by creating an extra tmp for body
             ; we don't presently have any justification (benchmark results or expand/optimize
@@ -561,12 +574,14 @@
             #;[(letrec ([,x* ,e*] ...) ,body)
              (let ([x (cp0-make-temp #f)])
                (let ([x* (append x* (list x))] [e* (append e* (list body))])
-                 (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
+                 (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
                  (values (make-lifted #t x* e*) (build-ref x))))]
             [(letrec* ([,x* ,e*] ...) ,body)
-             (guard (or (ivory? body) (andmap ivory1? e*)))
+             (guard (and (or (ivory? body) (andmap ivory1? e*))
+                         ;; don't break apart (potential) loops
+                         (not (possible-loop? x* body))))
              ; assocate each lhs with cooked operand for corresponding rhs.  see note above.
-             (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
+             (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
              (values (make-lifted #t x* e*) body)]
             ; force the issue by creating an extra tmp for body.
             ; we don't presently have any justification (benchmark results or expand/optimize
@@ -575,7 +590,7 @@
             #;[(letrec* ([,x* ,e*] ...) ,body)
              (let ([x (cp0-make-temp #f)])
                (let ([x* (append x* (list x))] [e* (append e* (list body))])
-                 (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
+                 (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
                  (values (make-lifted #t x* e*) (build-ref x))))]
             ; we can lift arbitrary subforms of record forms if we also lift
             ; a binding for the record form itself.  there's no worry about
@@ -607,7 +622,7 @@
                      (values #f e)
                      (let ([x (cp0-make-temp #f)])
                        (let ([x* (append liftmt* (list x))] [e* (append liftme* (list e))])
-                         (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e)) (operand-name-set! opnd (prelex-name x))) x* e*)
+                         (for-each (lambda (x e) (prelex-operand-set! x (build-cooked-opnd e))) x* e*)
                          (values (make-lifted #t x* e*) (build-ref x)))))))]
             [else (values #f e)]))
         (or (operand-value opnd)
@@ -662,7 +677,7 @@
                     (let ((opnd (car unused)))
                       (let ((e (operand-value opnd)))
                         (if e
-                            (if (simple? e)
+                            (if (simple1? e)
                                 (if (operand-singly-referenced-score opnd)
                                     ; singly-referenced integration attempt in copy2 succeeded
                                     (f (cdr unused) (fx+ (operand-singly-referenced-score opnd) n) todo)
@@ -695,19 +710,26 @@
           [(quote ,d) d]
           [else (sorry! who "~s is not a constant" x)])))
 
-    (define (name-preinfo-lambda! preinfo name)
-      (when (and (symbol? name)
-                 ;; Avoid replacing a name from an optimized-away `let` pattern:
-                 (not (preinfo-lambda-name preinfo)))
-        (preinfo-lambda-name-set! preinfo
-           (let ([x ($symbol-name name)])
-             (if (pair? x) (or (cdr x) (car x)) x)))))
-    
+    (define (symbol->lambda-name sym)
+      (let ([x ($symbol-name sym)])
+        (if (pair? x) (or (cdr x) (car x)) x)))
+
+    (define (preinfo-lambda-set-name-and-flags preinfo name flags)
+      (let ([new-name (and
+                       name
+                       ;; Avoid replacing a name from an optimized-away `let` pattern:
+                       (not (preinfo-lambda-name preinfo))
+                       (symbol->lambda-name (name->symbol name)))])
+        (if (or new-name
+                (not (fx= flags (preinfo-lambda-flags preinfo))))
+            (make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo)
+              (preinfo-lambda-libspec preinfo) (or new-name (preinfo-lambda-name preinfo)) flags)
+            preinfo)))
+
     (define preinfo-call->preinfo-lambda
       (lambda (preinfo name)
-        (let ([new-preinfo (make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo))])
-          (name-preinfo-lambda! new-preinfo name)
-          new-preinfo)))
+        (make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo)
+           #f (and name (symbol->lambda-name (name->symbol name))))))
 
     (define build-quote
       (lambda (d)
@@ -853,12 +875,17 @@
 
     (define make-nontail
       (lambda (ctxt e)
-        (if (context-case ctxt
-              [(tail) (single-valued-without-inspecting-continuation? e)]
-              [(ignored) (single-valued? e)]
-              [else #t])
-            e
-            (build-primcall 3 '$value (list e)))))
+        (context-case ctxt
+          [(tail)
+           (if (single-valued-without-inspecting-continuation? e)
+               e
+               (build-primcall 3 '$value (list e)))]
+          ;; An 'effect, 'ignored, 'value, or 'test position will not
+          ;; have any attachment on the immediate continuation.
+          ;; Also, an 'ignored, 'value, or 'test position will already
+          ;; enforce a single result value
+          [(effect) (safe-single-value e)]
+          [else e])))
 
     (define result-exp
       (lambda (e)
@@ -1337,9 +1364,9 @@
               [(pariah) #f]
               [else ($oops who "unrecognized record ~s" e)]))))
 
-      ;; Returns #t, #f, or a prelex for lambda that needs to be
+      ;; Returns #t, #f, or a prelex for a lambda that needs to be
       ;; single-valued to imply #t. The prelex case is useful to
-      ;; detect a loop.
+      ;; detect a single-valued loop.
       (define-who single-valued
         (lambda (e)
           (with-memoize () e
@@ -1356,13 +1383,16 @@
                                (and proc-e
                                     (memoize (procedure-single-valued proc-e #f))))))]
                    [(case-lambda ,preinfo ,cl* ...)
-                    (memoize (fold-left (lambda (r cl)
-                                          (and r
-                                               (nanopass-case (Lsrc CaseLambdaClause) cl
-                                                 [(clause (,x* ...) ,interface ,body)
-                                                  (single-valued-join r (single-valued body))])))
-                                        #t
-                                        cl*))]
+                    (memoize (or
+                              (all-set? (constant code-flag-single-valued)
+                                        (preinfo-lambda-flags preinfo))
+                              (fold-left (lambda (r cl)
+                                           (and r
+                                                (nanopass-case (Lsrc CaseLambdaClause) cl
+                                                  [(clause (,x* ...) ,interface ,body)
+                                                   (single-valued-join r (single-valued body))])))
+                                         #t
+                                         cl*)))]
                    [(ref ,maybe-src ,x)
                     (let ([v (and (not (prelex-was-assigned x))
                                   (let ([opnd (prelex-operand x)])
@@ -1373,14 +1403,17 @@
                              [(case-lambda ,preinfo ,cl* ...)
                               ;; Don't recur into the clauses, since that
                               ;; could send us into a loop for a `letrec`
-                              ;; binding. But use the preinfo as a summary
+                              ;; binding. But use the prelex as a summary
                               ;; or a way to tie a loop:
-                              (preinfo->single-valued preinfo)]
+                              (preinfo->single-valued preinfo x)]
                              [else #f])))]
-                   ;; Recognize call to a loop, and use the loop's preinfo in that case:
+                   ;; Recognize call to a loop, and use the loop's prelex in that case:
                    [(letrec ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2))
                     (and (eq? x1 x2)
-                         (preinfo->single-valued preinfo))]
+                         (preinfo->single-valued preinfo x1))]
+                   [(letrec* ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2))
+                    (and (eq? x1 x2)
+                         (preinfo->single-valued preinfo x1))]
                    [else #f]))]
               [(ref ,maybe-src ,x) #t]
               [(case-lambda ,preinfo ,cl* ...) #t]
@@ -1404,13 +1437,13 @@
               [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
               [else ($oops who "unrecognized record ~s" e)]))))
 
-      (define (preinfo->single-valued preinfo)
+      (define (preinfo->single-valued preinfo x)
         ;; If the single-valued flag is set, simplify to #t,
-        ;; otherwise return the preinfo to mean "single-valued
-        ;; of this lambda is "single-valued".
+        ;; otherwise return the prelex x to mean "single-valued
+        ;; if the lambda for x is single-valued".
         (or (all-set? (constant code-flag-single-valued)
                       (preinfo-lambda-flags preinfo))
-            preinfo))
+            x))
 
       (define single-valued-join
         (lambda (a b)
@@ -1418,8 +1451,8 @@
            [(eq? a b) a]
            [(eq? a #t) b]
            [(eq? b #t) a]
-           ;; If `a` and `b` are different preinfos, we currently give
-           ;; up, because a preinfo is used only to find a
+           ;; If `a` and `b` are different prelexes, we currently give
+           ;; up, because a prelex is used only to find a
            ;; single-function fixpoint.
            [else #f])))
 
@@ -1432,8 +1465,8 @@
           (cond
            [(eq? r #t) #t]
            [(eq? r #f) #f]
-           [else (all-set? (constant code-flag-single-valued)
-                           (preinfo-lambda-flags r))])))
+           ;; conservative assumption for a prelex:
+           [else #f])))
 
       (define-who single-valued-without-inspecting-continuation?
         (lambda (e)
@@ -1718,7 +1751,7 @@
             ; these operands will be cleared by with-extended-env
             (for-each (lambda (id opnd)
                         (prelex-operand-set! id opnd)
-                        (operand-name-set! opnd (prelex-name id)))
+                        (operand-name-set! opnd id))
               ids opnds)
             ; for r5rs letrec semantics: prevent copy propagation of references
             ; to lhs id if rhs might invoke call/cc
@@ -2007,21 +2040,25 @@
     (define record-equal?
       ; not very ambitious
       (lambda (e1 e2 ctxt)
-        (if (unused-value-context? ctxt)
-            (and (simple? e1) (simple? e2))
-            (nanopass-case (Lsrc Expr) e1
-              [(ref ,maybe-src1 ,x1)
-               (nanopass-case (Lsrc Expr) e2
-                 [(ref ,maybe-src2 ,x2) (eq? x1 x2)]
-                 [else #f])]
-              [(quote ,d1)
-               (nanopass-case (Lsrc Expr) e2
-                 [(quote ,d2)
-                  (if (eq? ctxt 'test)
-                      (if d1 d2 (not d2))
-                      (eq? d1 d2))]
-                 [else #f])]
-              [else #f]))))
+        (cond
+          [(eq? ctxt 'effect)
+           (and (simple? e1) (simple? e2))]
+          [(eq? ctxt 'ignored)
+           (and (simple1? e1) (simple1? e2))]
+          [else
+           (nanopass-case (Lsrc Expr) e1
+             [(ref ,maybe-src1 ,x1)
+              (nanopass-case (Lsrc Expr) e2
+                [(ref ,maybe-src2 ,x2) (eq? x1 x2)]
+                [else #f])]
+             [(quote ,d1)
+              (nanopass-case (Lsrc Expr) e2
+                [(quote ,d2)
+                 (if (eq? ctxt 'test)
+                     (if d1 d2 (not d2))
+                     (eq? d1 d2))]
+                [else #f])]
+             [else #f])])))
 
     (module ()
       (define-syntax define-inline
@@ -2532,7 +2569,7 @@
                             (let ([folded (generic-op a d)])
                               (and (target-fixnum? folded) folded)))))]
                 [else #f]))))
-        (define (partial-fold-plus level orig-arg* ctxt prim op generic-op ident bottom? assoc-at-level)
+        (define (partial-fold-plus level orig-arg* ctxt prim op generic-op ident bottom? assoc-at-level direct-result?)
           (define fold? (make-fold? op generic-op))
           (let loop ([arg* orig-arg*] [a ident] [val* '()] [used '()] [unused '()])
             (if (null? arg*)
@@ -2557,7 +2594,7 @@
                       (cond
                         [(null? val*) `(quote ,a)]
                         [(eqv? a ident)
-                         (if (and (fx= level 3) (null? (cdr val*)))
+                         (if (and (fx= level 3) (null? (cdr val*)) (direct-result? (car val*)))
                              (car val*)
                              (build-primcall (app-preinfo ctxt) level prim val*))]
                         [else
@@ -2619,15 +2656,17 @@
             [(_ plus prim generic-op ident bottom?)
              (partial-folder plus prim generic-op ident bottom? #f)]
             [(_ plus prim generic-op ident bottom? assoc-at-level)
+             (partial-folder plus prim generic-op ident bottom? assoc-at-level (lambda (e) #t))]
+            [(_ plus prim generic-op ident bottom? assoc-at-level direct-result?)
              (begin
                (define-inline 2 prim
                  ; (fl+) might should return -0.0, but we force it to return +0.0 per TSPL4
                  [() (residualize-seq '() '() ctxt) `(quote ,(if (eqv? ident -0.0) +0.0 ident))]
-                 [arg* (partial-fold-plus 2 arg* ctxt 'prim prim generic-op ident bottom? assoc-at-level)])
+                 [arg* (partial-fold-plus 2 arg* ctxt 'prim prim generic-op ident bottom? assoc-at-level direct-result?)])
                (define-inline 3 prim
                  ; (fl+) might should return -0.0, but we force it to return +0.0 per TSPL4
                  [() (residualize-seq '() '() ctxt) `(quote ,(if (eqv? ident -0.0) +0.0 ident))]
-                 [arg* (partial-fold-plus 3 arg* ctxt 'prim prim generic-op ident bottom? assoc-at-level)]))]
+                 [arg* (partial-fold-plus 3 arg* ctxt 'prim prim generic-op ident bottom? assoc-at-level direct-result?)]))]
             [(_ minus prim generic-op ident)
              (begin
                (define-inline 2 prim
@@ -2647,9 +2686,9 @@
             [(_ plus r6rs:prim prim generic-op ident bottom? assoc-at-level)
              (begin
                (define-inline 2 r6rs:prim
-                 [(arg1 arg2) (partial-fold-plus 2 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom? assoc-at-level)])
+                 [(arg1 arg2) (partial-fold-plus 2 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom? assoc-at-level (lambda (x) #t))])
                (define-inline 3 r6rs:prim
-                 [(arg1 arg2) (partial-fold-plus 3 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom? assoc-at-level)]))]
+                 [(arg1 arg2) (partial-fold-plus 3 (list arg1 arg2) ctxt 'prim prim generic-op ident bottom? assoc-at-level (lambda (x) #t))]))]
             [(_ minus r6rs:prim prim generic-op ident)
              (begin
                (define-inline 2 r6rs:prim
@@ -2661,18 +2700,28 @@
                  [(arg1 arg2)
                   (partial-fold-minus 3 arg1 (list arg2) ctxt 'prim prim generic-op ident)]))]))
 
+        (define obviously-fl?
+          ;; We keep single-argument `fl+` and `fl*` as an unboxing hint to the back end,
+          ;; but the hint is not necessary if the argument is the result of a primitive that
+          ;; produces fonums
+          (lambda (e)
+            (nanopass-case (Lsrc Expr) e
+              [(quote ,d) (flonum? d)]
+              [(call ,preinfo ,pr ,e* ...) (eq? 'flonum ($sgetprop (primref-name pr) '*result-type* #f))]
+              [else #f])))
+
         ; handling nans here using the support for handling exact zero in
         ; the multiply case.  maybe shouldn't bother with nans anyway.
         (partial-folder plus + + 0 generic-nan?)
         (partial-folder plus fx+ + 0 (lambda (x) #f) 3)
         (r6rs-fixnum-partial-folder plus r6rs:fx+ fx+ + 0 (lambda (x) #f) 3)
-        (partial-folder plus fl+ fl+ -0.0 fl-nan?)
+        (partial-folder plus fl+ fl+ -0.0 fl-nan? #f obviously-fl?)
         (partial-folder plus cfl+ cfl+ -0.0 cfl-nan?)
 
         (partial-folder plus * * 1 exact-zero?)   ; exact zero trumps nan
         (partial-folder plus fx* * 1 exact-zero? 3)
         (r6rs-fixnum-partial-folder plus r6rs:fx* fx* * 1 exact-zero? 3)
-        (partial-folder plus fl* fl* 1.0 fl-nan?)
+        (partial-folder plus fl* fl* 1.0 fl-nan? #f obviously-fl?)
         (partial-folder plus cfl* cfl* 1.0 cfl-nan?)
 
         ; not handling nans here since we don't have support for the exact
@@ -3575,7 +3624,7 @@
                                          ,void-rec
                                          ,(build-primcall 3 '$record-oops
                                             (list (let ([name (app-name ctxt)])
-                                                    (if name `(quote ,name) `(moi)))
+                                                    (if name `(quote ,(name->symbol name)) `(moi)))
                                               (build-ref rec-t)
                                               rtd-e)))
                                      ,expr))]
@@ -3590,7 +3639,7 @@
                                              ,void-rec
                                              ,(build-primcall 3 '$record-oops
                                                 (list (let ([name (app-name ctxt)])
-                                                        (if name `(quote ,name) `(moi)))
+                                                        (if name `(quote ,(name->symbol name)) `(moi)))
                                                   (build-ref rec-t)
                                                   (build-ref rtd-t))))
                                          ,expr))))])))))))
@@ -3631,7 +3680,7 @@
                                               ,void-rec
                                               ,(build-primcall 3 '$record-oops
                                                  (list (let ([name (app-name ctxt)])
-                                                         (if name `(quote ,name) `(moi)))
+                                                         (if name `(quote ,(name->symbol name)) `(moi)))
                                                    (build-ref rec-t)
                                                    rtd-e)))
                                          (if pred
@@ -3639,7 +3688,7 @@
                                                `(if ,pred ,void-rec
                                                     ,(build-primcall 3 'assertion-violationf
                                                        (list (let ([name (app-name ctxt)])
-                                                               (if name `(quote ,name) `(moi)))
+                                                               (if name `(quote ,(name->symbol name)) `(moi)))
                                                          `(quote ,(format "invalid value ~~s for foreign type ~s" type))
                                                          (build-ref val-t))))
                                                expr)
@@ -3656,7 +3705,7 @@
                                                    ,void-rec
                                                    ,(build-primcall 3 '$record-oops
                                                       (list (let ([name (app-name ctxt)])
-                                                              (if name `(quote ,name) `(moi)))
+                                                              (if name `(quote ,(name->symbol name)) `(moi)))
                                                         (build-ref rec-t)
                                                         (build-ref rtd-t))))
                                               (if pred
@@ -3664,7 +3713,7 @@
                                                     `(if ,pred ,void-rec
                                                          ,(build-primcall 3 'assertion-violationf
                                                             (list (let ([name (app-name ctxt)])
-                                                                    (if name `(quote ,name) `(moi)))
+                                                                    (if name `(quote ,(name->symbol name)) `(moi)))
                                                               `(quote ,(format "invalid value ~~s for foreign type ~s" type))
                                                               (build-ref val-t))))
                                                     expr)
@@ -4848,8 +4897,8 @@
                                    (build-let (list x) (list (build-primcall 3 'cons (list zero zero)))
                                      (build-primcall 3 'cons (list ref-x ref-x))))))
                          (build-case-lambda (let ([preinfo (preinfo-call->preinfo-lambda (app-preinfo ctxt) (app-name ctxt))])
-                                              (make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo) #f #f
-                                                (constant code-flag-guardian)))
+                                              (make-preinfo-lambda (preinfo-src preinfo) (preinfo-sexpr preinfo)
+                                                #f (preinfo-lambda-name preinfo) (constant code-flag-guardian)))
                            (cons
                              (list '()
                                (let* ([x (cp0-make-temp #t)] [ref-x (build-ref x)])
@@ -4999,7 +5048,7 @@
                (let ((e (cp0 e 'value env sc wd (prelex-name x) moi)))
                  (set-prelex-assigned! new-id #t)
                  `(set! ,maybe-src ,new-id ,e)))
-             (make-1seq ctxt (cp0 e 'ignored env sc wd (prelex-name x) moi) void-rec)))]
+             (make-1seq ctxt (cp0 e 'ignored env sc wd x moi) void-rec)))]
       [(call ,preinfo ,pr (seq ,e1 ,e2))
        (guard (eq? (primref-name pr) '$value))
        ;; This simplication probably doesn't enable optimizations, but
@@ -5058,33 +5107,34 @@
          (let-values ([(e args) (lift-let e e*)])
            (cp0-call preinfo e (build-operands args env wd moi) ctxt env sc wd name moi)))]
       [(case-lambda ,preinfo ,cl* ...)
-       (name-preinfo-lambda! preinfo name)
        (context-case ctxt
          [(value tail)
           (bump sc 1)
-          `(case-lambda ,preinfo
-             ,(let f ([cl* cl*] [mask 0] [known-single-valued #t])
-                (if (null? cl*)
-                    (begin
-                      (when (or (single-valued-reduce? known-single-valued)
-                                ;; Detect simple loop:
-                                (eq? known-single-valued preinfo))
-                        (preinfo-lambda-flags-set! preinfo (fxior (preinfo-lambda-flags preinfo)
-                                                                  (constant code-flag-single-valued))))
-                      '())
-                    (nanopass-case (Lsrc CaseLambdaClause) (car cl*)
-                      [(clause (,x* ...) ,interface ,body)
-                       (let ([new-mask (logor mask (if (fx< interface 0) (ash -1 (fx- -1 interface)) (ash 1 interface)))])
-                         (if (= new-mask mask)
-                             (f (cdr cl*) new-mask known-single-valued)
-                             (with-extended-env ((env x*) (env x* #f))
-                               (let ([body (cp0 body 'tail env sc wd #f name)])
-                                 (cons `(clause (,x* ...) ,interface ,body)
-                                       (f (cdr cl*) new-mask
-                                          (and known-single-valued
-                                               (single-valued-join known-single-valued
-                                                                   (single-valued body)))))))))])))
-             ...)]
+          (let f ([cl* cl*] [mask 0] [rcl* '()] [known-single-valued #t])
+            (if (null? cl*)
+                (let ([flags (fxior (preinfo-lambda-flags preinfo)
+                               (if (or (single-valued-reduce? known-single-valued)
+                                       ;; Detect a simple loop:
+                                       (and (prelex? name)
+                                            (eq? known-single-valued name)))
+                                   (constant code-flag-single-valued)
+                                   0))])
+                  `(case-lambda ,(preinfo-lambda-set-name-and-flags preinfo name flags)
+                     ,(reverse rcl*) ...))
+                (nanopass-case (Lsrc CaseLambdaClause) (car cl*)
+                  [(clause (,x* ...) ,interface ,body)
+                   (let ([new-mask (logor mask (if (fx< interface 0) (ash -1 (fx- -1 interface)) (ash 1 interface)))])
+                     (if (= new-mask mask)
+                         (f (cdr cl*) new-mask rcl* known-single-valued)
+                         (with-extended-env ((env x*) (env x* #f))
+                           (let ([body (cp0 body 'tail env sc wd #f name)])
+                             (f (cdr cl*) new-mask
+                                (cons (with-output-language (Lsrc CaseLambdaClause)
+                                        `(clause (,x* ...) ,interface ,body))
+                                      rcl*)
+                                (and known-single-valued
+                                     (single-valued-join known-single-valued
+                                                         (single-valued body))))))))])))]
          [(effect ignored) void-rec]
          [(test) true-rec]
          [(app)
diff --git a/src/ChezScheme/s/cpnanopass.ss b/src/ChezScheme/s/cpnanopass.ss
index 9d94a18913..ea88226b37 100644
--- a/src/ChezScheme/s/cpnanopass.ss
+++ b/src/ChezScheme/s/cpnanopass.ss
@@ -500,11 +500,11 @@
     (define-syntax define-reserved-registers
       (lambda (x)
         (syntax-case x ()
-          [(_ [regid alias ... callee-save? mdinfo] ...)
+          [(_ [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?))
+                 (define regid (make-reg 'regid 'mdinfo (tc-disp regid) callee-save? 'type))
                  (module (alias ...) (define x regid) (define alias x) ...))
                ...)])))
 
@@ -512,17 +512,27 @@
       (lambda (x)
         (assert (fx<= (constant asm-arg-reg-cnt) (constant asm-arg-reg-max)))
         (syntax-case x ()
-          [(_ regvec arg-registers extra-registers with-initialized-registers [regid reg-alias ... callee-save? mdinfo] ...)
-           (with-syntax ([((tc-disp ...) (arg-regid ...) (extra-regid ...))
-                          (syntax-case #'(regid ...) (%ac0 %xp %ts %td)
-                            [(%ac0 %xp %ts %td other ...)
+          [(_ 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)]
-                                     [rextra* '()])
+                                     [fp-offset (constant tc-fpregs-disp)]
+                                     [rextra* '()]
+                                     [rfpextra* '()])
                                (if (null? other*)
-                                   (if (fx= (length rextra*) (constant asm-arg-reg-max))
-                                       (let ([extra* (reverse rextra*)])
+                                   (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)
@@ -531,14 +541,17 @@
                                              (constant tc-td-disp)
                                              (reverse rtc-disp*))
                                            (list-head extra* (constant asm-arg-reg-cnt))
-                                           (list-tail extra* (constant asm-arg-reg-cnt))))
-                                       (syntax-error x (format "asm-arg-reg-max extra registers are not specified ~s" (syntax->datum rextra*))))
+                                           (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*) (cons #`(tc-disp #,other) rtc-disp*)
-                                            arg-offset rextra*)
-                                         (f (cdr other*) (cons arg-offset rtc-disp*)
-                                            (fx+ arg-offset (constant ptr-bytes)) (cons other rextra*))))))]
+                                         (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 8) 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
@@ -560,36 +573,39 @@
                  (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?)] ...)
+                      (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-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] ...)
+          [(_ [regid alias ... callee-save? mdinfo type] ...)
            #'(begin
                (begin
-                 (define regid (make-reg 'regid 'mdinfo #f callee-save?))
+                 (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] ...)
-              (allocable [areg areg-alias ... areg-callee-save? areg-mdinfo] ...)
-              (machine-depdendent [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo] ...))
-           (with-implicit (k regvec arg-registers extra-registers real-register? with-initialized-registers)
+          [(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] ...)
-                 (define-allocable-registers regvec arg-registers extra-registers with-initialized-registers [areg areg-alias ... areg-callee-save? areg-mdinfo] ...)
-                 (define-machine-dependent-registers [mdreg mdreg-alias ... mdreg-callee-save? mdreg-mdinfo] ...)
+                 (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 ()
@@ -598,9 +614,17 @@
     (architecture registers)
 
     ; pseudo register used for mref's with no actual index
-    (define %zero (make-reg 'zero #f #f #f))
-
-    ; define %ref-ret to be sfp[0] on machines w/no ret register
+    (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
@@ -625,10 +649,18 @@
         (make-libspec-label 'event-detour (lookup-libspec event-detour)
           (reg-cons* %ret %cp %ac0 arg-registers))))
 
-    (module (frame-vars get-fv)
+    ;; Both 'fp or both not
+    (define (compatible-var-types? t1 t2)
+      (cond
+        [(eq? t1 'fp) (eq? t2 'fp)]
+        [else (not (eq? t2 'fp))]))
+
+    (module (frame-vars get-fv get-ptr-fv get-ret-fv compatible-fv?)
       (define-threaded frame-vars)
       (define get-fv
-        (lambda (x)
+        (case-lambda
+         [(x) (get-fv x 'uptr)]
+         [(x type)
           (let ([n (vector-length frame-vars)])
             (when (fx>= x n)
               (let ([new-vec (make-vector (fxmax (fx+ x 1) (fx* n 2)) #f)])
@@ -639,9 +671,39 @@
                       (loop n))))
                 (set! frame-vars new-vec))))
           (or (vector-ref frame-vars x)
-              (let ([fv ($make-fv x)])
+              (let ([fv ($make-fv x (let* ([type
+                                            ;; Don't allocate misaligned 'fp
+                                            (constant-case stack-word-alignment
+                                              [(2) (if (and (eq? type 'fp)
+                                                            (fxodd? x))
+                                                       'ptr
+                                                       type)]
+                                              [(1) type])]
+                                           [type
+                                            ;; Don't allocate 'fp that overlaps
+                                            ;; an allocated slot
+                                            (constant-case ptr-bits
+                                              [(32) (let ([next-fv (and (fx< (fx+ x 1) (vector-length frame-vars))
+                                                                        (vector-ref frame-vars (add1 x)))])
+                                                      (if (and next-fv
+                                                               (not (eq? (fv-type next-fv) 'reserved)))
+                                                          'ptr
+                                                          type))]
+                                              [(64) type])])
+                                      type))])
                 (vector-set! frame-vars x fv)
-                fv)))))
+                fv))]))
+      (define get-ptr-fv
+        (lambda (x)
+          (let ([fv (get-fv x)])
+            (safe-assert (not (memq (fv-type fv) '(fp reserved))))
+            fv)))
+      (define get-ret-fv
+        (lambda ()
+          (get-ptr-fv 0)))
+      (define (compatible-fv? fv type)
+        (and (not (eq? (fv-type fv) 'reserved))
+             (compatible-var-types? (fv-type fv) type))))
 
     (define-syntax reg-cons*
       (lambda (x)
@@ -649,9 +711,10 @@
           [(_ ?reg ... ?reg*)
            (fold-right
              (lambda (reg reg*)
-               (if (real-register? (syntax->datum reg))
-                   #`(cons #,reg #,reg*)
-                   reg*))
+               (cond
+                 [(real-register? (syntax->datum reg))
+                  #`(cons #,reg #,reg*)]
+                 [else reg*]))
              #'?reg* #'(?reg ...))])))
 
     (define-syntax reg-list
@@ -702,10 +765,10 @@
                  #`(cons* (ref-reg in) ...
                      #,(if (memq 'scheme-args in*)
                            (if (memq 'extra-regs in*)
-                               #'(append arg-registers extra-registers)
+                               #'(append arg-registers extra-registers extra-fpregisters)
                                #'arg-registers)
                            (if (memq 'extra-regs in*)
-                               #'extra-registers
+                               #'(append extra-registers extra-fpregisters)
                                #''())))))])))
       (define-syntax get-tcslot
         (lambda (x)
@@ -713,11 +776,11 @@
             [(_ k reg)
              (with-implicit (k in-context %mref)
                #'(in-context Lvalue
-                   (%mref ,%tc ,(reg-tc-disp reg))))])))
+                   (%mref ,%tc ,%zero ,(reg-tc-disp reg) ,(reg-type reg))))])))
       (define-syntax $save-scheme-state
         (lambda (x)
           (syntax-case x ()
-            [(_ k orig-x in out)
+            [(_ k orig-x save? in out)
              (with-implicit (k quasiquote)
                ; although eap might be changed by dirty writes, and esp might be changed by
                ; one-shot continuation handling, we always write through to the tc so that
@@ -727,34 +790,52 @@
                ; out of the save list (but not the restore list below).
                #'(let ([regs-to-save (build-reg-list orig-x (base-in %sfp %ap %trap) in out)])
                    (fold-left (lambda (body reg)
-                                `(seq (set! ,(get-tcslot k reg) ,reg) ,body))
+                                (if (save? reg)
+                                    `(seq (set! ,(get-tcslot k reg) ,reg) ,body)
+                                    body))
                      `(nop) regs-to-save)))])))
       (define-syntax $restore-scheme-state
         (lambda (x)
           (syntax-case x ()
-            [(_ k orig-x in out)
+            [(_ k orig-x save? in out)
              (with-implicit (k quasiquote)
                #'(let ([regs-to-restore (build-reg-list orig-x (base-in %sfp %ap %trap %eap %esp) in out)])
                    (fold-left (lambda (body reg)
-                                `(seq (set! ,reg ,(get-tcslot k reg)) ,body))
+                                (if (save? reg)
+                                    `(seq (set! ,reg ,(get-tcslot k reg)) ,body)
+                                    body))
                      `(nop) regs-to-restore)))])))
       (define-syntax save-scheme-state
         (lambda (x)
           (syntax-case x ()
-            [(k in out) #`($save-scheme-state k #,x in out)])))
+            [(k in out) #`($save-scheme-state k #,x (lambda (x) #t) in out)])))
       (define-syntax restore-scheme-state
         (lambda (x)
           (syntax-case x ()
-            [(k in out) #`($restore-scheme-state k #,x in out)])))
+            [(k in out) #`($restore-scheme-state k #,x (lambda (x) #t) in out)])))
       (define-syntax with-saved-scheme-state
         (lambda (x)
           (syntax-case x ()
-            [(k in out ?body)
+            [(k in out ?body) #`(k (lambda (x) #t) in out ?body)]
+            [(k save? in out ?body)
              (with-implicit (k quasiquote %seq)
                #`(%seq
-                   ,($save-scheme-state k #,x in out)
+                   ,($save-scheme-state k #,x save? in out)
                    ,?body
-                   ,($restore-scheme-state k #,x in out)))]))))
+                   ,($restore-scheme-state k #,x save? in out)))]))))
+
+    (define add-caller-save-registers
+      ;; Adds alloctable caller-saved registers, since those may be
+      ;; mangled on a call to a C function
+      (lambda (reg*)
+        (let loop ([i 0])
+          (cond
+            [(fx= i (vector-length regvec)) reg*]
+            [else (let ([reg (vector-ref regvec i)])
+                    (if (or (reg-callee-save? reg)
+                            (memq reg reg*))
+                        (loop (fx+ i 1))
+                        (cons reg (loop (fx+ i 1)))))]))))
 
     (define-record-type ctci ; compile-time version of code-info
       (nongenerative)
@@ -914,8 +995,8 @@
       (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) () (%td))
-      (declare-intrinsic maybe-reify-cc maybe-reify-cc (%xp %ac0 %ts) () (%td))
+      (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
@@ -953,11 +1034,11 @@
     (define-record-type info-foreign (nongenerative)
       (parent info)
       (sealed #t)
-      (fields conv* arg-type* result-type (mutable name))
+      (fields conv* arg-type* result-type unboxed? (mutable name))
       (protocol
         (lambda (pargs->new)
-          (lambda (conv* arg-type* result-type)
-            ((pargs->new) conv* arg-type* result-type #f)))))
+          (lambda (conv* arg-type* result-type unboxed?)
+            ((pargs->new) conv* arg-type* result-type unboxed? #f)))))
 
     (define-record-type info-literal (nongenerative)
       (parent info)
@@ -974,11 +1055,6 @@
       (sealed #t)
       (fields type swapped?))
 
-    (define-record-type info-loadfl (nongenerative)
-      (parent info)
-      (sealed #t)
-      (fields flreg))
-
     (define-record-type info-condition-code (nongenerative)
       (parent info)
       (sealed #t)
@@ -1004,6 +1080,10 @@
       (sealed #t)
       (fields))
 
+    (define-record-type info-unboxed-args (nongenerative)
+      (parent info)
+      (fields unboxed?*))
+
     (module ()
       (record-writer (record-type-descriptor info-load)
         (lambda (x p wr)
@@ -1022,6 +1102,12 @@
           (fprintf p "#<literal ~s>" (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
@@ -1065,11 +1151,11 @@
          `(call ,(make-info-call (preinfo-src preinfo) (preinfo-sexpr preinfo) (preinfo-call-check? preinfo) #f #f)
             ,(Expr e) ,e* ...)]
         [(foreign (,conv* ...) ,name ,[e] (,arg-type* ...) ,result-type)
-         (let ([info (make-info-foreign conv* arg-type* result-type)])
+         (let ([info (make-info-foreign conv* arg-type* result-type #f)])
            (info-foreign-name-set! info name)
            `(foreign ,info ,e))]
         [(fcallable (,conv* ...) ,[e] (,arg-type* ...) ,result-type)
-         `(fcallable ,(make-info-foreign conv* arg-type* result-type) ,e)])
+         `(fcallable ,(make-info-foreign conv* arg-type* result-type #f) ,e)])
       (CaseLambdaExpr ir #f))
 
     (define find-matching-clause
@@ -1127,12 +1213,15 @@
     (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))]
+             #'`(mref e0 e1 imm uptr))]
           [(k e0 imm)
            (with-implicit (k quasiquote)
-             #'`(mref e0 ,%zero imm))])))
+             #'`(mref e0 ,%zero imm uptr))])))
 
     (define-syntax %inline
       (lambda (x)
@@ -2690,8 +2779,8 @@
                     [(immediate ,imm) (values body 0 0)]
                     [(quote ,d) (values body 0 0)]
                     [(goto ,l) (values body 1 1)]
-                    [(mref ,[loop : e1 -> e1-promise e1-size e1-new-size] ,[loop : e2 -> e2-promise e2-size e2-new-size] ,imm)
-                     (values (delay `(mref ,(force e1-promise) ,(force e2-promise) ,imm))
+                    [(mref ,[loop : e1 -> e1-promise e1-size e1-new-size] ,[loop : e2 -> e2-promise e2-size e2-new-size] ,imm ,type)
+                     (values (delay `(mref ,(force e1-promise) ,(force e2-promise) ,imm ,type))
                        (fx+ e1-size e2-size 1)
                        (fx+ e1-new-size e2-new-size 1))]
                     [,lvalue (values body 1 1)]
@@ -2813,7 +2902,7 @@
                  body)])))
         (Lvalue : Lvalue (ir rename-ht) -> Lvalue ()
           [,x (eq-hashtable-ref rename-ht x x)]
-          [(mref ,[e1] ,[e2] ,imm) `(mref ,e1 ,e2 ,imm)])
+          [(mref ,[e1] ,[e2] ,imm ,type) `(mref ,e1 ,e2 ,imm ,type)])
         (Expr : Expr (ir rename-ht) -> Expr ()
           [(loop ,x (,[Lvalue : x* rename-ht -> x*] ...) ,body)
            ;; NB: with-fresh is so well designed that it can't handle this case
@@ -2850,6 +2939,177 @@
                      ir)))]))
       (set! $loop-unroll-limit loop-unroll-limit))
 
+    (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-pass np-unbox-fp-vars! : L7 (ir) -> L7 ()
+      (definitions
+        (define unify-boxed!
+          ;; union find, where representative box has a list of all variables
+          ;; that refer to the box
+          (lambda (x1 x2)
+            (let ([b1 (or (uvar-location x1)
+                          (let ([b1 (box (list x1))])
+                            (uvar-location-set! x1 b1)
+                            b1))]
+                  [b2 (or (uvar-location x2)
+                          (let ([b2 (box (list x2))])
+                            (uvar-location-set! x2 b2)
+                            b2))])
+              (let ([last-b1 (last-box b1)]
+                    [last-b2 (last-box b2)])
+                (unless (eq? last-b1 last-b2)
+                  (set-box! last-b1 (append (unbox last-b1) (unbox last-b2)))
+                  (set-box! last-b2 last-b1))
+                (compress! b1 last-b1)
+                (compress! b2 last-b1)))))
+        (define last-box
+          (lambda (b)
+            (let ([p (unbox b)])
+              (if (box? p)
+                  (last-box p)
+                  b))))
+        (define compress!
+          (lambda (b last-b)
+            (unless (eq? b last-b)
+              (let ([p (unbox b)])
+                (set-box! b last-b)
+                (compress! p last-b)))))
+        (define ensure-not-unboxed!
+          (lambda (x)
+            (when (and (uvar? x) (eq? (uvar-type x) 'fp))
+              (uvar-type-set! x 'ptr)
+              ;; Propagate to all unified variables:
+              (let ([b (uvar-location x)])
+                (when b
+                  (let* ([b (last-box b)]
+                         [l (unbox b)])
+                    (set-box! b '())
+                    (for-each ensure-not-unboxed! l)))))))
+        (define primref-flonum-result?
+          (lambda (pr)
+            (eq? 'flonum ($sgetprop (primref-name pr) '*result-type* #f)))))
+      (Expr : Expr (ir [lhs #f]) -> * (#f) ; result is whether the expression produces a flonum
+        [(quote ,d) (flonum? d)]
+        [,pr #f]
+        [(if ,[e0 #f -> * fp?] ,e1 ,e2)
+         (let ([fp1? (Expr e1 lhs)]
+               [fp2? (Expr e2 lhs)])
+           (and fp1? fp2?))]
+        [(seq ,[e0 #f -> * fp?] ,e1)
+         (Expr e1 lhs)]
+        [,lvalue (Lvalue lvalue lhs)]
+        [(let ([,x* ,e*] ...) ,body)
+         (for-each (lambda (x e)
+                     ;; Optimistically assume 'fp, so it will unify ok with
+                     ;; another variable that might be 'fp
+                     (uvar-type-set! x 'fp)
+                     (unless (Expr e x)
+                       (ensure-not-unboxed! x)))
+                   x* e*)
+         (let ([fp? (Expr body lhs)])
+           (for-each (lambda (x) (uvar-location-set! x #f)) x*)
+           fp?)]
+        [(call ,info ,mdcl ,pr ,e* ...)
+         (guard (and (all-set? (prim-mask unboxed-arguments) (primref-flags pr))
+                     (let ([n (length e*)]
+                           [i* (primref-arity pr)])
+                       (and (ormap (lambda (i) (if (fx< i 0) (fx>= n (fx- -1 i)) (fx= n i))) i*)
+                            (fx<= n (constant inline-args-limit))))))
+         (for-each (lambda (e) (Expr e #t)) e*)
+         (primref-flonum-result? pr)]
+        [(call ,info ,mdcl ,pr ,e1 ,[e2 #f -> * fp?2] ,[e3 #f -> * fp?3] ,e4)
+         (guard (and (eq? '$object-set! (primref-name pr))
+                     (nanopass-case (L7 Expr) e1
+                       [(quote ,d) (eq? d 'double)])))
+         (Expr e4 #t)
+         #f]
+        [(call ,info ,mdcl ,pr ,e1 ,[e2 #f -> * fp?2] ,[e3 #f -> * fp?3])
+         (guard (and (eq? '$object-ref (primref-name pr))
+                     (nanopass-case (L7 Expr) e1
+                       [(quote ,d) (eq? d 'double)])))
+         #t]
+        [(call ,info ,mdcl ,pr ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2] ,e3)
+         (guard (eq? 'bytevector-ieee-double-native-set! (primref-name pr)))
+         (Expr e3 #t)
+         #f]
+        [(call ,info ,mdcl ,pr ,[e* #f -> * fp?] ...)
+         (primref-flonum-result? pr)]
+        [(loop ,x (,x* ...) ,body)
+         (safe-assert (uvar-loop? x))
+         (uvar-location-set! x x*)
+         (let ([fp? (Expr body lhs)])
+           (uvar-location-set! x #f)
+           fp?)]
+        [(call ,info ,mdcl ,x ,e* ...)
+         (guard (uvar-loop? x))
+         (let ([x* (uvar-location x)])
+           (for-each (lambda (x e)
+                       (unless (Expr e x)
+                         (ensure-not-unboxed! x)))
+                     x* e*))
+         ;; Assume fp result until proven otherwise:
+         #t]
+        [(call ,info ,mdcl ,[e #f -> * fp?] ,[e* #f -> * fp?*] ...)
+         #f]
+        [(mvcall ,info ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2]) #f]
+        [(mvlet ,[e #f -> * fp?] ((,x** ...) ,interface* ,[body* #f -> * body-fp?]) ...)
+         (andmap values body-fp?)]
+        [(set! ,x ,e)
+         (unless (Expr e x)
+           (ensure-not-unboxed! x))
+         #f]
+        [(set! ,[lvalue #f -> * fp?l] ,[e #f -> * fp?])
+         #f]
+        [(unboxed-fp ,[e #f -> * fp?])
+         #t]
+        [(alloc ,info ,[e #f -> * fp?]) #f]
+        [(goto ,l) #f]
+        [(label ,l ,body) (Expr body lhs)]
+        [(label-ref ,l ,offset) #f]
+        [(values ,info ,[e* #f -> * fp?] ...) #f]
+        [(inline ,info ,prim ,[e* #f -> * fp?] ...) #f]
+        [(immediate ,imm) #f]
+        [(literal ,info) #f]
+        [(attachment-set ,aop ,[e #f -> * fp?]) #f]
+        [(attachment-get ,reified ,[e #f -> * fp?]) #f]
+        [(attachment-consume ,reified ,[e #f -> * fp?]) #f]
+        [(continuation-get) #f]
+        [(continuation-set ,cop ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2]) #f]
+        [(foreign-call ,info ,[e #f -> * fp?] ,[e* #f -> * fp?*] ...) #f]
+        [(profile ,src) #f]
+        [(pariah) #f])
+      (Lvalue : Lvalue (ir [lhs #f]) -> * (#f)
+        [,x
+         (guard (uvar? x))
+         (cond
+           [(not lhs) (ensure-not-unboxed! x)]
+           [(eq? lhs #t) (void)]
+           [(not (eq? (uvar-type lhs) 'fp)) (ensure-not-unboxed! x)]
+           [(not (eq? (uvar-type x) 'fp)) (ensure-not-unboxed! lhs)]
+           [else (unify-boxed! x lhs)])
+         (eq? (uvar-type x) 'fp)]
+        [,x #f]
+        [(mref ,[e1 #f -> * fp?1] ,[e2 #f -> * fp?2] ,imm ,type) (eq? type 'fp)])
+      (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)))
@@ -2890,6 +3150,12 @@
                #'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?
@@ -2919,7 +3185,7 @@
                  [(immediate ,imm) #t]
                  [(literal ,info) #t]
                  [(label-ref ,l ,offset) #t]
-                 [(mref ,e1 ,e2 ,imm) #t]
+                 [(mref ,e1 ,e2 ,imm ,type) #t]
                  [(quote ,d) #t]
                  [,pr #t]
                  [(call ,info ,mdcl ,pr ,e* ...)
@@ -2936,6 +3202,7 @@
                        (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
@@ -2948,24 +3215,54 @@
                   `(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 ())
-        (Expr : Expr (ir) -> Expr ()
+        (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)
-           (cond
-             [(ptr->imm d) => (lambda (i) `(immediate ,i))]
-             [else `(literal ,(make-info-literal #f 'object d 0))])]
-          [,pr (Symref (primref-name pr))]
+           (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*] ...)
+             ,[e* #f -> e* unboxed-fp?*] ...)
            (guard (and (eq? (primref-name pr) '$top-level-value) (symbol? d)))
-           `(call ,info0 ,mdcl0 ,(Symref d) ,e* ...)]
+           (values `(call ,info0 ,mdcl0 ,(Symref d) ,e* ...) #f)]
           [(call ,info ,mdcl ,pr ,e* ...)
            (cond
              [(and
@@ -2975,17 +3272,19 @@
                    (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 ([e (Expr e)])
-                     (cond
-                       [(info-call-shift-attachment? info)
-                        (let ([t (make-tmp 't)])
-                          `(let ([,t ,e])
-                             (seq
-                              (attachment-set pop #f)
-                              ,t)))]
-                       [else 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* (map Expr e*)])
+              (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)
@@ -2993,7 +3292,113 @@
                                                 (info-call-shift-attachment? info)
                                                 (info-call-shift-consumer-attachment?* info))
                                 info)])
-                  `(call ,info ,mdcl ,(Symref (primref-name pr)) ,e* ...)))])]))
+                  (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 (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)))
@@ -3056,9 +3461,9 @@
             (if (no-need-to-bind? multiple-ref? e)
                 (values e values)
                 (let ([t (make-tmp 't type)])
-                  (values t
-                    (lambda (body)
-                      `(let ([,t ,e]) ,body)))))))
+                  (values t (lift-fp-unboxed
+                             (lambda (body)
+                               `(let ([,t ,e]) ,body))))))))
         (define list-binder
           (lambda (multiple-ref? type e*)
             (if (null? e*)
@@ -3098,6 +3503,23 @@
              ($bind list-binder multiple-ref? type (b ...) e)]
             [(_ multiple-ref? (b ...) e)
              ($bind list-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 ()
@@ -3225,6 +3647,9 @@
                         (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?
@@ -3277,13 +3702,22 @@
               ,(%inline sll ,e
                  (immediate ,(fx- (constant char-data-offset) (constant fixnum-offset))))
               ,(%constant type-char))))
+	(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-feature pthreads
+	      (constant-case architecture
+	        [(arm32 arm64) `(seq ,(%inline store-store-fence) ,e)]
+                [else 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-seq)
+                                     (lambda (s r) (add-store-fence `(seq ,s ,r))))]
+            [(base index offset e build-assign build-barrier-seq)
              (if (nanopass-case (L7 Expr) e
                    [(quote ,d) (ptr->imm d)]
                    [else #f])
@@ -3299,13 +3733,13 @@
                        (bind #f ([e e])
                          ; eval a second so the address is not live across any calls
                          (bind #t ([a a])
-                           (build-seq
+                           (build-barrier-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])
-                           (build-seq
+			   (build-barrier-seq
                              (build-assign a %zero 0 e)
                              `(if ,(%type-check mask-fixnum type-fixnum ,e)
                                   ,(%constant svoid)
@@ -3318,9 +3752,10 @@
                 (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))))
+	    (add-store-fence
+             `(if ,cas
+                  (seq ,remember ,(%constant strue))
+                  ,(%constant sfalse)))))
         (define build-$record
           (lambda (tag args)
             (bind #f (tag)
@@ -3337,7 +3772,7 @@
                                  ,(f (cdr args) (fx+ offset (constant ptr-bytes)))))))))))))
         (define build-$real->flonum
           (lambda (src sexpr x who)
-            (if (constant? flonum? x)
+            (if (known-flonum-result? x)
                 x
                 (bind #t (x)
                   (bind #f (who)
@@ -3703,13 +4138,7 @@
                                   (immediate ,offset)))
                               ,t)))])
                     (bind #f (base index)
-                      (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
-                        (%seq
-                          (inline ,(make-info-loadfl %flreg1) ,%load-double
-                            ,base ,index (immediate ,offset))
-                          (inline ,(make-info-loadfl %flreg1) ,%store-double
-                            ,t ,%zero ,(%constant flonum-data-disp))
-                          ,t))))]
+                      (%mref ,base ,index ,offset fp)))]
                [(single-float)
                 (if swapped?
                     (bind #f (base index)
@@ -3718,18 +4147,22 @@
                           (set! ,(%mref ,t ,(constant flonum-data-disp))
                             (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index
                               (immediate ,offset)))
-                          (inline ,(make-info-loadfl %flreg1) ,%load-single->double
-                            ,t ,%zero ,(%constant flonum-data-disp))
-                          (inline ,(make-info-loadfl %flreg1) ,%store-double
-                            ,t ,%zero ,(%constant flonum-data-disp))
+                          (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
-                          (inline ,(make-info-loadfl %flreg1) ,%load-single->double
-                            ,base ,index (immediate ,offset))
-                          (inline ,(make-info-loadfl %flreg1) ,%store-double
-                            ,t ,%zero ,(%constant flonum-data-disp))
+                          (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
@@ -3807,18 +4240,14 @@
                [(scheme-object) (build-dirty-store base index offset value)]
                [(double-float)
                 (bind #f (base index)
-                  (%seq
-                    (inline ,(make-info-loadfl %flreg1) ,%load-double
-                      ,value ,%zero ,(%constant flonum-data-disp))
-                    (inline ,(make-info-loadfl %flreg1) ,%store-double
-                      ,base ,index (immediate ,offset))))]
+                  `(set! ,(%mref ,base ,index ,offset fp) ,value))]
                [(single-float)
                 (bind #f (base index)
-                  (%seq
-                    (inline ,(make-info-loadfl %flreg1) ,%load-double->single
-                      ,value ,%zero ,(%constant flonum-data-disp))
-                    (inline ,(make-info-loadfl %flreg1) ,%store-single
-                      ,base ,index (immediate ,offset))))]
+                  `(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)
@@ -3984,7 +4413,7 @@
                        ,(%inline logor
                                  ,(%mref ,e-v ,(constant type-disp))
                                  (immediate ,(constant immutable-flag))))))]))
-        (define inline-args-limit 10)
+        (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))
@@ -4020,6 +4449,23 @@
                        (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)
@@ -4123,7 +4569,7 @@
           [(e1 e2)
            (or (relop-length RELOP= e1 e2)
                (%inline eq? ,e1 ,e2))])
-        (define-inline 2 $keep-live
+        (define-inline 2 keep-live
           [(e) (%seq ,(%inline keep-live ,e) ,(%constant svoid))])
         (let ()
           (define (zgo src sexpr e e1 e2 r6rs?)
@@ -5453,7 +5899,7 @@
           (inline-accessor $thread-tc thread-tc-disp)
           )
         (let ()
-          (define (build-maybe-seginfo e)
+          (define (build-seginfo maybe? e)
             (let ([ptr (make-assigned-tmp 'ptr)]
                   [seginfo (make-assigned-tmp 'seginfo)])
               (define (build-level-3 seginfo k)
@@ -5465,9 +5911,11 @@
                                                                                          (constant segment-t2-bits))))
                                                    (immediate ,(constant log2-ptr-bytes)))
                                          ,0)])
-                        (if ,(%inline eq? ,s3 (immediate 0))
-                            (immediate 0)
-                            ,(k s3))))]
+                        ,(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
@@ -5479,9 +5927,11 @@
                                                        (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1)
                                                                           (constant log2-ptr-bytes))))
                                          0)])
-                        (if ,(%inline eq? ,s2 (immediate 0))
-                            (immediate 0)
-                            ,(k s2))))]
+                        ,(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)))])
@@ -5499,14 +5949,13 @@
                  ,(%constant sfalse)
                  (if ,(%type-check mask-immediate type-immediate ,e)
                      ,(%constant sfalse)
-                     ,(let ([s-e (build-maybe-seginfo e)]
+                     ,(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)
-                                           ,(%inline logand ,s (immediate ,(fxnot (constant space-locked))))))))))))
+                                  (%inline eq? (immediate ,space) ,s))))))))
 
           (define-inline 2 $maybe-seginfo
             [(e)
@@ -5515,29 +5964,45 @@
                     ,(%constant sfalse)
                     (if ,(%type-check mask-immediate type-immediate ,e)
                         ,(%constant sfalse)
-                        ,(let ([s-e (build-maybe-seginfo e)]
+                        ,(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))))))])
-          ;; Generation is first unsigned char in `seginfo` as defined in "types.h"
+          (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 1))])
-          ;; Space is second unsigned char in `seginfo` as defined in "types.h"
+             (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))])
           (define-inline 2 $seginfo-space
             [(e)
              (bind #f (e)
-                   (%inline logand ,(build-object-ref #f 'unsigned-8 e %zero 0)
-                            (immediate ,(fxnot (fix (constant space-locked))))))])
-
+                   (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-maybe-seginfo e)]
+                    ,(let ([s-e (build-seginfo #t e)]
                            [si (make-assigned-tmp 'si)])
                        `(let ([,si ,s-e])
                           (if ,(%inline eq? ,si (immediate 0))
@@ -5658,6 +6123,18 @@
         (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 ()
@@ -6313,7 +6790,7 @@
                                     (if ($nan? d)
                                         ;; NaN: invert `fl=` on self
                                         (bind #t (e2)
-                                          (build-not (%inline fl= ,e2 ,e2)))
+                                          (build-not (build-fl= e2 e2)))
                                         ;; Non-NaN: compare bits
                                         (constant-case ptr-bits
                                           [(32)
@@ -7059,7 +7536,7 @@
                           ,(build-libcall #t src sexpr logtest e1 e2)))])
         (define-inline 3 $flhash
           [(e) (bind #t (e)
-                 `(if ,(%inline fl= ,e ,e)
+                 `(if ,(build-fl= e e)
                      ,(%inline logand
                        ,(%inline srl
                          ,(constant-case ptr-bits
@@ -7101,7 +7578,7 @@
         (define-inline 3 $fleqv?
           [(e1 e2)
            (bind #t (e1 e2)
-             `(if ,(%inline fl= ,e1 ,e1) ; check e1 not +nan.0
+             `(if ,(build-fl= e1 e1) ; check e1 not +nan.0
                   ,(constant-case ptr-bits
                     [(32) (build-and
                             (%inline eq?
@@ -7117,137 +7594,117 @@
                                  "$fleqv doesn't handle ptr-bits = ~s"
                                  (constant ptr-bits))])
                   ;; If e1 is +nan.0, see if e2 is +nan.0:
-                  ,(build-not (%inline fl= ,e2 ,e2))))])
+                  ,(build-not (build-fl= e2 e2))))])
 
         (let ()
-          (define build-flop-1
-            ; NB: e must be bound
+          (define build-fp-op-1
             (lambda (op e)
-              (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
-                `(seq (inline ,null-info ,op ,e ,t) ,t))))
-          (define build-flop-2
-            ; NB: e1 and e2 must be bound
+              (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 #t ([t (%constant-alloc type-flonum (constant size-flonum))])
-                `(seq (inline ,null-info ,op ,e1 ,e2 ,t) ,t))))
+              (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)
-              (bind (constant-case ptr-bits [(32) #t] [(64) #f]) (e)
-                (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
-                  (%seq
-                    ,(constant-case ptr-bits
-                       [(64)
-                        `(set! ,(%mref ,t ,(constant flonum-data-disp))
-                           ,(%inline logand
-                              ,(%mref ,e ,(constant flonum-data-disp))
-                              ,(%inline srl (immediate -1) (immediate 1))))]
-                       [(32)
-                        (let ()
-                          (constant-case native-endianness
-                            [(big)
-                             (begin
-                               (define disp-high (constant flonum-data-disp))
-                               (define disp-low (fx+ (constant flonum-data-disp) 4)))]
-                            [(little)
-                             (begin
-                               (define disp-low (constant flonum-data-disp))
-                               (define disp-high (fx+ (constant flonum-data-disp) 4)))])
-                          (%seq
-                            (set! ,(%mref ,t ,disp-high)
-                              ,(%inline logand
-                                 ,(%mref ,e ,disp-high)
-                                 ,(%inline srl (immediate -1) (immediate 1))))
-                            (set! ,(%mref ,t ,disp-low)
-                              ,(%mref ,e ,disp-low))))])
-                    ,t)))))
+              (build-fl-adjust-sign e %logand (%inline srl (immediate -1) (immediate 1)))))
           (define build-flneg
             (lambda (e)
-              (bind (constant-case ptr-bits [(32) #t] [(64) #f]) (e)
-                (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
-                  (%seq
-                    ,(constant-case ptr-bits
-                       [(64)
-                        `(set! ,(%mref ,t ,(constant flonum-data-disp))
-                           ,(%inline logxor
-                              ,(%mref ,e ,(constant flonum-data-disp))
-                              ,(%inline sll (immediate 1) (immediate 63))))]
-                       [(32)
-                        (let ()
-                          (constant-case native-endianness
-                            [(big)
-                             (begin
-                               (define disp-high (constant flonum-data-disp))
-                               (define disp-low (fx+ (constant flonum-data-disp) 4)))]
-                            [(little)
-                             (begin
-                               (define disp-low (constant flonum-data-disp))
-                               (define disp-high (fx+ (constant flonum-data-disp) 4)))])
-                          (%seq
-                            (set! ,(%mref ,t ,disp-high)
-                              ,(%inline logxor
-                                 ,(%mref ,e ,disp-high)
-                                 ,(%inline sll (immediate 1) (immediate 31))))
-                            (set! ,(%mref ,t ,disp-low)
-                              ,(%mref ,e ,disp-low))))])
-                    ,t)))))
-
-          ;; TODO: Rather then reducing here, (which will allocate a new flonum for each interim result)
-          ;; we could allocate a single flonum and reuse it until the final result is calculated.
-          ;; Better yet, we could do this across nested fl operations, so that only one flonum is
-          ;; allocated across nested fl+, fl*, fl-, fl/ etc. operation
+              (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) (bind #f (e1 e2) (build-flop-2 %fl+ e1 e2))]
-            [(e1 . e*) (reduce src sexpr moi e1 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) (bind #f (e1 e2) (build-flop-2 %fl* e1 e2))]
-            [(e1 . e*) (reduce src sexpr moi e1 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) (bind #f (e1 e2) (build-flop-2 %fl- e1 e2))]
-            [(e1 . e*) (reduce src sexpr moi e1 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) (bind #f (e) (build-flop-2 %fl/ `(quote 1.0) e))]
-            [(e1 e2) (bind #f (e1 e2) (build-flop-2 %fl/ e1 e2))]
-            [(e1 . e*) (reduce src sexpr moi e1 e*)])
+            [(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) (bind #f (e) (build-flop-1 %flsqrt e))]
-               [(ppc32) #f])])
-
-          (define-inline 3 flround
-            ; NB: there is no support in SSE2 for flround, though this was added in SSE4.1
-            [(e) (build-libcall #f src sexpr flround e)])
+               [(x86 x86_64 arm32 arm64) (build-fp-op-1 %fpsqrt e)]
+               [(ppc32) (build-fl-call (lookup-c-entry flsqrt) 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
+                    (%seq
                        (set! ,(%mref ,t ,(constant inexactnum-type-disp))
                          ,(%constant type-inexactnum))
-                       ,(%seq
-                          (inline ,(make-info-loadfl %flreg1) ,%load-double
-                            ,e1 ,%zero ,(%constant flonum-data-disp))
-                          (inline ,(make-info-loadfl %flreg1) ,%store-double
-                            ,t ,%zero ,(%constant inexactnum-real-disp))
-                          (inline ,(make-info-loadfl %flreg1) ,%load-double
-                            ,e2 ,%zero ,(%constant flonum-data-disp))
-                          (inline ,(make-info-loadfl %flreg1) ,%store-double
-                            ,t ,%zero ,(%constant inexactnum-imag-disp))
-                          ,t))))))
+                       (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)])
@@ -7306,9 +7763,15 @@
                            ,t)))])
 
           (let ()
-            (define (build-fl< e1 e2) (%inline fl< ,e1 ,e2))
-            (define (build-fl= e1 e2) (%inline fl= ,e1 ,e2))
-            (define (build-fl<= e1 e2) (%inline fl<= ,e1 ,e2))
+            (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
@@ -7317,11 +7780,11 @@
                     [(_ op r6rs:op builder inequality? swapped?)
                      (with-syntax ([(args ...) (if (datum swapped?) #'(e2 e1) #'(e1 e2))]
                                    [reducer (if (datum inequality?)
-                                                #'reduce-inequality
-                                                #'reduce-equality)])
+                                                #'(reduce-fp-compare reduce-inequality)
+                                                #'(reduce-fp-compare reduce-equality))])
                        #'(begin
                            (define-inline 3 op
-                             [(e) (bind #t (e) (build-fl= e e))]
+                             [(e) (build-fl= e)]
                              [(e1 e2) (builder args ...)]
                              [(e1 e2 . e*) (reducer src sexpr moi e1 e2 e*)])
                            (define-inline 3 r6rs:op
@@ -7337,25 +7800,80 @@
               (define-syntax build-bind-and-check
                 (syntax-rules ()
                   [(_ src sexpr op e1 e2 body)
-                   (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)))]))
+                   (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))])
+                     (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
-                             [(e) #f]
+                             [(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*) #f])
+                             [(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*) #f])))])))
+                             [(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<? build-fl< #t #f)
@@ -7384,113 +7902,194 @@
                                 (build-$inexactnum-real-part e1)
                                 (build-$inexactnum-real-part e2)))))))
               (define-inline 3 cfl=
-                [(e) (bind #f (e) (build-cfl= e e))] ; this is weird, why not just true?
+                [(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-flop-3
-              ; NB: e1, e2, and e3 must be bound
-              (lambda (op e1 e2 e3)
-                (build-flop-2 op e1
-                  (build-flop-2 op e2 e3))))
-            (define build-checked-flop
+            (define build-checked-fp-op
               (case-lambda
                 [(e k)
-                 (bind #t (e)
-                   `(if ,(build-flonums? (list e))
-                        ,e
-                        ,(k e)))]
-                [(e1 e2 op k)
-                 (bind #t (e1 e2)
-                   `(if ,(build-flonums? (list e1 e2))
-                        ,(build-flop-2 op e1 e2)
-                        ,(k e1 e2)))]
-                [(e1 e2 e3 op k)
-                 (bind #f (e1 e2 e3)
-                   `(if ,(build-flonums? (list e1 e2 e3))
-                        ,(build-flop-3 op e1 e2 e3)
-                        ,(k e1 e2 e3)))]))
+                 (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-flop e
+              [(e) (build-checked-fp-op e
                      (lambda (e)
                        (build-libcall #t src sexpr fl+ e `(quote 0.0))))]
-              [(e1 e2) (build-checked-flop e1 e2 %fl+
+              [(e1 e2) (build-checked-fp-op e1 e2 %fp+
                          (lambda (e1 e2)
                            (build-libcall #t src sexpr fl+ e1 e2)))]
-              ; TODO: add 3 argument fl+ library function
-              #;[(e1 e2 e3) (build-checked flop e1 e2 e3 %fl+
-                            (lambda (e1 e2 e3)
-                              (build-libcall #t src sexpr fl+ e1 e2 e3)))]
-              [(e1 . e*) #f])
+              [(e1 . e*) (reduce-fp src sexpr 2 'fl+ e1 e*)])
 
             (define-inline 2 fl*
               [() `(quote 1.0)]
-              [(e) (build-checked-flop e
+              [(e) (build-checked-fp-op e
                      (lambda (e)
                        (build-libcall #t src sexpr fl* e `(quote 1.0))))]
-              [(e1 e2) (build-checked-flop e1 e2 %fl*
+              [(e1 e2) (build-checked-fp-op e1 e2 %fp*
                          (lambda (e1 e2)
                            (build-libcall #t src sexpr fl* e1 e2)))]
-              ; TODO: add 3 argument fl* library function
-              #;[(e1 e2 e3) (build-checked flop e1 e2 e3 %fl*
-                            (lambda (e1 e2 e3)
-                              (build-libcall #t src sexpr fl* e1 e2 e3)))]
-              [(e1 . e*) #f])
+              [(e1 . e*) (reduce-fp src sexpr 2 'fl* e1 e*)])
 
             (define-inline 2 fl-
-              [(e)
-               (bind #t (e)
-                 `(if ,(build-flonums? (list e))
-                      ,(build-flneg e)
-                      ,(build-libcall #t src sexpr flnegate e)))]
-              [(e1 e2) (build-checked-flop e1 e2 %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)))]
-              ; TODO: add 3 argument fl- library function
-              #;[(e1 e2 e3) (build-checked flop e1 e2 e3 %fl-
-                            (lambda (e1 e2 e3)
-                              (build-libcall #t src sexpr fl- e1 e2 e3)))]
-              [(e1 . e*) #f])
+              [(e1 . e*) (reduce-fp src sexpr 2 'fl- e1 e*)])
 
             (define-inline 2 fl/
-              [(e) (build-checked-flop `(quote 1.0) e %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-flop e1 e2 %fl/
+              [(e1 e2) (build-checked-fp-op e1 e2 %fp/
                          (lambda (e1 e2)
                            (build-libcall #t src sexpr fl/ e1 e2)))]
-              ; TODO: add 3 argument fl/ library function
-              #;[(e1 e2 e3) (build-checked flop e1 e2 e3 %fl/
-                            (lambda (e1 e2 e3)
-                              (build-libcall #t src sexpr fl/ e1 e2 e3)))]
-              [(e1 . e*) #f])))
-
-        ; 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 (e-x)
-                   (build-fix
-                     (%inline trunc ,e-x)))])
+              [(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) (build-fp-op-1 %fpsqrt e)]
+                   [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)]))
+               (lambda (e)
+                 (build-libcall #t src sexpr flsqrt 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)
-              (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))])
-                (%seq
-                  ,(%inline flt ,(build-unfix e-x) ,t)
-                  ,t))))
+            (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))])
+            [(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 (constant? 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)
+                        ,(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))))))]))
@@ -8022,7 +8621,7 @@
                               (label ,L2
                                 (seq
                                   ,(%inline pause)
-                                  (if ,(%inline eq? (mref ,e-base ,e-index ,imm-offset) (immediate 0))
+                                  (if ,(%inline eq? (mref ,e-base ,e-index ,imm-offset uptr) (immediate 0))
                                       (goto ,L1)
                                       (goto ,L2)))))))))))]))
         (let ()
@@ -8960,7 +9559,16 @@
             (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))
+            (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
@@ -9001,7 +9609,17 @@
                               (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))
+            (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
@@ -9569,38 +10187,71 @@
            (translate (%mref ,e ,(constant continuation-stack-clength-disp))
              (constant fixnum-offset)
              (constant log2-ptr-bytes))])
-        (define-inline 3 $continuation-return-code
-          [(e)
-           (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))])
-             (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-inline 3 $continuation-return-offset
-          [(e)
-           (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))])
-             (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-inline 3 $continuation-return-livemask
-          [(e)
-           (bind #t ([ra (%mref ,e ,(constant continuation-return-address-disp))])
-             (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-inline 3 $continuation-stack-ref
-          [(e-k e-i)
-           (%mref
+        (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)
@@ -10009,6 +10660,7 @@
                    (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax)
                    64))]
              [(arm32) (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))
@@ -10028,7 +10680,8 @@
                 ,(unsigned->ptr
                    (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax)
                    64))]
-             [(arm32 ppc32) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)])])
+             [(arm32 ppc32) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)]
+             [(arm64) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 64)])])
 
     )) ; expand-primitives module
 
@@ -10058,7 +10711,7 @@
                 (and (or (goto-oc? goto) (not (local-label-overflow-check (goto-label goto))))
                      (or (goto-tc? goto) (not (local-label-trap-check (goto-label goto))))))))
           (Lvalue : Lvalue (ir oc? tc?) -> Lvalue ()
-            [(mref ,[e0] ,[e1] ,imm) `(mref ,e0 ,e1 ,imm)])
+            [(mref ,[e0] ,[e1] ,imm ,type) `(mref ,e0 ,e1 ,imm ,type)])
           (Expr : Expr (ir oc? tc?) -> Expr ()
             [(overflow-check ,[e #t tc? -> e]) (if oc? e `(overflow-check ,e))]
             [(trap-check ,ioc ,[e oc? #t -> e]) (if tc? e `(trap-check ,(if oc? #f ioc) ,e))]
@@ -10098,8 +10751,8 @@
                   `(trap-check ,overflow? ,e)
                   e)))))
       (Lvalue : Lvalue (ir) -> Lvalue ('no 'no)
-        [(mref ,[e0 #f -> e0 oc0 tc0] ,[e1 #f -> e1 oc1 tc1] ,imm)
-         (values `(mref ,e0 ,e1 ,imm) (combine-seq oc0 oc1) (combine-seq tc0 tc1))])
+        [(mref ,[e0 #f -> e0 oc0 tc0] ,[e1 #f -> e1 oc1 tc1] ,imm ,type)
+         (values `(mref ,e0 ,e1 ,imm ,type) (combine-seq oc0 oc1) (combine-seq tc0 tc1))])
       (Expr : Expr (ir tail?) -> Expr ('no 'no)
         [(goto ,l)
          (if (local-label? l)
@@ -10241,7 +10894,7 @@
             [,x (guard (uvar? x))
              (cond
                [(uvar-in-prefix? x)
-                (let ([t (make-tmp 't)])
+                (let ([t (make-tmp 't (uvar-type x))])
                   (uvar-location-set! x t)
                   (uvar-in-prefix! x #f)
                   (set! x* (cons x x*))
@@ -10357,16 +11010,16 @@
       (definitions
         (define local*)
         (define make-tmp
-          (lambda (x)
+          (lambda (x type)
             (import (only np-languages make-tmp))
-            (let ([x (make-tmp x)])
+            (let ([x (make-tmp x type)])
               (set! local* (cons x local*))
               x)))
         (define Ref
           (lambda (ir setup*)
             (if (var? ir)
                 (values ir setup*)
-                (let ([tmp (make-tmp 't)])
+                (let ([tmp (make-tmp 't 'uptr)])
                   (values tmp (cons (Rhs ir tmp) setup*))))))
         (define Lvalue?
           (lambda (x)
@@ -10374,32 +11027,38 @@
               [,lvalue #t]
               [else #f])))
         (define Triv*
-          (lambda (e* k)
-            (let f ([e* e*] [lvalue-setup* '()] [rt* '()] [setup* '()])
+          (case-lambda
+           [(e* k) (Triv* e* #f k)]
+           [(e* fp?* k)
+            (let f ([e* e*] [fp?* fp?*] [lvalue-setup* '()] [rt* '()] [setup* '()])
               (if (null? e*)
                   (build-seq* setup*
                     (build-seq* lvalue-setup*
                       (k (reverse rt*))))
-                  (let-values ([(t t-setup*) (Triv (car e*) (null? lvalue-setup*))])
+                  (let-values ([(t t-setup*) (Triv (car e*) (null? lvalue-setup*) (and fp?* (car fp?*)))])
                     (if (and (null? lvalue-setup*)
                              (not (null? t-setup*))
                              (Lvalue? t)
                              ; uvar's are singly assigned
                              (or (not (uvar? t)) (uvar-assigned? t)))
-                        (f (cdr e*) t-setup* (cons t rt*) setup*)
-                        (f (cdr e*) lvalue-setup* (cons t rt*) (append t-setup* setup*))))))))
+                        (f (cdr e*) (and fp?* (cdr fp?*)) t-setup* (cons t rt*) setup*)
+                        (f (cdr e*) (and fp?* (cdr fp?*)) lvalue-setup* (cons t rt*) (append t-setup* setup*))))))]))
         (define Triv?
           (lambda (maybe-e k)
             (if maybe-e
-                (let-values ([(t setup*) (Triv maybe-e #t)])
+                (let-values ([(t setup*) (Triv maybe-e #f #f)])
                   (build-seq* setup* (k t)))
                 (k #f))))
+        (define (fp-lvalue? lvalue)
+          (nanopass-case (L10 Lvalue) lvalue
+            [,x (and (uvar? x) (eq? (uvar-type x) 'fp))]
+            [(mref ,x1 ,x2 ,imm ,type) (eq? type 'fp)]))
         (define build-seq* (lambda (x* y) (fold-right build-seq y x*)))
         (with-output-language (L10 Expr)
           (define build-seq (lambda (x y) `(seq ,x ,y)))
           (define Rhs
             (lambda (ir lvalue)
-              (Expr ir
+              (Expr ir (fp-lvalue? lvalue)
                 (lambda (e)
                   (nanopass-case (L10 Expr) e
                     [,rhs `(set! ,lvalue ,rhs)]
@@ -10420,18 +11079,18 @@
       (CaseLambdaClause : CaseLambdaClause (ir) -> CaseLambdaClause ()
         [(clause (,x* ...) ,mcp ,interface ,body)
          (fluid-let ([local* '()])
-           (let ([body (Expr body values)])
+           (let ([body (Expr body #f values)])
              (safe-assert (nodups x* local*))
              `(clause (,x* ...) (,local* ...) ,mcp ,interface
                 ,body)))])
-      (Triv : Expr (ir lvalue-okay?) -> Triv (setup*)
+      (Triv : Expr (ir lvalue-okay? fp?) -> Triv (setup*)
         [,x
          (guard (or lvalue-okay? (and (uvar? x) (not (uvar-assigned? x))) (eq? x %zero)))
          (values x '())]
-        [(mref ,e1 ,e2 ,imm)
+        [(mref ,e1 ,e2 ,imm ,type)
          (guard lvalue-okay?)
          (let*-values ([(x1 setup*) (Ref e1 '())] [(x2 setup*) (Ref e2 setup*)])
-           (values (%mref ,x1 ,x2 ,imm) setup*))]
+           (values (%mref ,x1 ,x2 ,imm ,type) setup*))]
         [(literal ,info) (values `(literal ,info) '())]
         [(immediate ,imm) (values `(immediate ,imm) '())]
         [(label-ref ,l ,offset) (values `(label-ref ,l ,offset) '())]
@@ -10442,19 +11101,20 @@
            (fold-right
              (lambda (ir lvalue setup*) (cons (Rhs ir lvalue) setup*))
              setup* e* x*))]
-        [(seq ,[Expr : e0 values -> e0] ,[t setup*])
+        [(seq ,[Expr : e0 fp? values -> e0] ,[t setup*])
          (values t (cons e0 setup*))]
         [(pariah) (values (%constant svoid) (list (with-output-language (L10 Expr) `(pariah))))]
         [else
-         (let ([tmp (make-tmp 't)])
+         (let ([tmp (make-tmp 't (if fp? 'fp 'ptr))])
            (values tmp (list (Rhs ir tmp))))])
-      (Expr : Expr (ir k) -> Expr ()
+      (Expr : Expr (ir fp? k) -> Expr ()
         [(inline ,info ,prim ,e1* ...)
-         (Triv* e1*
+         (Triv* e1* (and (info-unboxed-args? info)
+                         (info-unboxed-args-unboxed?* info))
            (lambda (t1*)
              (k `(inline ,info ,prim ,t1* ...))))]
         [(alloc ,info ,e)
-         (let-values ([(t setup*) (Triv e #t)])
+         (let-values ([(t setup*) (Triv e #t #f)])
            (build-seq* setup* (k `(alloc ,info ,t))))]
         [(call ,info ,mdcl ,e0? ,e1* ...)
          (if e0?
@@ -10478,17 +11138,18 @@
            (lambda (t*)
              (k `(continuation-set ,cop ,(car t*) ,(cadr t*)))))]
         [(foreign-call ,info ,e0 ,e1* ...)
-         (Triv* (cons e0 e1*)
+         (Triv* (cons e0 e1*) (and (info-foreign-unboxed? info)
+                                   (cons #f (map fp-type? (info-foreign-arg-type* info))))
            (lambda (t*)
              (k `(foreign-call ,info ,(car t*) ,(cdr t*) ...))))]
         [(values ,info ,e* ...)
          (Triv* e*
            (lambda (t*)
              (k `(values ,info ,t* ...))))]
-        [(if ,[Expr : e0 values -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
-        [(seq ,[Expr : e0 values -> e0] ,[e1]) `(seq ,e0 ,e1)]
+        [(if ,[Expr : e0 #f values -> e0] ,[e1] ,[e2]) `(if ,e0 ,e1 ,e2)]
+        [(seq ,[Expr : e0 #f values -> e0] ,[e1]) `(seq ,e0 ,e1)]
         [(set! ,lvalue ,e)
-         (let-values ([(lvalue setup*) (Triv lvalue #t)])
+         (let-values ([(lvalue setup*) (Triv lvalue #t #f)])
            ; must put lvalue setup* first to avoid potentially interleaved argument
            ; evaluation in, e.g.:
            ;
@@ -10536,12 +11197,12 @@
          (set! local* (append x* local*))
          (safe-assert (nodups local*))
          (fold-left (lambda (t x e) (build-seq (Rhs e x) t)) body x* e*)]
-        [(mvlet ,[Expr : e values -> e] ((,x** ...) ,interface* ,[body*]) ...)
+        [(mvlet ,[Expr : e #f values -> e] ((,x** ...) ,interface* ,[body*]) ...)
          (set! local* (append (apply append x**) local*))
          (safe-assert (nodups local*))
          `(mvlet ,e ((,x** ...) ,interface* ,body*) ...)]
-        [(mvcall ,info ,[Expr : e1 values -> e1] ,e2)
-         (let-values ([(t2 setup*) (Triv e2 #t)])
+        [(mvcall ,info ,[Expr : e1 #f values -> e1] ,e2)
+         (let-values ([(t2 setup*) (Triv e2 #t #f)])
            (build-seq* setup* (k `(mvcall ,info ,e1 ,t2))))]
         [(goto ,l) `(goto ,l)]
         [(label ,l ,[body]) `(label ,l ,body)]
@@ -10550,24 +11211,34 @@
         [(pariah) `(pariah)]
         [(profile ,src) `(profile ,src)]
         [else
-         (let-values ([(t setup*) (Triv ir #t)])
+         (let-values ([(t setup*) (Triv ir #t fp?)])
            (build-seq* setup* (k t)))]))
 
     (define-pass np-push-mrvs : L10 (ir) -> L10.5 ()
       (definitions
         (define local*)
         (define make-tmp
-          (lambda (x)
+          (case-lambda
+           [(x) (make-tmp x 'ptr)]
+           [(x type)
             (import (only np-languages make-tmp))
-            (let ([x (make-tmp x)])
+            (let ([x (make-tmp x type)])
               (set! local* (cons x local*))
-              x)))
+              x)]))
         (define make-info-call-like
           (lambda (info shift-consumer-attachment?*)
             (make-info-call (info-call-src info) (info-call-sexpr info)
                             (info-call-check? info) (info-call-pariah? info) (info-call-error? info)
                             (info-call-shift-attachment? info)
                             shift-consumer-attachment?*)))
+        (define (rhs->type rhs)
+          (if (nanopass-case (L10.5 Rhs) rhs
+                [(foreign-call ,info ,t0 ,t1* ...)
+                 (and (info-foreign-unboxed? info)
+                      (fp-type? (info-foreign-result-type info)))]
+                [else #f])
+              'fp
+              'ptr))
         (define Mvcall
           (lambda (info e consumer k)
             (let ([info (make-info-call (info-call-src info) (info-call-sexpr info) #f #f #f
@@ -10594,7 +11265,7 @@
                   [(profile ,src) `(profile ,src)]
                   [(goto ,l) `(goto ,l)]
                   [,rhs ; alloc, inline, foreign-call
-                   (let ([tmp (make-tmp 't)])
+                   (let ([tmp (make-tmp 't (rhs->type rhs))])
                      `(seq
                         (set! ,tmp ,rhs)
                         ,(k `(mvcall ,(make-info-call-like info '()) #f ,consumer ,tmp ()))))]
@@ -10696,7 +11367,7 @@
                       [(mlabel ,[e] (,l* ,[e*]) ...) `(mlabel ,e (,l* ,e*) ...)]
                       [(goto ,l) `(goto ,l)]
                       [,rhs ; alloc, inline, foreign-call
-                        (let ([tmp (make-tmp 't)])
+                        (let ([tmp (make-tmp 't (rhs->type rhs))])
                           `(seq
                              (set! ,tmp ,rhs)
                              ,(Pvalues #f (list tmp))))]
@@ -10725,6 +11396,10 @@
             (let ([x (make-tmp x)])
               (set! local* (cons x local*))
               x)))
+        (define (fp-lvalue? lvalue)
+          (nanopass-case (L10.5 Lvalue) lvalue
+            [,x (and (uvar? x) (eq? (uvar-type x) 'fp))]
+            [(mref ,x1 ,x2 ,imm ,type) (eq? type 'fp)]))
         (define rhs-inline
           (lambda (lvalue info prim t*)
             (with-output-language (L11 Effect)
@@ -10761,7 +11436,7 @@
                     (set! ,t ?rhs)
                     ,(predicafy-triv ,t)))])))
         [,x (predicafy-triv ,x)]
-        [(mref ,x1 ,x2 ,imm) (predicafy-triv ,(%mref ,x1 ,x2 ,imm))]
+        [(mref ,x1 ,x2 ,imm ,type) (predicafy-triv ,(%mref ,x1 ,x2 ,imm ,type))]
         [(literal ,info)
          (if (info-literal-indirect? info)
              (predicafy-triv (literal ,info))
@@ -10776,7 +11451,10 @@
          (if (and (info-call-error? info) (fx< (debug-level) 2))
              `(seq (tail (mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...))) (true))
              (predicafy-rhs (mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...))))]
-        [(foreign-call ,info ,[t0] ,[t1] ...) (predicafy-rhs (foreign-call ,info ,t0 ,t1 ...))]
+        [(foreign-call ,info ,[t0] ,[t1] ...)
+         (safe-assert (not (and (info-foreign-unboxed? info)
+                                (fp-type? (info-foreign-result-type info)))))
+         (predicafy-rhs (foreign-call ,info ,t0 ,t1 ...))]
         [(label ,l ,[pbody]) `(seq (label ,l) ,pbody)]
         [(trap-check ,ioc ,[pbody]) `(seq (trap-check ,ioc) ,pbody)]
         [(overflow-check ,[pbody]) `(seq (overflow-check) ,pbody)]
@@ -10794,8 +11472,10 @@
          ($oops who "unrecognized prim ~s" prim)]
         [(set! ,[lvalue] (inline ,info ,prim ,[t*] ...))
          `(seq ,(rhs-inline lvalue info prim t*) (true))]
-        [(set! ,[lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
-         (guard (info-call-error? info) (fx< (debug-level) 2))
+        [(set! ,[lvalue -> lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
+         (guard (info-call-error? info) (or (fx< (debug-level) 2)
+                                            ;; must really escape if fp context
+                                            (fp-lvalue? lvalue)))
          (%seq
            (tail (mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...)))
            (true))]
@@ -10816,7 +11496,7 @@
             (true))])
       (Effect : Expr (ir) -> Effect ()
         [,x `(nop)]
-        [(mref ,x1 ,x2 ,imm) `(nop)]
+        [(mref ,x1 ,x2 ,imm ,type) `(nop)]
         [(literal ,info) `(nop)]
         [(immediate ,imm) `(nop)]
         [(label-ref ,l ,offset) `(nop)]
@@ -10831,8 +11511,10 @@
            [else `(inline ,info ,prim ,t* ...)])]
         [(set! ,[lvalue] (inline ,info ,prim ,[t*] ...))
          (rhs-inline lvalue info prim t*)]
-        [(set! ,[lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
-         (guard (info-call-error? info) (fx< (debug-level) 2))
+        [(set! ,[lvalue -> lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
+         (guard (info-call-error? info) (or (fx< (debug-level) 2)
+                                            ;; must really escape if fp context
+                                            (fp-lvalue? lvalue)))
          `(tail (mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...)))]
         [(set! ,[lvalue] (attachment-get ,reified? ,[t?]))
          `(set! ,lvalue (attachment-get ,reified? ,t?))]
@@ -10874,8 +11556,10 @@
          ($oops who "unrecognized prim ~s" prim)]
         [(set! ,[lvalue] (inline ,info ,prim ,[t*] ...))
          `(seq ,(rhs-inline lvalue info prim t*) ,(%constant svoid))]
-        [(set! ,[lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
-         (guard (info-call-error? info) (fx< (debug-level) 2))
+        [(set! ,[lvalue -> lvalue] (mvcall ,info ,mdcl ,[t0?] ,[t1] ... (,[t*] ...)))
+         (guard (info-call-error? info) (or (fx< (debug-level) 2)
+                                            ;; must really escape if fp context
+                                            (fp-lvalue? lvalue)))
          `(mvcall ,info ,mdcl ,t0? ,t1 ... (,t* ...))]
         [(set! ,[lvalue] ,[rhs]) `(seq (set! ,lvalue ,rhs) ,(%constant svoid))]
         [(mvset ,info (,mdcl ,[t0?] ,[t1] ...) (,[t*] ...) ((,x** ...) ,interface* ,l*) ...)
@@ -11053,11 +11737,13 @@
         (define le-label)
         (define-$type-check (L13 Pred))
         (define make-tmp
-          (lambda (x)
+          (case-lambda
+           [(x) (make-tmp x 'ptr)]
+           [(x type)
             (import (only np-languages make-tmp))
-            (let ([x (make-tmp x)])
+            (let ([x (make-tmp x type)])
               (set! local* (cons x local*))
-              x)))
+              x)]))
         (define set-formal-registers!
           (lambda (x*)
             (let do-reg ([x* x*] [reg* arg-registers])
@@ -11111,7 +11797,7 @@
                 (with-output-language (L13 Effect)
                   (let loop ([save-reg* save-reg*] [i 0])
                     (cond
-                      [(null? save-reg*) e]
+                      [(null? save-reg*) (with-saved-ret-reg e)]
                       [else
                        (%seq
                         ,(case i
@@ -11135,15 +11821,15 @@
                            ;; `label-ref` offset is adjusted later if return point turns out to be compact
                            (%seq (set! ,%ref-ret (label-ref ,rpl ,(constant size-rp-header))) ,tl)
                            (meta-cond
-                             [(real-register? '%ret) (%seq (set! ,%ret ,(get-fv 0)) ,tl)]
+                             [(real-register? '%ret) (%seq (set! ,%ret ,(get-ret-fv)) ,tl)]
                              [else tl]))))
                    (define finish-call
                      (lambda (argcnt? cp? t)
-                       (safe-assert (not (eq? t (get-fv 0))))
+                       (safe-assert (not (eq? t (get-ret-fv))))
                        (let ([live-reg* (reg-cons* %ret (if cp? (reg-cons* %cp reg*) reg*))]
                              [live-fv* (meta-cond
                                          [(real-register? '%ret) fv*]
-                                         [else (cons (get-fv 0) fv*)])])
+                                         [else (cons (get-ret-fv) fv*)])])
                          ((lambda (e)
                             (cond
                               [shift-attachment?
@@ -11152,7 +11838,7 @@
                                    (cons (and consumer? %ac0)
                                          (nanopass-case (L13 Triv) t
                                            [,x (cons x live-reg*)]
-                                           [(mref ,x1 ,x2 ,imm) (cons x1 (cons x2 live-reg*))]
+                                           [(mref ,x1 ,x2 ,imm ,type) (cons x1 (cons x2 live-reg*))]
                                            [else live-reg*]))
                                    (%seq
                                     (set! ,%td (inline ,(intrinsic-info-asmlib reify-1cc #f) ,%asmlibcall))
@@ -11423,7 +12109,7 @@
                                      (if (null? frame-t*)
                                          (begin (set! max-fv (fxmax max-fv i)) '())
                                          (let ([i (fx+ i 1)])
-                                           (cons (get-fv i) (f (cdr frame-t*) i)))))])
+                                           (cons (get-ptr-fv i) (f (cdr frame-t*) i)))))])
                           (set-locs fv* frame-t*
                             (set-locs reg* reg-t*
                               (build-call t0 #f reg* fv* info mdcl)))))
@@ -11456,7 +12142,7 @@
                                  (if (null? frame-t*)
                                      (begin (set! max-fv (fxmax max-fv i)) '())
                                      (let ([i (fx+ i 1)])
-                                       (cons (get-fv i) (f (cdr frame-t*) i)))))])
+                                       (cons (get-ptr-fv i) (f (cdr frame-t*) i)))))])
                       (set-locs fv* frame-t*
                         (set-locs reg* reg-t*
                           `(seq
@@ -11465,12 +12151,12 @@
                                 [(real-register? '%ret)
                                  (%seq
                                    ; must leave RA in %ret for values-error
-                                   (set! ,%ret ,(get-fv 0))
+                                   (set! ,%ret ,(get-ret-fv))
                                    ,(%mv-jump ,%ret (,%ac0 ,%ret ,reg* ... ,fv* ...)))]
                                 [else
                                  (%seq
-                                   (set! ,%xp ,(get-fv 0))
-                                   ,(%mv-jump ,%xp (,%ac0 ,reg* ... ,(get-fv 0) ,fv* ...)))])))))))))))
+                                   (set! ,%xp ,(get-ret-fv))
+                                   ,(%mv-jump ,%xp (,%ac0 ,reg* ... ,(get-ret-fv) ,fv* ...)))])))))))))))
         (define-syntax do-return
           (lambda (x)
             (syntax-case x ()
@@ -11478,7 +12164,7 @@
                (with-implicit (k quasiquote)
                  #'`(seq
                       (set! ,%ac0 retval)
-                      (jump ,(get-fv 0) (,%ac0))))])))
+                      (jump ,(get-ret-fv) (,%ac0))))])))
         (define Ref
           (lambda (x)
             (when (uvar? x) (uvar-referenced! x #t))
@@ -11495,7 +12181,7 @@
                   (%inline sll ,t ,(%constant fixnum-offset)))))
             (define Scheme->C
               ; ASSUMPTIONS: ac0, ac1, and xp are not C argument registers
-              (lambda (type toC t)
+              (lambda (type toC t expects-unboxed? is-unboxed?)
                 (define ptr->integer
                   (lambda (width t k)
                     (if (fx>= (constant fixnum-bits) width)
@@ -11531,10 +12217,14 @@
                              ,(toC (in-context Rhs (%lea ,x (constant bytevector-data-disp)))))))))
                 (define build-float
                   (lambda ()
-                    (let ([x (make-tmp 't)])
+                    (let ([x (make-tmp 't (if is-unboxed? 'fp 'ptr))])
                       `(seq
                          (set! ,x ,t)
-                         ,(toC x)))))
+                         ,(toC (if (and expects-unboxed?
+                                        (not is-unboxed?))
+                                   (with-output-language (L13 Rhs)
+                                     (%mref ,x ,%zero ,(constant flonum-data-disp) fp))
+                                   x))))))
                 (nanopass-case (Ltype Type) type
                   [(fp-scheme-object) (toC t)]
                   [(fp-fixnum) (toC (build-unfix t))]
@@ -11567,10 +12257,10 @@
                    ;; to the function as its first argument (or simulated as such)
                    (toC)]
                   [else
-                   (Scheme->C type toC t)])))
+                   (Scheme->C type toC t #f #f)])))
             (define C->Scheme
               ; ASSUMPTIONS: ac0, ac1, and xp are not C argument registers
-              (lambda (type fromC lvalue)
+              (lambda (type fromC lvalue expects-unboxed? is-unboxed?)
                 (define integer->ptr
                  ; ac0 holds low 32-bits, ac1 holds high 32 bits, if needed
                   (lambda (width lvalue)
@@ -11644,6 +12334,16 @@
                     (literal ,(make-info-literal #f 'object ftd 0)))
                    (set! ,(%mref ,%xp ,(constant record-data-disp)) ,%ac0)
                    (set! ,lvalue ,%xp)))
+                (define (receive-fp)
+                  (if is-unboxed?
+                      (fromC lvalue)
+                      (%seq
+                       (set! ,%xp ,(%constant-alloc type-flonum (constant size-flonum) #t))
+                       ,(fromC (if expects-unboxed?
+                                   (with-output-language (L13 Lvalue)
+                                     (%mref ,%xp ,%zero ,(constant flonum-data-disp) fp))
+                                   %xp))
+                       (set! ,lvalue ,%xp))))
                 (nanopass-case (Ltype Type) type
                   [(fp-void) `(set! ,lvalue ,(%constant svoid))]
                   [(fp-scheme-object) (fromC lvalue)]
@@ -11679,16 +12379,8 @@
                            (fromC %ac0 (in-context Lvalue (ref-reg %ac1)))
                            (fromC %ac0))
                       ,(unsigned->ptr bits lvalue))]
-                  [(fp-double-float)
-                   (%seq
-                     (set! ,%xp ,(%constant-alloc type-flonum (constant size-flonum) #t))
-                     ,(fromC %xp)
-                     (set! ,lvalue ,%xp))]
-                  [(fp-single-float)
-                   (%seq
-                     (set! ,%xp ,(%constant-alloc type-flonum (constant size-flonum) #t))
-                     ,(fromC %xp)
-                     (set! ,lvalue ,%xp))]
+                  [(fp-double-float) (receive-fp)]
+                  [(fp-single-float) (receive-fp)]
                   [(fp-ftd ,ftd)
                    (%seq
                     ,(fromC %ac0) ; C integer return might be wiped out by alloc
@@ -11705,20 +12397,28 @@
           (define build-foreign-call
             (with-output-language (L13 Effect)
               (lambda (info t0 t1* maybe-lvalue new-frame?)
-                (let ([arg-type* (info-foreign-arg-type* info)]
-                      [result-type (info-foreign-result-type info)])
-                  (let ([e (let-values ([(allocate c-args ccall c-res deallocate) (asm-foreign-call info)])
-                             ; NB. allocate must save tc if not callee-save, and ccall
-                             ;     (not deallocate) must restore tc if not callee-save
-                             (%seq
+                (let ([atomic? (memq 'atomic (info-foreign-conv* info))]) ;; 'atomic => no callables, not varargs
+                  (let ([arg-type* (info-foreign-arg-type* info)]
+                        [result-type (info-foreign-result-type info)]
+                        [unboxed? (info-foreign-unboxed? info)]
+                        [save-reg? (if atomic?
+                                       (lambda (reg) (not (reg-callee-save? reg)))
+                                       (lambda (reg) #t))])
+                    (let ([e (let-values ([(allocate c-args ccall c-res deallocate) (asm-foreign-call info)])
+                              ; NB. allocate must save tc if not callee-save, and ccall
+                              ;     (not deallocate) must restore tc if not callee-save
+                              (%seq
                                ,(allocate)
-                               ; cp must hold our closure or our code object.  we choose code object
-                               (set! ,(%tc-ref cp) (label-ref ,le-label 0))
+                               ,(if atomic?
+                                    `(nop)
+                                    ;; cp must hold our closure or our code object.  we choose code object
+                                    `(set! ,(%tc-ref cp) (label-ref ,le-label 0)))
                                ,(with-saved-scheme-state
+                                 save-reg?
                                   (in) ; save just the required registers, e.g., %sfp
                                   (out %ac0 %ac1 %cp %xp %yp %ts %td scheme-args extra-regs)
-                                  (fold-left (lambda (e t1 arg-type c-arg) `(seq ,(Scheme->C arg-type c-arg t1) ,e))
-                                    (ccall t0) t1* arg-type* c-args))
+                                  (fold-left (lambda (e t1 arg-type c-arg) `(seq ,(Scheme->C arg-type c-arg t1 #t unboxed?) ,e))
+                                    (ccall t0 atomic?) t1* arg-type* c-args))
                                ,(let ([e (deallocate)])
                                   (if maybe-lvalue
                                       (nanopass-case (Ltype Type) result-type
@@ -11727,11 +12427,13 @@
                                          ;; was instead installed in the first argument.
                                          `(seq (set! ,maybe-lvalue ,(%constant svoid)) ,e)]
                                         [else
-                                         `(seq ,(C->Scheme result-type c-res maybe-lvalue) ,e)])
+                                         `(seq ,(C->Scheme result-type c-res maybe-lvalue #t unboxed?) ,e)])
                                       e))))])
+                    e
+                    #;
                     (if new-frame?
                         (sorry! who "can't handle nontail foreign calls")
-                        e))))))
+                        e)))))))
           (define build-fcallable
             (with-output-language (L13 Tail)
               (lambda (info self-label)
@@ -11749,7 +12451,10 @@
                                    (if (null? frame-x*)
                                        (begin (set! max-fv (fxmax max-fv i)) '())
                                        (let ([i (fx+ i 1)])
-                                         (cons (get-fv i) (f (cdr frame-x*) i)))))])
+                                         (cons (get-ptr-fv i) (f (cdr frame-x*) i)))))]
+                            [cp-save (meta-cond
+                                      [(real-register? '%cp) (make-tmp 'cp)]
+                                      [else #f])])
                         ; add 2 for the old RA and cchain
                         (set! max-fv (fx+ max-fv 2))
                         (let-values ([(c-init c-args c-result c-return) (asm-foreign-callable info)])
@@ -11759,18 +12464,21 @@
                           ; c-return restores callee-save registers and returns to C
                           (%seq
                             ,(c-init)
-                            ; although we don't actually need %cp in a register, we need
-                            ; to make sure that `(%tc-ref cp)` doesn't change before S_call_help
-                            ; is called, and claiming that %cp is live is the easiest way
                             ,(restore-scheme-state
-                               (in %cp)
+                               (in %cp) ; to save and then restore just before S_call_help
                                (out %ac0 %ac1 %xp %yp %ts %td scheme-args extra-regs))
                             ; need overflow check since we're effectively retroactively turning
                             ; what was a foreign call into a Scheme non-tail call
                             (fcallable-overflow-check)
                             ; leave room for the RA & c-chain
                             (set! ,%sfp ,(%inline + ,%sfp (immediate ,(fx* (constant ptr-bytes) 2))))
-                            ,(fold-left (lambda (e x arg-type c-arg) `(seq ,(C->Scheme arg-type c-arg x) ,e))
+                            ; stash %cp and restore later to make sure it's intact by the time
+                            ; that we get to S_call_help
+                            ,(meta-cond
+                              [(real-register? '%cp) `(set! ,cp-save ,%cp)]
+                              [else `(nop)])
+                            ; convert arguments
+                            ,(fold-left (lambda (e x arg-type c-arg) `(seq ,(C->Scheme arg-type c-arg x #f #f) ,e))
                                (set-locs fv* frame-x*
                                  (set-locs (map (lambda (reg) (in-context Lvalue (%mref ,%tc ,(reg-tc-disp reg)))) reg*) reg-x*
                                    `(set! ,%ac0 (immediate ,(length arg-type*)))))
@@ -11779,6 +12487,9 @@
                             ; needs to be a quote, not an immediate
                             (set! ,(ref-reg %ac1) (literal ,(make-info-literal #f 'object 0 0)))
                             (set! ,(ref-reg %ts) (label-ref ,self-label 0)) ; for locking
+                            ,(meta-cond
+                              [(real-register? '%cp) `(set! ,%cp ,cp-save)]
+                              [else `(nop)])
                             ,(save-scheme-state
                                (in %ac0 %ac1 %ts %cp)
                                (out %xp %yp %td scheme-args extra-regs))
@@ -11965,7 +12676,7 @@
                                         (set! ,%ts ,(%inline + ,%ts ,%td))
                                         ,(%inline < ,(ref-reg %esp) ,%ts)))
                                  ,(%seq
-                                    ,(with-saved-scheme-state
+                                   ,(with-saved-scheme-state
                                        (in %ac0 %cp %xp %yp scheme-args)
                                        (out %ac1 %ts %td extra-regs)
                                        `(inline ,(make-info-c-simple-call #f (lookup-c-entry split-and-resize)) ,%c-simple-call))
@@ -12111,13 +12822,13 @@
                                           (set! ,%ret ,(%mref ,xp/cp ,(constant continuation-return-address-disp)))
                                           ,(%mv-jump ,%ret (,%ac0 ,%ret ,arg-registers ...)))]
                                        [else
-                                         (let ([fv0 (get-fv 0)])
+                                         (let ([fv0 (get-ret-fv)])
                                            (%seq
                                              (set! ,%xp ,(%mref ,xp/cp ,(constant continuation-return-address-disp)))
                                              (set! ,fv0 ,%xp)
                                              ,(%mv-jump ,%xp (,%ac0 ,arg-registers ... ,fv0))))]))))))))))))
         (define reify-cc-help
-          (lambda (1-shot? always? finish)
+          (lambda (1-shot? always? save-ra? ref-ret finish)
             (with-output-language (L13 Tail)
                 (%seq
                   (set! ,%td ,(%tc-ref stack-link))
@@ -12126,7 +12837,7 @@
                              (%seq
                                ,(let ([alloc
                                        (%seq
-                                        (set! ,%xp ,(%constant-alloc type-closure (constant size-continuation)))
+                                        (set! ,%xp ,(%constant-alloc type-closure (constant size-continuation) #f save-ra?))
                                         (set! ,(%mref ,%xp ,(constant continuation-code-disp))
                                               (literal ,(make-info-literal #f 'library (lookup-libspec nuate) (constant code-data-disp)))))])
                                   (if 1-shot?
@@ -12136,10 +12847,10 @@
                                            ,alloc
                                            (set! ,(%tc-ref cached-frame) ,(%constant sfalse))))
                                       alloc))
-                               (set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,%ref-ret)
+                               (set! ,(%mref ,%xp ,(constant continuation-return-address-disp)) ,ref-ret)
                                (set! ,(%mref ,%xp ,(constant continuation-winders-disp)) ,(%tc-ref winders))
                                (set! ,(%mref ,%xp ,(constant continuation-attachments-disp)) ,(%tc-ref attachments))
-                               (set! ,%ref-ret ,%ac0)
+                               (set! ,ref-ret ,%ac0)
                                (set! ,(%mref ,%xp ,(constant continuation-link-disp)) ,%td)
                                (set! ,(%tc-ref stack-link) ,%xp)
                                (set! ,%ac0 ,(%tc-ref scheme-stack))
@@ -12168,7 +12879,7 @@
                                                 ,(%mref ,%td ,(constant continuation-attachments-disp))
                                                 ,(%constant sfalse))
                                             (false)
-                                            ,(%inline eq? ,%ref-ret ,%ac0))
+                                            ,(%inline eq? ,ref-ret ,%ac0))
                                         ,(finish %td)
                                         ,(build-reify)))))])
                      (if 1-shot?
@@ -12214,7 +12925,7 @@
                  (set! ,uf (literal ,(make-info-literal #f 'library-code
                                                         (lookup-libspec dounderflow)
                                                         (fx+ (constant code-data-disp) (constant size-rp-header)))))
-                 (if ,(%inline eq? ,%ref-ret ,uf)
+                 (if ,(%inline eq? ,(get-ret-fv) ,uf)
                      ;; Maybe reified, so maybe an attachment
                      ,(%seq
                        (set! ,sl ,(%tc-ref stack-link))
@@ -12268,28 +12979,31 @@
            [(dorest4) (make-do-rest 4 frame-args-offset)]
            [(dorest5) (make-do-rest 5 frame-args-offset)]
            [(reify-1cc maybe-reify-cc)
-            (let ([other-reg* (fold-left (lambda (live* kill) (remq kill live*))
-                                         (vector->list regvec)
-                                         ;; Registers used by `reify-cc-help` output,
-                                         ;; plus `%ts` so that we have one to allocate
-                                         (reg-list %xp %td %ac0 %ts))]
-                  [1cc? (eq? sym 'reify-1cc)])
+            (let ([1cc? (eq? sym 'reify-1cc)])
               `(lambda ,(make-named-info-lambda (if 1cc? "reify-1cc" "maybe-reify-cc") '(0)) 0 ()
                 ,(asm-enter
                    (%seq
-                     (check-live ,other-reg* ...)
-                     ,(reify-cc-help 1cc? 1cc?
+                     ;; make sure the reify-1cc intrinsic declares kill for registers used by `reify-cc-help`,
+                     ;; plus (say) %ts to have one to allocate, plus more as needed to allocate per machine
+                     (check-live ,(intrinsic-entry-live* reify-1cc) ...)
+                     ,(reify-cc-help 1cc? 1cc? #t (with-output-language (L13 Lvalue)
+                                                    ;; Use sfp[0] instead of the ret register,
+                                                    ;; because we want to refer to this call's return
+                                                    (%mref ,%sfp 0))
                        (lambda (reg)
                          (if (eq? reg %td)
-                             `(asm-return ,%td ,other-reg* ...)
+                             `(asm-return ,%td ,(intrinsic-return-live* reify-1cc) ...)
                              `(seq
                                 (set! ,%td ,reg)
-                                (asm-return ,%td ,other-reg* ...)))))))))]
+                                (asm-return ,%td ,(intrinsic-return-live* reify-1cc) ...)))))))))]
            [(callcc)
             `(lambda ,(make-named-info-lambda 'callcc '(1)) 0 ()
                ,(%seq
                   (set! ,(ref-reg %cp) ,(make-arg-opnd 1))
-                  ,(reify-cc-help #f #f
+                  ,(reify-cc-help #f #f #f (with-output-language (L13 Lvalue)
+                                             ;; Use the ret registerr (if any), because reify
+                                             ;; adjusts the return address for a tail call
+                                             %ref-ret)
                     (lambda (reg)
                       (%seq
                         (set! ,(make-arg-opnd 1) ,reg)
@@ -12428,10 +13142,10 @@
            [else `(hand-coded ,sym)])])
       (Lvalue : Lvalue (ir) -> Lvalue ()
         [,x (Ref x)]
-        [(mref ,x1 ,x2 ,imm) (%mref ,(Ref x1) ,(Ref x2) ,imm)])
+        [(mref ,x1 ,x2 ,imm ,type) (%mref ,(Ref x1) ,(Ref x2) ,imm ,type)])
       (Triv : Triv (ir) -> Triv ()
         [,x (Ref x)] ; TODO: cannot call ref in cata, as we don't allow top-level cata
-        [(mref ,x1 ,x2 ,imm) (%mref ,(Ref x1) ,(Ref x2) ,imm)])
+        [(mref ,x1 ,x2 ,imm ,type) (%mref ,(Ref x1) ,(Ref x2) ,imm ,type)])
       (Rhs : Rhs (ir) -> Rhs ()
         [(mvcall ,info ,mdcl ,t0? ,t1* ... (,t* ...))
          ($oops who "Effect is responsible for handling mvcalls")]
@@ -12561,7 +13275,7 @@
                                      ,(%mref ,%td ,(constant continuation-attachments-disp))
                                      ,(%constant sfalse))
                            (false)
-                           ,(%inline eq? ,%ref-ret ,tmp))
+                           ,(%inline eq? ,(get-ret-fv) ,tmp))
                        (if ,(%inline eq? ,(%mref ,%td ,(constant continuation-attachments-disp)) ,ats)
                            (nop)
                            (set! ,ats ,(%mref ,ats ,(constant pair-cdr-disp))))
@@ -12590,7 +13304,7 @@
                         (set! ,tmp (literal ,(make-info-literal #f 'library-code
                                                                 (lookup-libspec dounderflow)
                                                                 (fx+ (constant code-data-disp) (constant size-rp-header)))))
-                        (set! ,%ref-ret ,tmp)
+                        (set! ,(get-ret-fv) ,tmp)
                         (set! ,delta ,(%inline - ,%sfp ,(%tc-ref scheme-stack)))
                         (set! ,(%tc-ref scheme-stack) ,%sfp)
                         (set! ,(%tc-ref scheme-stack-size) ,(%inline - ,(%tc-ref scheme-stack-size) ,delta))
@@ -12616,7 +13330,8 @@
          (for-each (lambda (x) (uvar-referenced! x #f)) x*)
          (let do-frame ([x* (set-formal-registers! x*)] [fv-idx 1])
            (unless (null? x*)
-             (let ([x (car x*)] [fv (get-fv fv-idx)])
+             (let ([x (car x*)] [fv (get-ptr-fv fv-idx)])
+               (safe-assert (compatible-fv? fv (uvar-type x)))
                (uvar-location-set! x fv)
                (do-frame (cdr x*) (fx+ fv-idx 1)))))
          (let ()
@@ -12645,7 +13360,7 @@
                ; TODO: don't want to save ret for leaf routines
                ; TODO: don't necessarily want to position ret save here
                ,(meta-cond
-                  [(real-register? '%ret) `(set! ,(get-fv 0) ,%ret)]
+                  [(real-register? '%ret) `(set! ,(get-ret-fv) ,%ret)]
                   [else `(nop)])
                (overflood-check)
                ,(bind-formals mcp x* tlbody))))]
@@ -12655,7 +13370,7 @@
          `(seq
             ; CAUTION: fv0 must hold return address when we call into C
             ,(build-foreign-call info t0 t1* %ac0 #f)
-            (jump ,(get-fv 0) (,%ac0)))]
+            (jump ,(get-ret-fv) (,%ac0)))]
         [,rhs (do-return ,(Rhs ir))]
         [(values ,info ,[t]) (do-return ,t)]
         [(values ,info ,t* ...) (build-mv-return t*)]))
@@ -13192,7 +13907,7 @@
                         [else
                           (%seq
                             (set! ,%xp ,%ref-ret)
-                            ,(%mv-jump ,%xp (,%ac0 ,arg-registers ... ,(get-fv 0))))]))))]
+                            ,(%mv-jump ,%xp (,%ac0 ,arg-registers ... ,(get-ret-fv))))]))))]
            [($apply-procedure)
             (let ([Lloop (make-local-label 'loop)]
                   [Ldone (make-local-label 'done)])
@@ -13627,8 +14342,10 @@
                        (in %ac0 %cp scheme-args)
                        (out %ac1 %xp %yp %ts %td extra-regs))
                     (new-frame ,(make-info-newframe #f #f '() '() '()) ,'() ... ,Lret)
-                    ; NB: hack!!!
-                    (set! ,%sfp ,(%inline - ,%sfp (immediate ,(constant ptr-bytes))))
+                    ; NB: hack!!! Asssuming a frame-size calculation:
+                    (set! ,%sfp ,(%inline - ,%sfp (immediate ,(constant-case stack-word-alignment
+                                                                [(2) (fx* 2 (constant ptr-bytes))]
+                                                                [(1) (constant ptr-bytes)]))))
                     (set! ,%ref-ret (label-ref ,Lret ,(constant size-rp-header)))
                     (tail ,(do-call)) ; argcnt already in ac0
                     #;(asm align)
@@ -13651,7 +14368,7 @@
                ,(constant-case architecture
                   [(x86_64)
                    `(seq
-                     (set! ,%rax (inline ,(make-info-inline) ,%popcount ,%rdi))
+                     (set! ,%rax (inline ,(make-info-inline) ,%popcount ,%rcx))
                      (asm-c-return ,null-info ,%rax))]
                   [else
                    ;; Generate anything, since this should not get called
@@ -13760,7 +14477,7 @@
                (set! ,refeap ,(%inline - ,refeap ,(%constant ptr-bytes)))
                ; write through to tc so dirty-list bounds are always known in case of an
                ; invalid memory reference or illegal instruction
-               (set! (mref ,%tc ,%zero ,(tc-disp %eap)) ,refeap)
+               (set! (mref ,%tc ,%zero ,(tc-disp %eap) uptr) ,refeap)
                (set! ,(%mref ,refeap 0) ,t))
              (%seq
                (set! ,%td ,refeap)
@@ -13928,7 +14645,7 @@
                   (values block (cons block block*))))))
           (Lvalue : Lvalue (ir target) -> * (ir)
             [,x x]
-            [(mref ,x1 ,x2 ,imm) (with-output-language (L15a Lvalue) `(mref ,x1 ,x2 ,imm))])
+            [(mref ,x1 ,x2 ,imm ,type) (with-output-language (L15a Lvalue) `(mref ,x1 ,x2 ,imm ,type))])
           (Triv : Triv (ir target) -> * (ir)
             [(literal ,info) (with-output-language (L15a Triv) `(literal ,info))]
             [(immediate ,imm) (with-output-language (L15a Triv) `(immediate ,imm))]
@@ -14939,7 +15656,7 @@
                       (lambda (lvalue)
                         (nanopass-case (L15a Lvalue) lvalue
                           [,x (process-var x)]
-                          [(mref ,x1 ,x2 ,imm) (process-var x1) (process-var x2)])))
+                          [(mref ,x1 ,x2 ,imm ,type) (process-var x1) (process-var x2)])))
                     (define Triv
                       (lambda (t)
                         (nanopass-case (L15a Triv) t
@@ -15226,6 +15943,11 @@
           (define touch-label!
             (lambda (l)
               (unless (libspec-label? l) (local-label-iteration-set! l 1))))
+          (define (fp-lvalue? lvalue)
+            (nanopass-case (L16 Lvalue) lvalue
+              [,x (or (and (uvar? x) (eq? (uvar-type x) 'fp))
+                      (and (reg? x) (eq? (reg-type x) 'fp)))]
+              [(mref ,x1 ,x2 ,imm ,type) (eq? type 'fp)]))
           (define LambdaBody
             (lambda (entry-block* block* func)
               #;(when (#%$assembly-output)
@@ -15279,7 +16001,7 @@
           [(asm-return) (values (asm-return) chunk* offset)]
           [(asm-c-return ,info) (values (asm-c-return info) chunk* offset)]
           [(jump (label-ref ,l ,offset0))
-           (values (asm-direct-jump l (adjust-return-point-offset offset0 l)) chunk* offset)]
+           (values (asm-direct-jump l offset0) chunk* offset)]
           [(jump (literal ,info))
            (values (asm-literal-jump info) chunk* offset)]
           [(jump ,t)
@@ -15362,13 +16084,16 @@
           [(rp-compact-header ,error-on-values ,fs ,lpm) (values (asm-rp-compact-header code* error-on-values fs lpm current-func #f) chunk* offset)]
           [(set! ,x (label-ref ,l ,offset1))
            (guard (eq? (local-label-func l) current-func))
-           (let ([chunk (make-chunk code*)]
-                 [offset1 (adjust-return-point-offset offset1 l)])
+           (let ([chunk (make-chunk code*)])
              (let ([offset (fx+ (chunk-size chunk) offset)] [chunk* (cons chunk chunk*)])
                (let ([chunk (asm-return-address x l offset1 offset)])
                  (values '() (cons chunk chunk*) (fx+ (chunk-size chunk) offset)))))]
           [(set! ,lvalue (asm ,info ,proc ,t* ...)) (values (apply proc code* lvalue t*) chunk* offset)]
-          [(set! ,lvalue ,rhs) (values (asm-move code* lvalue rhs) chunk* offset)]
+          [(set! ,lvalue ,rhs) (values (if (fp-lvalue? lvalue)
+                                           (asm-fpmove code* lvalue rhs)
+                                           (asm-move code* lvalue rhs))
+                                       chunk*
+                                       offset)]
           [(asm ,info ,proc ,t* ...) (values (apply proc code* t*) chunk* offset)])
         (Pred : Pred (ir l1 l2 offset) -> * (code* chunk)
           [(asm ,info ,proc ,t* ...) (apply proc l1 l2 offset t*)])
@@ -15377,7 +16102,7 @@
       (define-pass Triv->rand : (L16 Triv) (ir) -> * (operand)
         (Triv : Triv (ir) -> * (operand)
           [,x (cons 'reg x)]
-          [(mref ,x1 ,x2 ,imm)
+          [(mref ,x1 ,x2 ,imm ,type)
            (if (eq? x2 %zero)
                `(disp ,imm ,x1)
                `(index ,imm ,x2 ,x1))]
@@ -15534,6 +16259,18 @@
             (tree-extract (cset-tree cset) (cset-size cset) v)))
         )
 
+      ;; Alignment to support unboxed doubles
+      (define stack-align
+        (lambda (n)
+          (constant-case stack-word-alignment
+            [(2) (if (fxodd? n) (fx+ n 1) n)]
+            [(1) n])))
+      (define stack-aligned-first-argument?
+        (lambda (n)
+          (constant-case stack-word-alignment
+            [(2) (fxodd? n)]
+            [(1) #t])))
+
       (define do-live-analysis!
         (lambda (live-size entry-block*)
           (define add-var (make-add-var live-size))
@@ -15550,7 +16287,7 @@
               (define Triv
                 (lambda (out t)
                   (nanopass-case (L15a Triv) t
-                    [(mref ,x1 ,x2 ,imm) (add-var (add-var out x2) x1)]
+                    [(mref ,x1 ,x2 ,imm ,type) (add-var (add-var out x2) x1)]
                     [,x (add-var out x)]
                     [else out])))
               (define Rhs
@@ -15609,7 +16346,7 @@
                              (begin
                                (live-info-live-set! live-info out)
                                (Rhs out rhs)))]
-                        [(set! ,live-info (mref ,x1 ,x2 ,imm) ,rhs)
+                        [(set! ,live-info (mref ,x1 ,x2 ,imm ,type) ,rhs)
                          (live-info-live-set! live-info out)
                          (Rhs (add-var (add-var out x1) x2) rhs)]
                         [(inline ,live-info ,info ,effect-prim ,t* ...)
@@ -15694,7 +16431,7 @@
                        (if (or (null? nfv*) (fx> i max-fv))
                            next
                            (loop (cdr nfv*) (fx+ i 1)
-                             (let ([new-next (remove-var next (get-fv i))])
+                             (let ([new-next (remove-var next (get-ptr-fv i))])
                                (if (eq? new-next next)
                                    next
                                    (add-var next (car nfv*)))))))))]
@@ -15720,7 +16457,7 @@
                                                          (reg-cons* %ret %ac0 arg-registers)
                                                          (info-newframe-cnfv* newframe-info)
                                                          (info-newframe-nfv** newframe-info)))
-                                                     (get-fv 0))])
+                                                     (get-ret-fv))])
                                          (newframe-block-live-call-set! block call)
                                          call)))])
                        (let ([out (union-live
@@ -16006,7 +16743,7 @@
                                     (if (conflict-fv? x0 fv)
                                         (loop move* work*)
                                         (begin
-                                          (safe-assert (not (eq? fv (get-fv 0))))
+                                          (safe-assert (not (eq? fv (get-ret-fv))))
                                           (begin (clear-seen!) (succ fv))))))
                                 (if (fv? var)
                                     (try-fv var)
@@ -16020,20 +16757,33 @@
               (lambda (spill max-fv first-open)
                 (define return
                   (lambda (home max-fv first-open)
+                    (safe-assert (compatible-fv? home (uvar-type spill)))
                     (uvar-location-set! spill home)
                     (update-conflict! home spill)
-                    (values max-fv first-open)))
+                    (let ([max-fv
+                           (constant-case ptr-bits
+                             [(32)
+                              (cond
+                                [(eq? (uvar-type spill) 'fp)
+                                 ;; Make sure next slot is unused
+                                 (let ([fv (get-fv (fx+ 1 (fv-offset home)) 'reserved)])
+                                   (safe-assert (eq? (fv-type fv) 'reserved)))
+                                 (fxmax max-fv (fx+ 1 (fv-offset home)))]
+                                [else max-fv])]
+                             [(64) max-fv])])
+                      (values max-fv first-open))))
                 (find-move-related-home spill
                   (lambda (home) (return home max-fv first-open))
                   (lambda ()
                     (let f ([first-open first-open])
-                      (let* ([fv (get-fv first-open)] [cset (var-spillable-conflict* fv)])
+                      (let* ([fv (get-fv first-open (uvar-type spill))] [cset (var-spillable-conflict* fv)])
                         (if (and cset (cset-full? cset))
                             (f (fx+ first-open 1))
                             (let ([spill-offset (var-index spill)])
                               (let f ([fv-offset first-open] [fv fv] [cset cset])
-                                (if (and cset (conflict-bit-set? cset spill-offset))
-                                    (let* ([fv-offset (fx+ fv-offset 1)] [fv (get-fv fv-offset)] [cset (var-spillable-conflict* fv)])
+                                (if (or (and cset (conflict-bit-set? cset spill-offset))
+                                        (not (compatible-fv? fv (uvar-type spill))))
+                                    (let* ([fv-offset (fx+ fv-offset 1)] [fv (get-fv fv-offset (uvar-type spill))] [cset (var-spillable-conflict* fv)])
                                       (f fv-offset fv cset))
                                     (return fv (fxmax fv-offset max-fv) first-open)))))))))))
             (define find-homes!
@@ -16062,8 +16812,10 @@
                 (let loop ([nfv* nfv*] [offset base])
                   (or (null? nfv*)
                       (and (or (not (car nfv*))
-                               (let ([cset (var-spillable-conflict* (get-fv offset))])
-                                 (not (and cset (conflict-bit-set? cset (var-index (car nfv*)))))))
+                               (let ([fv (get-fv offset)])
+                                 (and (compatible-fv? fv 'ptr)
+                                      (let ([cset (var-spillable-conflict* fv)])
+                                        (not (and cset (conflict-bit-set? cset (var-index (car nfv*)))))))))
                            (loop (cdr nfv*) (fx+ offset 1)))))))
             (define assign-new-frame!
               (lambda (cnfv* nfv** call-live*)
@@ -16071,14 +16823,17 @@
                   (lambda (nfv* offset)
                     (if (null? nfv*)
                         (set! max-fv (fxmax offset max-fv))
-                        (let ([nfv (car nfv*)] [home (get-fv offset)])
+                        (let* ([nfv (car nfv*)] [home (get-fv offset (uvar-type nfv))])
+                          (safe-assert (compatible-fv? home (uvar-type nfv)))
                           (uvar-location-set! nfv home)
                           (update-conflict! home nfv)
                           (set-offsets! (cdr nfv*) (fx+ offset 1))))))
                 (let ([arg-offset (fx+ (length cnfv*) 1)]) ; +1 for return address slot
                   (let loop ([base (fx+ (find-max-fv call-live*) 1)])
                     (let ([arg-base (fx+ base arg-offset)])
-                      (if (and (cool? base cnfv*) (andmap (lambda (nfv*) (cool? arg-base nfv*)) nfv**))
+                      (if (and (stack-aligned-first-argument? arg-base)
+                               (cool? base cnfv*)
+                               (andmap (lambda (nfv*) (cool? arg-base nfv*)) nfv**))
                           (begin
                             (set! max-fs@call (fxmax max-fs@call base)) ; max frame size @ call in ptrs
                             (set-offsets! cnfv* base)
@@ -16142,8 +16897,9 @@
                                          [(and (uvar? x) (uvar-iii x)) =>
                                           (lambda (index)
                                             (safe-assert
-                                              (let ([name.offset (vector-ref (ctci-live ctci) index)])
-                                                (logbit? (fx- (cdr name.offset) 1) lpm)))
+                                             (or (eq? (uvar-type x) 'fp)
+                                                 (let ([name.offset (vector-ref (ctci-live ctci) index)])
+                                                   (logbit? (fx- (cdr name.offset) 1) lpm))))
                                             (cons index i*))]
                                          [else i*]))
                                      '() call-live*))])
@@ -16197,7 +16953,7 @@
                  (safe-assert (not (fx= frame-words 0)))
                  (let ([shift-offset (fx* frame-words (constant ptr-bytes))])
                    (safe-assert (fx> shift-offset 0))
-                   (cons `(set! ,live-info (mref ,reg ,%zero ,imm) (mref ,reg ,%zero ,shift-offset)) new-effect*))))]
+                   (cons `(set! ,live-info (mref ,reg ,%zero ,imm ptr) (mref ,reg ,%zero ,shift-offset ptr)) new-effect*))))]
             [(check-live ,live-info ,reg* ...)
              (let ([live (fold-left (lambda (live reg)
                                       (let ([t (remove-var live reg)])
@@ -16295,11 +17051,11 @@
             (lambda (x cur-off)
               (if (fv? x)
                   (with-output-language (L15c Lvalue)
-                    `(mref ,%sfp ,%zero ,(fx- (fx* (fv-offset x) (constant ptr-bytes)) cur-off)))
+                    `(mref ,%sfp ,%zero ,(fx- (fx* (fv-offset x) (constant ptr-bytes)) cur-off) ,(fv-type x)))
                   x))))
         (Lvalue : Lvalue (ir cur-off) -> Lvalue ()
-          [(mref ,x0 ,x1 ,imm)
-           `(mref ,(fv->mref (var->loc x0) cur-off) ,(fv->mref (var->loc x1) cur-off) ,imm)]
+          [(mref ,x0 ,x1 ,imm ,type)
+           `(mref ,(fv->mref (var->loc x0) cur-off) ,(fv->mref (var->loc x1) cur-off) ,imm ,type)]
           [,x (fv->mref (var->loc x) cur-off)])
         ; NB: defining Triv & Rhs with cur-off argument so we actually get to our version of Lvalue
         (Triv : Triv (ir cur-off) -> Triv ())
@@ -16338,13 +17094,16 @@
             block*)
           `(dummy)))
 
+      ;; updates live-variable info as instructions are expanded
       (module (select-instructions!)
         (define make-tmp
-          (lambda (x)
+          (case-lambda
+           [(x) (make-tmp x 'uptr)]
+           [(x type)
             (import (only np-languages make-unspillable))
-            (let ([tmp (make-unspillable x)])
+            (let ([tmp (make-unspillable x type)])
               (set! unspillable* (cons tmp unspillable*))
-              tmp)))
+              tmp)]))
         (define make-restricted-unspillable
           (lambda (x reg*)
             (import (only np-languages make-restricted-unspillable))
@@ -16407,24 +17166,25 @@
         (define mref?
           (lambda (x)
             (nanopass-case (L15c Triv) x
-              [(mref ,lvalue1 ,lvalue2 ,imm) #t]
+              [(mref ,lvalue1 ,lvalue2 ,imm ,type) #t]
               [else #f])))
         (define same?
           (lambda (a b)
             (or (eq? a b)
                 (nanopass-case (L15c Triv) a
-                  [(mref ,lvalue11 ,lvalue12 ,imm1)
+                  [(mref ,lvalue11 ,lvalue12 ,imm1 ,type1)
                    (nanopass-case (L15c Triv) b
-                     [(mref ,lvalue21 ,lvalue22 ,imm2)
+                     [(mref ,lvalue21 ,lvalue22 ,imm2 ,type2)
                       (and (or (and (eq? lvalue11 lvalue21) (eq? lvalue12 lvalue22))
                                (and (eq? lvalue11 lvalue22) (eq? lvalue12 lvalue21)))
-                           (eqv? imm1 imm2))]
+                           (eqv? imm1 imm2)
+                           (eq? type1 type2))]
                      [else #f])]
                   [else #f]))))
 
         (define-pass imm->imm : (L15c Triv) (ir) -> (L15d Triv) ()
           (Lvalue : Lvalue (ir) -> Lvalue ()
-            [(mref ,lvalue1 ,lvalue2 ,imm) (sorry! who "unexpected mref ~s" ir)])
+            [(mref ,lvalue1 ,lvalue2 ,imm ,type) (sorry! who "unexpected mref ~s" ir)])
           (Triv : Triv (ir) -> Triv ()))
 
         (define-pass literal@->literal : (L15c Triv) (ir) -> (L15d Triv) ()
@@ -16442,7 +17202,7 @@
               (define Triv
                 (lambda (out t)
                   (nanopass-case (L15d Triv) t
-                    [(mref ,x1 ,x2 ,imm) (add-var (add-var out x2) x1)]
+                    [(mref ,x1 ,x2 ,imm ,type) (add-var (add-var out x2) x1)]
                     [,x (add-var out x)]
                     [else out])))
               (define Rhs
@@ -16499,10 +17259,10 @@
                 (if force-overflow?
                     (fxmax
                       (fx- (fx* max-fs@call (constant ptr-bytes)) 0)
-                      (fx- (fx* (fx+ max-fv 1) (constant ptr-bytes)) (fx- (constant stack-slop) (fx* (constant stack-frame-limit) 2))))
+                      (fx- (fx* (fx+ (stack-align max-fv) 1) (constant ptr-bytes)) (fx- (constant stack-slop) (fx* (constant stack-frame-limit) 2))))
                     (fxmax
                       (fx- (fx* max-fs@call (constant ptr-bytes)) (constant stack-frame-limit))
-                      (fx- (fx* (fx+ max-fv 1) (constant ptr-bytes)) (fx- (constant stack-slop) (constant stack-frame-limit)))))))
+                      (fx- (fx* (fx+ (stack-align max-fv) 1) (constant ptr-bytes)) (fx- (constant stack-slop) (constant stack-frame-limit)))))))
             (define overage (compute-overage max-fs@call))
             (define handle-overflow-check
               (lambda (reg info new-effect* live)
@@ -16512,7 +17272,7 @@
                                                       (meta-cond
                                                         [(real-register? '%esp) %esp]
                                                         [else (with-output-language (L15c Triv)
-                                                                `(mref ,%tc ,%zero ,(tc-disp %esp)))]))
+                                                                `(mref ,%tc ,%zero ,(tc-disp %esp) uptr))]))
                                                     live)])
                   (append xnew-effect*
                     (cons (with-output-language (L15d Effect)
@@ -16554,11 +17314,17 @@
                           (begin
                             (assert (not (checks-cc? block)))
                             (f e*))))
-                    e*))))
+                    e*)))
+            (define (fp-lvalue? lvalue)
+              (nanopass-case (L15c Lvalue) lvalue
+                [,x (or (and (uvar? x) (eq? (uvar-type x) 'fp))
+                        (and (reg? x) (eq? (reg-type x) 'fp)))]
+                [(mref ,lvalue1 ,lvalue2 ,imm ,type) (eq? type 'fp)])))
           (Rhs : Rhs (ir lvalue new-effect* live) -> * (new-effect*)
             [(inline ,info ,value-prim ,t* ...)
              (handle-value-inline lvalue value-prim info new-effect* t* live)]
-            [else (handle-value-inline lvalue %move null-info new-effect* (list ir) live)])
+            [else (let ([op (if (fp-lvalue? lvalue) %fpmove %move)])
+                    (handle-value-inline lvalue op null-info new-effect* (list ir) live))])
           (Tail : Tail (ir) -> Tail ()
             [(jump ,live-info ,t) (handle-jump t (live-info-live live-info))]
             [(goto ,l) (values '() `(goto ,l))]
@@ -16681,7 +17447,7 @@
           (define Triv
             (lambda (unspillable* t)
               (nanopass-case (L15d Triv) t
-                [(mref ,x1 ,x2 ,imm) (add-unspillable (add-unspillable unspillable* x2) x1)]
+                [(mref ,x1 ,x2 ,imm ,type) (add-unspillable (add-unspillable unspillable* x2) x1)]
                 [,x (add-unspillable unspillable* x)]
                 [else unspillable*])))
           (define Rhs
@@ -16702,6 +17468,8 @@
           (define Effect*
             (lambda (e* unspillable*)
               (if (null? e*)
+                  ;; If this assertion fails, then an unspillable was referenced
+                  ;; without a preceding assignment:
                   (safe-assert (null? unspillable*))
                   (Effect* (cdr e*)
                     (nanopass-case (L15d Effect) (car e*)
@@ -16709,6 +17477,7 @@
                        (let ([spillable-live (live-info-live live-info)])
                          (if (unspillable? x)
                              (let ([unspillable* (remq x unspillable*)])
+                               (unless (uvar-seen? x) (#%printf ">> ~s\n" x))
                                (safe-assert (uvar-seen? x))
                                (uvar-seen! x #f)
                                (if (and (var? rhs) (var-index rhs))
@@ -16756,10 +17525,19 @@
 
       (define-who assign-registers!
         (lambda (lambda-info varvec unvarvec)
-          (define k (vector-length regvec))
+          (define total-k (vector-length regvec))
+          (define fp-k (length extra-fpregisters))
+          (define ptr-k (- total-k fp-k))
           (define uvar-weight
             (lambda (x)
-              (fx- (uvar-ref-weight x) (uvar-save-weight x))))
+              (cond
+                [(eq? (uvar-type x) 'fp)
+                 ;; Prioritize FP registers by degree only, which makes
+                 ;; sense with a few registers where we want to prioritize
+                 ;; local calculations
+                 0]
+                [else
+                 (fx- (uvar-ref-weight x) (uvar-save-weight x))])))
           ; could also be calculated when the conflict set is built, which would be more
           ; efficient for low-degree variables
           (define compute-degrees!
@@ -16790,8 +17568,9 @@
             (lambda (x)
               (define conflict?
                 (lambda (reg x)
-                  (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg) (var-spillable-conflict* reg))])
-                    (conflict-bit-set? cset (var-index x)))))
+                  (or (not (compatible-var-types? (reg-type reg) (uvar-type x)))
+                      (let ([cset (if (uvar-unspillable? x) (var-unspillable-conflict* reg) (var-spillable-conflict* reg))])
+                        (conflict-bit-set? cset (var-index x))))))
               (define find-move-related-home
                 (lambda (x0 succ fail)
                   (let f ([x x0] [work* '()] [clear-seen! void])
@@ -16827,17 +17606,19 @@
               (find-move-related-home x
                 set-home!
                 (lambda ()
-                  (let f ([offset (fx- k 1)])
+                  (let f ([offset (fx- total-k 1)])
                     (cond
                       [(fx< offset 0)
                        (uvar-spilled! x #t)
                        (when (uvar-unspillable? x)
-                         (sorry! who "spilled unspillable ~s" x))]
+                         (sorry! who "spilled unspillable ~s in ~s" x lambda-info))]
                       [(conflict? (vector-ref regvec offset) x) (f (fx- offset 1))]
                       [else (set-home! (vector-ref regvec offset))]))))))
           (define pick-victims
             (lambda (x*)
-              (define low-degree? (lambda (x) (fx< (uvar-degree x) k)))
+              (define low-degree? (lambda (x) (fx< (uvar-degree x) (if (eq? (uvar-type x) 'fp)
+                                                                       fp-k
+                                                                       ptr-k))))
               (define pick-potential-spill
                 ; x* is already sorted by weight, so this effectively picks uvar with
                 ; the highest degree among those with the lowest weight
@@ -16962,7 +17743,12 @@
                                     [else (f i (cdr spillable*))])
                                   (let ([v (f (fx+ i 1) (cdr spillable*))])
                                     (uvar-iii-set! spillable i)
-                                    (vector-set! v i (cons (unannotate source) (fv-offset (uvar-location spillable))))
+                                    (vector-set! v i (cons (let ([name (unannotate source)])
+                                                             ;; A boxed symbol means an "unboxed" variable
+                                                             (if (eq? (uvar-type spillable) 'fp)
+                                                                 (box name)
+                                                                 name))
+                                                           (fv-offset (uvar-location spillable))))
                                     v)))]
                            [else (f i (cdr spillable*))]))))))])))
 
@@ -16974,7 +17760,7 @@
                   (or (uvar-location x) (sorry! who "no location assigned to uvar ~s" x))
                   x))))
         (Lvalue : Lvalue (ir) -> Lvalue ()
-          [(mref ,x0 ,x1 ,imm) `(mref ,(var->loc x0) ,(var->loc x1) ,imm)]
+          [(mref ,x0 ,x1 ,imm ,type) `(mref ,(var->loc x0) ,(var->loc x1) ,imm ,type)]
           [,x (var->loc x)])
         (Pred : Pred (ir) -> Pred ())
         (Tail : Tail (ir) -> Tail ())
@@ -17172,7 +17958,8 @@
                                (let* ([kunspillable (length unspillable*)] [unvarvec (make-vector kunspillable)])
                                  ; set up var indices & unvarvec mapping from indices to unspillables
                                  (fold-left (lambda (i x) (var-index-set! x i) (vector-set! unvarvec i x) (fx+ i 1)) 0 unspillable*)
-                                 ; rerun intra-block live analysis and record (reg v spillable v unspillable) x unspillable conflicts
+                                 ; select-instrcutions! kept intra-block live analysis up-to-date, so now
+                                 ; record (reg v spillable v unspillable) x unspillable conflicts
                                  (RApass unparse-L15d do-unspillable-conflict! kfv kspillable varvec live-size kunspillable unvarvec block*)
                                  #;(show-conflicts (info-lambda-name info) varvec unvarvec)
                                  (RApass unparse-L15d assign-registers! info varvec unvarvec)
@@ -17379,6 +18166,7 @@
                     ir
                     ((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-place-overflow-and-trap unparse-L9.5)
               (pass np-rebind-on-ruined-path unparse-L9.5)
diff --git a/src/ChezScheme/s/cprep.ss b/src/ChezScheme/s/cprep.ss
index 2f610e1896..e8e969f12a 100644
--- a/src/ChezScheme/s/cprep.ss
+++ b/src/ChezScheme/s/cprep.ss
@@ -93,6 +93,7 @@
                       [(i3nt-stdcall) '__stdcall]
                       [(i3nt-com) '__com]
                       [(adjust-active) '__collect_safe]
+                      [(varargs) '__varargs]
                       [else #f]))
                   x*)))
          (define-who uncprep-fp-specifier
diff --git a/src/ChezScheme/s/ftype.ss b/src/ChezScheme/s/ftype.ss
index 3f4e3d0aa1..ce9ab7108b 100644
--- a/src/ChezScheme/s/ftype.ss
+++ b/src/ChezScheme/s/ftype.ss
@@ -122,7 +122,7 @@ notes:
     big-endian machines, the first field occupies the high-order bits,
     with each subsequent field just below the preceding field.
 
-  - ftype pointers are records encapsulating an ftype descriptor
+  - ftyp<e pointers are records encapsulating an ftype descriptor
     (ftd) along with the address of the foreign object, except that
     pointers of type void* are just addresses.  the encapsulated
     ftd is used to verify the applicability of an ftype-&ref,
@@ -957,6 +957,12 @@ ftype operators:
       (or (ftd-struct? x)
           (ftd-union? x)
           (ftd-array? x))))
+  (set! $ftd-unsigned?
+    (lambda (x)
+      (and (ftd-base? x)
+           (case (ftd-base-type x)
+             [(unsigned-8 unsigned-16 unsigned-32 unsigned-64) #t]
+             [else #f]))))
   (set! $ftd->members
     (lambda (x)
       ;; Currently used for x86_64 and arm32 ABI: Returns a list of
diff --git a/src/ChezScheme/s/i3fb.def b/src/ChezScheme/s/i3fb.def
index 5f1593d4b6..a7ea2d5629 100644
--- a/src/ChezScheme/s/i3fb.def
+++ b/src/ChezScheme/s/i3fb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/i3le.def b/src/ChezScheme/s/i3le.def
index faf7eac137..98ffafb924 100644
--- a/src/ChezScheme/s/i3le.def
+++ b/src/ChezScheme/s/i3le.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/i3nb.def b/src/ChezScheme/s/i3nb.def
index 7878f9239d..e464c9f919 100644
--- a/src/ChezScheme/s/i3nb.def
+++ b/src/ChezScheme/s/i3nb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/i3nt.def b/src/ChezScheme/s/i3nt.def
index 9bb96f4d53..4efbd53764 100644
--- a/src/ChezScheme/s/i3nt.def
+++ b/src/ChezScheme/s/i3nt.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/i3ob.def b/src/ChezScheme/s/i3ob.def
index ed01492a8a..7a8879ed36 100644
--- a/src/ChezScheme/s/i3ob.def
+++ b/src/ChezScheme/s/i3ob.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/i3osx.def b/src/ChezScheme/s/i3osx.def
index f44d51c4b7..02ecd7bf03 100644
--- a/src/ChezScheme/s/i3osx.def
+++ b/src/ChezScheme/s/i3osx.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/i3qnx.def b/src/ChezScheme/s/i3qnx.def
index 5da2c7fb15..a0b291de2e 100644
--- a/src/ChezScheme/s/i3qnx.def
+++ b/src/ChezScheme/s/i3qnx.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/i3s2.def b/src/ChezScheme/s/i3s2.def
index 544e308685..a8f39705df 100644
--- a/src/ChezScheme/s/i3s2.def
+++ b/src/ChezScheme/s/i3s2.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/inspect.ss b/src/ChezScheme/s/inspect.ss
index ebf0ad714f..1bd56e3fd8 100644
--- a/src/ChezScheme/s/inspect.ss
+++ b/src/ChezScheme/s/inspect.ss
@@ -2281,8 +2281,12 @@
                                (values (make-vector count) count cp))
                            (let ([obj (vector-ref vals i)] [var* (vector-ref vars i)])
                              (cond
-                               [(eq? obj cookie)
-                                (unless (null? var*) ($oops who "expected value for ~s but it was not in lpm" (car var*)))
+                               [(and (eq? obj cookie)
+                                     (or (null? var*)
+                                         ;; unboxed variable?
+                                         (not (and (pair? var*) (box? (car var*)) (null? (cdr var*))))))
+                                (unless (null? var*)
+                                  ($oops who "expected value for ~s but it was not in lpm" (car var*)))
                                 (f (fx1+ i) count cp cpvar*)]
                                [(null? var*)
                                 (let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)])
@@ -2310,7 +2314,12 @@
                                                                           (vector->list var)))]
                                                [else
                                                  (let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)])
-                                                   (vector-set! v count (make-variable-object obj var))
+                                                   (vector-set! v count (cond
+                                                                          [(box? var)
+                                                                           ;; unboxed variable
+                                                                           (make-variable-object '<unboxed-flonum> (unbox var))]
+                                                                          [else
+                                                                           (make-variable-object obj var)]))
                                                    (values v frame-count cp))])))))]))))
                      (lambda (v frame-count cp)
                        (real-make-continuation-object x (rp-info-src rpi) (rp-info-sexpr rpi) cp v frame-count pos))))))]
diff --git a/src/ChezScheme/s/library.ss b/src/ChezScheme/s/library.ss
index 33f967e43e..bddad668a8 100644
--- a/src/ChezScheme/s/library.ss
+++ b/src/ChezScheme/s/library.ss
@@ -303,6 +303,11 @@
   (define index-oops
     (lambda (who x i)
       ($oops who "~s is not a valid index for ~s" i x)))
+  (define bytevector-index-oops
+    ;; for consistency with error before library entry was introduced:
+    (lambda (who x i)
+      ($oops who "invalid index ~s for bytevector ~s" i x)))
+
   (define stencil-vector-oops
     (lambda (who x)
       ($oops who "~s is not a vector" x)))
@@ -400,6 +405,16 @@
   (define-library-entry (stencil-vector-mask v)
     (stencil-vector-oops 'stencil-vector-mask v))
 
+  (define-library-entry (bytevector-ieee-double-native-ref v i)
+    (if (bytevector? v)
+        (bytevector-index-oops 'bytevector-ieee-double-native-ref v i)
+        (bytevector-oops 'bytevector-ieee-double-native-ref v)))
+
+  (define-library-entry (bytevector-ieee-double-native-set! v i)
+    (if (mutable-bytevector? v)
+        (bytevector-index-oops 'bytevector-ieee-double-native-set! v i)
+        (mutable-bytevector-oops 'bytevector-ieee-double-native-set! v)))
+
   (define-library-entry (char=? x y) (char-oops 'char=? (if (char? x) y x)))
   (define-library-entry (char<? x y) (char-oops 'char<? (if (char? x) y x)))
   (define-library-entry (char>? x y) (char-oops 'char>? (if (char? x) y x)))
@@ -523,6 +538,7 @@
 (define-library-entry (fxxor x y) (fxnonfixnum2 'fxxor x y))
 (define-library-entry (fxand x y) (fxnonfixnum2 'fxand x y))
 (define-library-entry (fxnot x) (fxnonfixnum1 'fxnot x))
+(define-library-entry (fixnum->flonum x) (fxnonfixnum1 'fixnum->flonum x))
 (define-library-entry (fxpopcount x) ($oops 'fxpopcount32 "~s is not a non-negative fixnum" x))
 (define-library-entry (fxpopcount32 x) ($oops 'fxpopcount32 "~s is not a 32-bit fixnum" x))
 (define-library-entry (fxpopcount16 x) ($oops 'fxpopcount16 "~s is not a 16-bit fixnum" x))
@@ -658,8 +674,32 @@
   (define-library-entry (fl* x y) (flonum-oops 'fl* (if (flonum? x) y x)))
   (define-library-entry (fl/ x y) (flonum-oops 'fl/ (if (flonum? x) y x)))
   (define-library-entry (flnegate x) (flonum-oops 'fl- x))
+  (define-library-entry (flabs x) (flonum-oops 'flabs x))
+
+  (define-library-entry (flsqrt x) (flonum-oops 'flsqrt x))
+  (define-library-entry (flround x) (flonum-oops 'flround x))
+  (define-library-entry (flfloor x) (flonum-oops 'flfloor x))
+  (define-library-entry (flceiling x) (flonum-oops 'flceiling x))
+  (define-library-entry (fltruncate x) (flonum-oops 'fltruncate x))
+  (define-library-entry (flsin x) (flonum-oops 'flsin x))
+  (define-library-entry (flcos x) (flonum-oops 'flcos x))
+  (define-library-entry (fltan x) (flonum-oops 'fltan x))
+  (define-library-entry (flasin x) (flonum-oops 'flasin x))
+  (define-library-entry (flacos x) (flonum-oops 'flacos x))
+  (define-library-entry (flatan x) (flonum-oops 'flatan x))
+  (define-library-entry (flatan2 x y) (flonum-oops 'flatan (if (flonum? x) y x)))
+  (define-library-entry (flexp x) (flonum-oops 'flexp x))
+  (define-library-entry (fllog x) (flonum-oops 'fllog x))
+  (define-library-entry (fllog2 x y) (flonum-oops 'fllog (if (flonum? x) y x)))
+  (define-library-entry (flexpt x y) (flonum-oops 'flexpt (if (flonum? x) y x)))
+
+  (define-library-entry (flonum->fixnum x) (if (flonum? x)
+                                               ($oops 'flonum->fixnum "result for ~s would be outside of fixnum range" x)
+                                               (flonum-oops 'flonum->fixnum x)))
 )
 
+;; Now using `rint` via a C entry
+#;
 (define-library-entry (flround x)
  ; assumes round-to-nearest-or-even
   (float-type-case
diff --git a/src/ChezScheme/s/mathprims.ss b/src/ChezScheme/s/mathprims.ss
index 41d0e80805..381f807469 100644
--- a/src/ChezScheme/s/mathprims.ss
+++ b/src/ChezScheme/s/mathprims.ss
@@ -272,8 +272,7 @@
 
    (set! flabs
       (lambda (x)
-         (unless (flonum? x) (flargerr 'flabs x))
-         (#3%flabs x)))
+         (#2%flabs x)))
 
    (set! flround
       (lambda (x)
@@ -318,13 +317,8 @@
          ($flonum-sign x)))
 
    (set-who! flonum->fixnum
-      (let ([flmnf (fixnum->flonum (most-negative-fixnum))]
-            [flmpf (fixnum->flonum (most-positive-fixnum))])
-         (lambda (x)
-            (unless (flonum? x) (flargerr who x))
-            (unless (fl<= flmnf x flmpf)
-               ($oops who "result for ~s would be outside of fixnum range" x))
-            (#3%flonum->fixnum x))))
+     (lambda (x)
+       (#2%flonum->fixnum x)))
 )
 
 (let ()
@@ -682,8 +676,7 @@
 
    (set! fixnum->flonum
       (lambda (x)
-         (unless (fixnum? x) (fxargerr 'fixnum->flonum x))
-         (#3%fixnum->flonum x)))
+         (#2%fixnum->flonum x)))
 
    (set-who! fxlength
      (lambda (x)
diff --git a/src/ChezScheme/s/mkgc.ss b/src/ChezScheme/s/mkgc.ss
index de6065b8e3..a30a2da9eb 100644
--- a/src/ChezScheme/s/mkgc.ss
+++ b/src/ChezScheme/s/mkgc.ss
@@ -18,6 +18,7 @@
 ;; Currently supported traversal modes:
 ;;   - copy
 ;;   - sweep
+;;   - mark
 ;;   - self-test   : check immediate pointers only for self references
 ;;   - size        : immediate size, so does not recur
 ;;   - measure     : recurs for reachable size
@@ -67,11 +68,19 @@
 ;; this order (but there are exceptions to the order):
 ;;  - (space <space>) : target for copy; works as a constraint for other modes
 ;;  - (vspace <vspace>) : target for vfasl
-;;  - (size <size> [<scale>]) : size for copy
+;;  - (size <size> [<scale>]) : size for copy; skips rest in size mode
+;;  - (mark <flag>) : in mark mode, skips rest except counting;
+;;      possible <flags>:
+;;       * one-bit : record as one bit per segment; inferred when size matches
+;;                   alignment or for `space-data`
+;;       * within-segment : alloacted within on segment; can be inferred from size
+;;       * no-sweep : no need to sweep content (perhaps covered by `trace-now`);
+;;                    inferred for `space-data`
+;;       * counting-root : check a counting root before pushing to sweep stack
 ;;  - (trace <field>) : relocate for sweep, copy for copy, recur otherwise
-;;  - (trace-early <field>) : relocate for sweep or copy, recur otherwise
+;;  - (trace-early <field>) : relocate for sweep, copy, and mark; recur otherwise
 ;;  - (trace-now <field>) : direct recur
-;;  - (trace-early-rtd <field>) : for record types, avoid recur on #!base-rtd
+;;  - (trace-early-rtd <field>) : for record types, avoids recur on #!base-rtd
 ;;  - (trace-ptrs <field> <count>) : trace an array of pointerrs
 ;;  - (copy <field>) : copy for copy, ignore otherwise
 ;;  - (copy-bytes <field> <count>) : copy an array of bytes
@@ -79,9 +88,12 @@
 ;;  - (copy-flonum* <field>) : copy potentially forwaded flonum
 ;;  - (copy-type <field>) : copy type from `_` to `_copy_`
 ;;  - (count <counter> [<size> [<scale> [<modes>]]]) :
-;;       : uses preceding `size` declaration unless <size>;
-;;         normally counts in copy mode, but <modes> can override
+;;       uses preceding `size` declaration unless <size>;
+;;       normally counts in copy mode, but <modes> can override
+;;  - (as-mark-end <statment> ...) : declares that <statement>s implement counting,
+;;       which means that it's included for mark mode
 ;;  - (skip-forwarding) : disable forward-pointer installation in copy mode
+;;  - (assert <expr>) : assertion
 ;;
 ;; In the above declarations, nonterminals like <space> can be
 ;; an identifier or a Parenthe-C expression. The meaning of a plain
@@ -134,6 +146,7 @@
 ;;  - _                 : object being copied, swept, etc.
 ;;  - _copy_            : target in copy or vfasl mode, same as _ otherwise
 ;;  - _tf_              : type word
+;;  - _tg_              : target generation
 ;;  - _backreferences?_ : dynamic flag indicating whether backreferences are on
 ;;
 ;; Stylistically, prefer constants and fields using the hyphenated
@@ -151,7 +164,14 @@
       (size size-ephemeron)
       (copy pair-car)
       (copy pair-cdr)
+      (case-mode
+       [(copy)
+        (set! (ephemeron-prev-ref _copy_) NULL)
+        (set! (ephemeron-next _copy_) NULL)]
+       [else])
       (add-ephemeron-to-pending)
+      (mark one-bit no-sweep)
+      (assert-ephemeron-size-ok)
       (count countof-ephemeron)]
      [space-weakpair
       (space space-weakpair)
@@ -170,14 +190,16 @@
     (define code : ptr (CLOSCODE _))
     (trace-code-early code)
     (cond
-      [(or-assume-continuation
-        (& (code-type code) (<< code-flag-continuation code-flags-offset)))
+      [(and-not-as-dirty
+        (or-assume-continuation
+         (& (code-type code) (<< code-flag-continuation code-flags-offset))))
        ;; continuation
        (space (cond
                 [(and-counts (is_counting_root si _)) space-count-pure]
                 [else space-continuation]))
        (vfasl-fail "closure")
        (size size-continuation)
+       (mark one-bit counting-root)
        (case-mode
         [self-test]
         [else
@@ -206,8 +228,8 @@
               (define stack : uptr (cast uptr (continuation-stack _)))
               (trace-stack stack
                            (+ stack (continuation-stack-clength _))
-                           (cast uptr (continuation-return-address _)))])])
-         (count countof-continuation)])]
+                           (cast uptr (continuation-return-address _)))])])])
+       (count countof-continuation)]
 
       [else
        ;; closure (not a continuation)
@@ -228,8 +250,18 @@
           (vfasl-fail "mutable closure")))
        (define len : uptr (code-closure-length code))
        (size (size_closure len))
-       (copy-clos-code code)
-       (trace-ptrs closure-data len)
+       (when-mark
+        (case-space
+         [space-pure
+          (mark one-bit counting-root)
+          (count countof-closure)]
+         [else
+          (mark counting-root)
+          (count countof-closure)]))
+       (when (or-not-as-dirty
+              (& (code-type code) (<< code-flag-mutable-closure code-flags-offset)))
+         (copy-clos-code code)
+         (trace-ptrs closure-data len))
        (pad (when (== (& len 1) 0)
               (set! (closure-data _copy_ len) (FIX 0))))
        (count countof-closure)])]
@@ -238,6 +270,7 @@
     (space space-symbol)
     (vspace vspace_symbol)
     (size size-symbol)
+    (mark one-bit)
     (trace/define symbol-value val :vfasl-as (FIX (vfasl_symbol_to_index vfi _)))
     (trace-symcode symbol-pvalue val)
     (trace-nonself/vfasl-as-nil symbol-plist)
@@ -250,6 +283,7 @@
     (space space-data)
     (vspace vspace_data)
     (size size-flonum)
+    (mark)
     (copy-flonum flonum-data)
     (count countof-flonum)
     (skip-forwarding)]
@@ -307,6 +341,7 @@
       (vfasl-check-parent-rtd rtd)
       (define len : uptr (UNFIX (record-type-size rtd)))
       (size (size_record_inst len))
+      (mark counting-root)
       (trace-record rtd len)
       (vfasl-set-base-rtd)
       (pad (when (or-vfasl
@@ -334,6 +369,7 @@
       (vspace vspace_impure)
       (define len : uptr (Svector_length _))
       (size (size_vector len))
+      (mark)
       (copy-type vector-type)
       (trace-ptrs vector-data len)
       (pad (when (== (& len 1) 0)
@@ -350,6 +386,8 @@
       (vspace vspace_impure)
       (define len : uptr (Sstencil_vector_length _))
       (size (size_stencil_vector len))
+      (mark within-segment) ; see assertion
+      (assert-stencil-vector-size)
       (copy-type stencil-vector-type)
       (trace-ptrs stencil-vector-data len)
       (pad (when (== (& len 1) 0)
@@ -361,6 +399,7 @@
       (vspace vspace_data)
       (define sz : uptr (size_string (Sstring_length _)))
       (size (just sz))
+      (mark)
       (copy-bytes string-type sz)
       (count countof-string)]
 
@@ -369,6 +408,7 @@
       (vspace vspace_data)
       (define sz : uptr (size_fxvector (Sfxvector_length _)))
       (size (just sz))
+      (mark)
       (copy-bytes fxvector-type sz)
       (count countof-fxvector)]
 
@@ -377,6 +417,7 @@
       (vspace vspace_data)
       (define sz : uptr (size_bytevector (Sbytevector_length _)))
       (size (just sz))
+      (mark)
       (copy-bytes bytevector-type sz)
       (count countof-bytevector)]
 
@@ -387,10 +428,12 @@
         [else space-impure]))
       (vfasl-fail "tlc")
       (size size-tlc)
+      (mark)
       (copy-type tlc-type)
       (trace-nonself tlc-ht)
-      (trace-tlc tlc-next tlc-keyval)
-      (count countof-tlc)]
+      (as-mark-end
+       (trace-tlc tlc-next tlc-keyval)
+       (count countof-tlc))]
 
      [box
       (space
@@ -405,6 +448,7 @@
             [else space-impure])]))
       (vspace vspace_impure)
       (size size-box)
+      (mark)
       (copy-type box-type)
       (trace box-ref)
       (count countof-box)]
@@ -414,8 +458,9 @@
       (vspace vspace_impure) ; would be better if we had pure, but these are rare
       (size size-ratnum)
       (copy-type ratnum-type)
-      (trace-now ratnum-numerator)
-      (trace-now ratnum-denominator)
+      (trace-immutable-now ratnum-numerator)
+      (trace-immutable-now ratnum-denominator)
+      (mark)
       (vfasl-pad-word)
       (count countof-ratnum)]
 
@@ -424,8 +469,9 @@
       (vspace vspace_impure) ; same rationale as ratnum
       (size size-exactnum)
       (copy-type exactnum-type)
-      (trace-now exactnum-real)
-      (trace-now exactnum-imag)
+      (trace-immutable-now exactnum-real)
+      (trace-immutable-now exactnum-imag)
+      (mark)
       (vfasl-pad-word)
       (count countof-exactnum)]
 
@@ -433,6 +479,7 @@
       (space space-data)
       (vspace vspace_data)
       (size size-inexactnum)
+      (mark)
       (copy-type inexactnum-type)
       (copy-flonum* inexactnum-real)
       (copy-flonum* inexactnum-imag)
@@ -443,6 +490,7 @@
       (vspace vspace_data)
       (define sz : uptr (size_bignum (BIGLEN _)))
       (size (just sz))
+      (mark)
       (copy-bytes bignum-type sz)
       (count countof-bignum)]
 
@@ -450,6 +498,7 @@
       (space space-port)
       (vfasl-fail "port")
       (size size-port)
+      (mark one-bit)
       (copy-type port-type)
       (trace-nonself port-handler)
       (copy port-ocount)
@@ -465,15 +514,17 @@
       (vspace vspace_code)
       (define len : uptr (code-length _)) ; in bytes
       (size (size_code len))
-      (copy-type code-type)
-      (copy code-length)
-      (copy code-reloc)
-      (trace-nonself code-name)
-      (trace-nonself code-arity-mask)
-      (copy code-closure-length)
-      (trace-nonself code-info)
-      (trace-nonself code-pinfo*)
-      (trace-code len)
+      (mark one-bit)
+      (when (and-not-as-dirty 1)
+       (copy-type code-type)
+       (copy code-length)
+       (copy code-reloc)
+       (trace-nonself code-name)
+       (trace-nonself code-arity-mask)
+       (copy code-closure-length)
+       (trace-nonself code-info)
+       (trace-nonself code-pinfo*)
+       (trace-code len))
       (count countof-code)]
 
      [thread
@@ -482,17 +533,20 @@
                [else space-pure-typed-object]))
       (vfasl-fail "thread")
       (size size-thread)
+      (mark one-bit)
       (case-mode
        [self-test]
        [else
         (copy-type thread-type)
-        (trace-tc thread-tc)
-        (count countof-thread)])]
+        (when (and-not-as-dirty 1)
+          (trace-tc thread-tc))])
+      (count countof-thread)]
 
      [rtd-counts
       (space space-data)
       (vfasl-as-false "rtd-counts") ; prune counts, since GC will recreate as needed
       (size size-rtd-counts)
+      (mark)
       (copy-bytes rtd-counts-type size_rtd_counts)
       (count countof-rtd-counts)]
 
@@ -500,12 +554,18 @@
       (space space-data)
       (vfasl-fail "phantom")
       (size size-phantom)
+      (mark)
       (copy-type phantom-type)
       (copy phantom-length)
       (case-mode
-       [copy (set! (array-ref S_G.phantom_sizes tg)
-                   +=
-                   (phantom-length _))]
+       [(copy mark)
+        (as-mark-end
+         (count countof-phantom)
+         ;; Separate from `count`, because we want to track sizes even
+         ;; if counting is not enabled:
+         (set! (array-ref (array-ref S_G.bytesof _tg_) countof-phantom)
+               +=
+               (phantom-length _)))]
        [measure (set! measure_total += (phantom-length _))]
        [else])])]))
 
@@ -534,9 +594,13 @@
       [(&& (!= cdr_p _)
            (&& (== (TYPEBITS cdr_p) type_pair)
                (&& (!= (set! qsi (MaybeSegInfo (ptr_get_segment cdr_p))) NULL)
-                   (&& (== (-> qsi space) (-> si space))
-                       (&& (!= (FWDMARKER cdr_p) forward_marker)
-                           (! (locked qsi cdr_p)))))))
+                   (&& (-> qsi old_space)
+                       (&& (== (-> qsi space) (-> si space))
+                           (&& (!= (FWDMARKER cdr_p) forward_marker)
+                               (&& (! (-> qsi use_marks))
+                                   ;; Checking `marked_mask`, too, in
+                                   ;; case the pair is locked
+                                   (! (-> qsi marked_mask)))))))))
        (check_triggers qsi)
        (size size-pair 2)
        (define new_cdr_p : ptr (cast ptr (+ (cast uptr _copy_) size_pair)))
@@ -556,19 +620,36 @@
        (do-cdr pair-cdr)
        (count count-pair)])]
    [else
-    (size size-pair) 
+    (size size-pair)
+    (mark)
+    (assert (= (constant size-pair) (constant byte-alignment)))
     (do-car pair-car)
     (do-cdr pair-cdr)
     (count count-pair)]))
 
 (define-trace-macro (add-ephemeron-to-pending)
   (case-mode
-   [sweep
+   [(sweep mark)
     (add_ephemeron_to_pending _)]
    [measure
     (add_ephemeron_to_pending_measure _)]
    [else]))
 
+(define-trace-macro (assert-ephemeron-size-ok)
+  ;; needed for dirty sweep strategy:
+  (assert (zero? (modulo (constant bytes-per-card) (constant size-ephemeron)))))
+
+(define-trace-macro (assert-stencil-vector-size)
+  ;; needed for within-mark-byte
+  (assert (< (+ (* (constant stencil-vector-mask-bits) (constant ptr-bytes))
+                (constant header-size-stencil-vector)
+                (constant byte-alignment))
+             (constant bytes-per-segment))))
+
+(define-trace-macro (trace-immutable-now ref)
+  (when (and-not-as-dirty 1)
+    (trace-now ref)))
+
 (define-trace-macro (trace-code-early code)
   (unless-code-relocated
    (case-mode
@@ -634,17 +715,20 @@
 
 (define-trace-macro (trace-tlc tlc-next tlc-keyval)
   (case-mode
-   [copy
+   [(copy mark)
     (define next : ptr (tlc-next _))
     (define keyval : ptr (tlc-keyval _))
-    (set! (tlc-next _copy_) next)
-    (set! (tlc-keyval _copy_) keyval)
+    (case-mode
+     [copy
+      (set! (tlc-next _copy_) next)
+      (set! (tlc-keyval _copy_) keyval)]
+     [else])
     ;; If next isn't false and keyval is old, add tlc to a list of tlcs
     ;; to process later. Determining if keyval is old is a (conservative)
     ;; approximation to determining if key is old. We can't easily
     ;; determine if key is old, since keyval might or might not have been
     ;; swept already. NB: assuming keyvals are always pairs.
-    (when (&& (!= next Sfalse) (& (SPACE keyval) space_old))
+    (when (&& (!= next Sfalse) (OLDSPACE keyval))
       (set! tlcs_to_rehash (S_cons_in space_new 0 _copy_ tlcs_to_rehash)))]
    [else
     (trace-nonself tlc-keyval)
@@ -743,41 +827,51 @@
 
 (define-trace-macro (count-record rtd)
   (case-mode
-   [copy
-    (case-flag counts?
-     [on
-      (let* ([c_rtd : ptr (cond
-                            [(== _tf_ _) _copy_]
-                            [else rtd])]
-             [counts : ptr (record-type-counts c_rtd)])
-        (cond
-          [(== counts Sfalse)
-           (let* ([grtd : IGEN (GENERATION c_rtd)])
-             (set! (array-ref (array-ref S_G.countof grtd) countof_rtd_counts) += 1)
-             ;; Allocate counts struct in same generation as rtd. Initialize timestamp & counts.
-             (find_room space_data grtd type_typed_object size_rtd_counts counts)
-             (set! (rtd-counts-type counts) type_rtd_counts)
-             (set! (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
-             (let* ([g : IGEN 0])
-               (while
-                :? (<= g static_generation)
-                (set! (rtd-counts-data counts g) 0)
-                (set! g += 1)))
-             (set! (record-type-counts c_rtd) counts)
-             (set! (array-ref S_G.rtds_with_counts grtd)
-                   (S_cons_in (cond [(== grtd 0) space_new] [else space_impure]) grtd c_rtd
-                              (array-ref S_G.rtds_with_counts grtd)))
-             (set! (array-ref (array-ref S_G.countof grtd) countof_pair) += 1))]
-          [else
-           (trace-early (just counts))
-           (set! (record-type-counts c_rtd) counts)
-           (when (!= (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
-             (S_fixup_counts counts))])
-        (set! (rtd-counts-data counts tg) (+ (rtd-counts-data counts tg) 1))
-        ;; Copies size that we've already gathered, but needed for counting from roots:
-        (when (== p_spc space-count-impure) (set! count_root_bytes += p_sz))
-        (count countof-record))]
-     [off])]
+   [(copy mark)
+    (as-mark-end
+     (case-flag counts?
+      [on
+       (when S_G.enable_object_counts
+         (let* ([c_rtd : ptr (cond
+                               [(== _tf_ _) _copy_]
+                               [else rtd])]
+                [counts : ptr (record-type-counts c_rtd)])
+           (cond
+             [(== counts Sfalse)
+              (let* ([grtd : IGEN (GENERATION c_rtd)])
+                (set! (array-ref (array-ref S_G.countof grtd) countof_rtd_counts) += 1)
+                ;; Allocate counts struct in same generation as rtd. Initialize timestamp & counts.
+                (find_room space_data grtd type_typed_object size_rtd_counts counts)
+                (set! (rtd-counts-type counts) type_rtd_counts)
+                (set! (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
+                (let* ([g : IGEN 0])
+                  (while
+                   :? (<= g static_generation)
+                   (set! (rtd-counts-data counts g) 0)
+                   (set! g += 1)))
+                (set! (record-type-counts c_rtd) counts)
+                (set! (array-ref S_G.rtds_with_counts grtd)
+                      ;; For max_copied_generation, the list will get copied again in `rtds_with_counts` fixup;
+                      ;; meanwhile, allocating in `space_impure` would copy and sweep old list entries causing
+                      ;; otherwise inaccessible rtds to be retained
+                      (S_cons_in (cond [(<= grtd max_copied_generation) space_new] [else space_impure])
+                                 (cond [(<= grtd max_copied_generation) 0] [else grtd])
+                                 c_rtd
+                                 (array-ref S_G.rtds_with_counts grtd)))
+                (set! (array-ref (array-ref S_G.countof grtd) countof_pair) += 1))]
+             [else
+              (trace-early (just counts))
+              (set! (record-type-counts c_rtd) counts)
+              (when (!= (rtd-counts-timestamp counts) (array-ref S_G.gctimestamp 0))
+                (S_fixup_counts counts))])
+           (set! (rtd-counts-data counts _tg_) (+ (rtd-counts-data counts _tg_) 1))))
+       ;; Copies size that we may have already gathered, but needed for counting from roots:
+       (case-mode
+        [(copy)
+         (when (== p_spc space-count-impure) (set! count_root_bytes += p_sz))]
+        [else])
+       (count countof-record)]
+      [off]))]
    [else]))
 
 (define-trace-macro (trace-buffer flag port-buffer port-last)
@@ -831,11 +925,14 @@
       (trace-stack (cast uptr (tc-scheme-stack tc))
                    (cast uptr (SFP tc))
                    (cast uptr (FRAME tc 0)))
-      (trace (tc-U tc))
-      (trace (tc-V tc))
-      (trace (tc-W tc))
-      (trace (tc-X tc))
-      (trace (tc-Y tc))
+      (case-mode
+       [(sweep)
+        (set! (tc-U tc) 0)
+        (set! (tc-V tc) 0)
+        (set! (tc-W tc) 0)
+        (set! (tc-X tc) 0)
+        (set! (tc-Y tc) 0)]
+       [else])
       (trace (tc-threadno tc))
       (trace (tc-current-input tc))
       (trace (tc-current-output tc))
@@ -909,27 +1006,17 @@
     (copy copy-field)]
    [else
     (define xcp : ptr field)
-    (case-mode
-     [sweep
-      (define x_si : seginfo* (SegInfo (ptr_get_segment xcp)))
-      (when (& (-> x_si space) space_old)
-        (trace-return-code field xcp x_si))]
-     [else
-      (trace-return-code field xcp no_x_si)])]))
+    (trace-return-code field xcp)]))
 
-(define-trace-macro (trace-return-code field xcp x_si)
+(define-trace-macro (trace-return-code field xcp)
   (define co : iptr (+ (ENTRYOFFSET xcp) (- (cast uptr xcp) (cast uptr (ENTRYOFFSETADDR xcp)))))
-  ;; In the call to copy below, assuming SPACE(c_p) == SPACE(xcp) since
-  ;; c_p and XCP point to/into the same object
   (define c_p : ptr (cast ptr (- (cast uptr xcp) co)))
   (case-mode
    [sweep
-    (cond
-      [(== (FWDMARKER c_p) forward_marker)
-       (set! c_p (FWDADDRESS c_p))]
-      [else
-       (set! c_p (copy c_p x_si))])
-    (set! field (cast ptr (+ (cast uptr c_p) co)))]
+    (define x_si : seginfo* (SegInfo (ptr_get_segment c_p)))
+    (when (-> x_si old_space)
+      (relocate_code c_p x_si)
+      (set! field (cast ptr (+ (cast uptr c_p) co))))]
    [else
     (trace (just c_p))]))
 
@@ -985,7 +1072,7 @@
           [sweep
            (S_set_code_obj "gc" (RELOC_TYPE entry) _ a obj item_off)]
           [vfasl-sweep
-           (S_set_code_obj "vfasl" (abs-for-vfasl (RELOC_TYPE entry)) _ a obj item_off)]
+           (S_set_code_obj "vfasl" (abs_reloc_variant (RELOC_TYPE entry)) _ a obj item_off)]
           [else]))))
 
     (case-mode
@@ -996,15 +1083,18 @@
                  (== 0 (& (code-type _) (<< code_flag_template code_flags_offset)))))
          (set! (code-reloc _) (cast ptr 0))]
         [else
-         ;; Don't copy non-oldspace relocation tables, since we may be
-         ;; sweeping a locked code object that is older than target_generation.
-         ;; Doing so would be a waste of work anyway.
-         (when (OLDSPACE t)
-           (let* ([oldt : ptr t])
-             (set! n (size_reloc_table (reloc-table-size oldt)))
+         (let* ([t_si : seginfo* (SegInfo (ptr_get_segment t))])
+           (when (-> t_si old_space)
+             (set! n (size_reloc_table (reloc-table-size t)))
              (count countof-relocation-table (just n) 1 sweep)
-             (find_room space_data target_generation typemod n t)
-             (memcpy_aligned t oldt n)))
+             (cond
+               [(-> t_si use_marks)
+                ;; Assert: (! (marked t_si t))
+                (mark_typemod_data_object t n t_si)]
+               [else
+                (let* ([oldt : ptr t])
+                  (find_room space_data target_generation typemod n t)
+                  (memcpy_aligned t oldt n))])))
          (set! (reloc-table-code t) _)
          (set! (code-reloc _) t)])
       (S_record_code_mod tc_in (cast uptr (& (code-data _ 0))) (cast uptr (code-length _)))]
@@ -1017,7 +1107,10 @@
 (define-trace-macro (unless-code-relocated stmt)
   (case-flag code-relocated?
    [on]
-   [off stmt]))
+   [off
+    (case-flag as-dirty?
+     [on]
+     [off stmt])]))
 
 (define-trace-macro (or-assume-continuation e)
   (case-flag assume-continuation?
@@ -1029,6 +1122,16 @@
    [on e]
    [off 0]))
 
+(define-trace-macro (and-not-as-dirty e)
+  (case-flag as-dirty?
+   [on 0]
+   [off e]))
+
+(define-trace-macro (or-not-as-dirty e)
+  (case-flag as-dirty?
+   [on e]
+   [off 1]))
+
 (define-trace-macro (or-vfasl e)
   (case-mode
    [vfasl-copy 1]
@@ -1039,10 +1142,10 @@
    [(vfasl-copy vfasl-sweep) e]
    [else]))
 
-(define-trace-macro (abs-for-vfasl e)
+(define-trace-macro (when-mark e)
   (case-mode
-   [vfasl-sweep reloc_abs]
-   [else e]))
+   [(mark) e]
+   [else]))
 
 (define-trace-macro (pad e)
   (case-mode
@@ -1218,18 +1321,20 @@
                [(sweep) (if (lookup 'as-dirty? config #f)
                             "IGEN"
                             "void")]
+               [(mark) "void"]
                [else "void"])
              name
              (case (lookup 'mode config)
                [(sweep)
-                (if (type-included? 'code config)
+                (if (and (type-included? 'code config)
+                         (not (lookup 'as-dirty? config #f)))
                     "ptr tc_in, "
                     "")]
                [(vfasl-copy vfasl-sweep)
                 "vfasl_info *vfi, "]
                [else ""])
              (case (lookup 'mode config)
-               [(copy vfasl-copy) ", seginfo *si"]
+               [(copy mark vfasl-copy) ", seginfo *si"]
                [(sweep)
                 (if (lookup 'as-dirty? config #f)
                     ", IGEN tg, IGEN youngest"
@@ -1262,15 +1367,6 @@
        (case (lookup 'mode config)
          [(copy)
           (code-block
-           (cond
-             [(lookup 'counts? config #f)
-              (code
-               "if (!(si->space & space_old) || locked(si, p)) {"
-               "  if (measure_all_enabled) push_measure(p);"
-               "  return p;"
-               "}")]
-             [else
-              "if (locked(si, p)) return p;"])
            "change = 1;"
            "check_triggers(si);"
            (code-block
@@ -1282,6 +1378,13 @@
             (and (lookup 'maybe-backreferences? config #f)
                  "ADD_BACKREFERENCE(p)")
             "return new_p;"))]
+         [(mark)
+          (code-block
+           "change = 1;"
+           "check_triggers(si);"
+           (ensure-segment-mark-mask "si" "" '())
+           (body)
+           "ADD_BACKREFERENCE(p)")]
          [(sweep)
           (code-block
            (and (lookup 'maybe-backreferences? config #f)
@@ -1373,8 +1476,8 @@
              (code-block
               (format "ISPC p_at_spc = ~a;"
                       (case (lookup 'mode config)
-                        [(copy vfasl-copy) "si->space"]
-                        [else "SPACE(p) & ~(space_locked | space_old)"]))
+                        [(copy mark vfasl-copy) "si->space"]
+                        [else "SPACE(p)"]))
               (let loop ([all-clauses all-clauses] [else? #f])
                 (match all-clauses
                   [`([else . ,body])
@@ -1385,9 +1488,7 @@
                    (code
                     (format "~aif (p_at_spc == ~a)"
                             (if else? "else " "")
-                            (case (lookup 'mode config)
-                              [(copy) (format "(~a | space_old)" (as-c spc))]
-                              [else (as-c spc)]))
+                            (as-c spc))
                     (code-block (statements body config))
                     (loop rest #t))])))
              (statements (cdr l) config))]
@@ -1399,10 +1500,10 @@
                             off)])
               (statements (append body (cdr l)) config))]
            [`(trace-early-rtd ,field)
-            (code (case (and (not (lookup 'only-dirty? config #f))
+            (code (case (and (not (lookup 'as-dirty? config #f))
                              (not (lookup 'rtd-relocated? config #f))
                              (lookup 'mode config))
-                    [(copy sweep)
+                    [(copy sweep mark)
                      (code
                       "/* Relocate to make sure we aren't using an oldspace descriptor"
                       "   that has been overwritten by a forwarding marker, but don't loop"
@@ -1434,6 +1535,8 @@
                [(self-test) #f]
                [(measure vfasl-copy vfasl-sweep)
                 (statements (list `(trace ,field)) config)]
+               [(mark)
+                (relocate-statement (field-expression field config "p" #t) config)]
                [else
                 (trace-statement field config #f)])
              (statements (cdr l) config))]
@@ -1523,6 +1626,9 @@
                                    (cons `(constant-size? ,(symbol? size))
                                          config))
                   (statements (cdr l) config))]
+           [`(as-mark-end . ,stmts)
+            (statements (append stmts (cdr l))
+                        config)]
            [`(space ,s)
             (case (lookup 'mode config)
               [(copy)
@@ -1530,6 +1636,10 @@
                                   (expression s config #f #t)
                                   ";")
                      (statements (cdr l) (cons '(space-ready? #t) config)))]
+              [(mark)
+               (statements (cdr l) (if (symbol? s)
+                                       (cons `(known-space ,s) config)
+                                       config))]
               [else (statements (cdr l) config)])]
            [`(vspace ,s)
             (case (lookup 'mode config)
@@ -1554,59 +1664,75 @@
                              (case mode
                                [(sweep) 'sweep+size]
                                [else mode])
-                             mode)])
-              (code-block
-               (case mode
-                 [(copy sweep+size size measure vfasl-copy vfasl-sweep)
+                             mode)]
+                   [was-used? (let ([used? (hashtable-ref (lookup 'used config) 'p_sz #f)])
+                                (hashtable-set! (lookup 'used config) 'p_sz #f)
+                                used?)]
+                   [config (if (and (symbol? sz)
+                                    (eqv? scale 1))
+                               (cons `(known-size ,sz) config)
+                               config)]
+                   [config (if (symbol? sz)
+                               (cons '(constant-size? #t)
+                                     config)
+                               config)]
+                   [rest
+                    (case mode
+                      [(copy vfasl-copy)
+                       (case mode
+                         [(copy) (unless (lookup 'space-ready? config #f)
+                                   (error 'generate "size before space"))]
+                         [(vfasl-copy) (unless (lookup 'vspace-ready? config #f)
+                                         (error 'generate "size before vspace for ~a/~a"
+                                                (lookup 'basetype config)
+                                                (lookup 'type config #f)))])
+                       (hashtable-set! (lookup 'used config) 'p_sz #t)
+                       (code (format "~a, ~a, p_sz, new_p);"
+                                     (case mode
+                                       [(copy) "find_room(p_spc, tg"]
+                                       [(vfasl-copy) "FIND_ROOM(vfi, p_vspc"])
+                                     (as-c 'type (lookup 'basetype config)))
+                             (statements (let ([extra (lookup 'copy-extra config #f)])
+                                           (if extra
+                                               (cons `(copy ,extra) (cdr l))
+                                               (let* ([mode (lookup 'mode config)]
+                                                      [extra (and (memq mode '(copy vfasl-copy))
+                                                                  (lookup 'copy-extra-rtd config #f))])
+                                                 (if extra
+                                                     (cons `(set! (,extra _copy_)
+                                                                  ,(case mode
+                                                                     [(copy)
+                                                                      `(cond
+                                                                         [(== tf _) _copy_]
+                                                                         [else rtd])]
+                                                                     [else 'rtd]))
+                                                           (cdr l))
+                                                     (cdr l)))))
+                                         (cons '(copy-ready? #t)
+                                               config)))]
+                      [(size)
+                       (hashtable-set! (lookup 'used config) 'p_sz #t)
+                       (code "return p_sz;")]
+                      [(vfasl-sweep)
+                       (hashtable-set! (lookup 'used config) 'p_sz #t)
+                       (code "result_sz = p_sz;"
+                             (statements (cdr l) config))]
+                      [(measure)
+                       (hashtable-set! (lookup 'used config) 'p_sz #t)
+                       (code "measure_total += p_sz;"
+                             (statements (cdr l) config))]
+                      [else (statements (cdr l) config)])]
+                   [used? (hashtable-ref (lookup 'used config) 'p_sz #f)])
+              (hashtable-set! (lookup 'used config) 'p_sz was-used?)
+              (cond
+                [used?
+                 (code-block
                   (format "uptr p_sz = ~a;" (let ([s (size-expression sz config)])
                                               (if (= scale 1)
                                                   s
-                                                  (format "~a * (~a)" scale s))))]
-                 [else #f])
-               (case mode
-                 [(copy vfasl-copy)
-                  (case mode
-                    [(copy) (unless (lookup 'space-ready? config #f)
-                              (error 'generate "size before space"))]
-                    [(vfasl-copy) (unless (lookup 'vspace-ready? config #f)
-                                    (error 'generate "size before vspace for ~a/~a"
-                                           (lookup 'basetype config)
-                                           (lookup 'type config #f)))])
-                  (code (format "~a, ~a, p_sz, new_p);"
-                                (case mode
-                                  [(copy) "find_room(p_spc, tg"]
-                                  [(vfasl-copy) "FIND_ROOM(vfi, p_vspc"])
-                                (as-c 'type (lookup 'basetype config)))
-                        (statements (let ([extra (lookup 'copy-extra config #f)])
-                                      (if extra
-                                          (cons `(copy ,extra) (cdr l))
-                                          (let* ([mode (lookup 'mode config)]
-                                                 [extra (and (memq mode '(copy vfasl-copy))
-                                                             (lookup 'copy-extra-rtd config #f))])
-                                            (if extra
-                                                (cons `(set! (,extra _copy_)
-                                                             ,(case mode
-                                                                [(copy)
-                                                                 `(cond
-                                                                    [(== tf _) _copy_]
-                                                                    [else rtd])]
-                                                                [else 'rtd]))
-                                                      (cdr l))
-                                                (cdr l)))))
-                                    (cons '(copy-ready? #t)
-                                          (if (symbol? sz)
-                                              (cons '(constant-size? #t)
-                                                    config)
-                                              config))))]
-                 [(size)
-                  (code "return p_sz;")]
-                 [(vfasl-sweep)
-                  (code "result_sz = p_sz;"
-                        (statements (cdr l) config))]
-                 [(measure)
-                  (code "measure_total += p_sz;"
-                        (statements (cdr l) config))]
-                 [else (statements (cdr l) config)])))]
+                                                  (format "~a * (~a)" scale s))))
+                  rest)]
+                [else rest]))]
            [`(skip-forwarding)
             (case (lookup 'mode config)
               [(copy)
@@ -1615,6 +1741,35 @@
                (code "return new_p;")]
               [else
                (statements (cdr l) config)])]
+           [`(mark . ,flags)
+            (for-each (lambda (flag)
+                        (unless (memq flag '(one-bit no-sweep within-segment counting-root))
+                          (error 'mark "bad flag ~s" flag)))
+                      flags)
+            (case (lookup 'mode config)
+              [(mark)
+               (let* ([count-stmt (let loop ([l (cdr l)])
+                                   (cond
+                                     [(null? l) (error 'mark "could not find `count` or `as-mark-end` ~s" config)]
+                                     [else
+                                      (match (car l)
+                                        [`(count . ,rest) (car l)]
+                                        [`(as-mark-end . ,stmts) (car l)]
+                                        [`(case-mode . ,all-clauses)
+                                         (let ([body (find-matching-mode 'mark all-clauses)])
+                                           (loop (append body (cdr l))))]
+                                        [`(,id . ,args)
+                                         (let ([m (eq-hashtable-ref trace-macros id #f)])
+                                           (if m
+                                               (loop (append (apply-macro m args)
+                                                             (cdr l)))
+                                               (loop (cdr l))))]
+                                        [else (loop (cdr l))])]))])
+                 (code
+                  (mark-statement flags config)
+                  (statements (list count-stmt) config)))]
+              [else
+               (statements (cdr l) config)])]
            [`(define ,id : ,type ,rhs)
             (let* ([used (lookup 'used config)]
                    [prev-used? (hashtable-ref used id #f)])
@@ -1708,6 +1863,10 @@
                   (statements (cdr l) config))]
            [`(break)
             (code "break;")]
+           [`(assert ,expr)
+            (unless (eval expr)
+              (error 'assert "failed: ~s" expr))
+            (statements (cdr l) config)]
            [`(,id . ,args)
             (let ([m (eq-hashtable-ref trace-macros id #f)])
               (if m
@@ -1735,6 +1894,10 @@
                    [else "p"])]
         [`_tf_
          (lookup 'tf config "TYPEFIELD(p)")]
+        [`_tg_
+         (case (lookup 'mode config)
+           [(copy) "tg"]
+           [else "target_generation"])]
         [`_backreferences?_
          (if (lookup 'maybe-backreferences? config #f)
              "BACKREFERENCES_ENABLED"
@@ -1815,6 +1978,8 @@
                  (comma-ize (map (lambda (r) (expression r config)) rands)))]
         [else
          (cond
+           [(eq? a #f) "Sfalse"]
+           [(eq? a #t) "Strue"]
            [(symbol? a)
             (cond
               [(getprop a '*c-name* #f)
@@ -1851,7 +2016,8 @@
     (cond
       [(or (eq? mode 'sweep)
            (eq? mode 'vfasl-sweep)
-           (and early? (eq? mode 'copy)))
+           (and early? (or (eq? mode 'copy)
+                           (eq? mode 'mark))))
        (relocate-statement (field-expression field config "p" #t) config)]
       [(or (eq? mode 'copy)
            (eq? mode 'vfasl-copy))
@@ -1898,12 +2064,13 @@
       [else #f]))
 
   (define (count-statement counter size scale modes config)
-    (let ([mode (lookup 'mode config)])
+    (let* ([real-mode (lookup 'mode config)]
+           [mode (if (eq? real-mode 'mark) 'copy real-mode)])
       (cond
         [(or (eq? mode modes) (and (pair? modes) (memq mode modes)))
          (cond
            [(lookup 'counts? config #f)
-            (let ([tg (if (eq? mode 'copy)
+            (let ([tg (if (eq? real-mode 'copy)
                           "tg"
                           "target_generation")])
               (code
@@ -1915,13 +2082,122 @@
                            (as-c counter)
                            (let ([s (if size
                                         (expression size config)
-                                        "p_sz")])
+                                        (begin
+                                          (hashtable-set! (lookup 'used config) 'p_sz #t)
+                                          "p_sz"))])
                              (if (eqv? scale 1)
                                  s
                                  (format "~a * (~a)" scale s)))))))]
            [else #f])]
         [else #f])))
 
+  (define (mark-statement flags config)
+    (let* ([known-space (lookup 'known-space config #f)]
+           [sz (let ([sz (lookup 'known-size config #f)])
+                 (and sz (get-size-value sz)))]
+           [one-bit? (or (memq 'one-bit flags)
+                         (eq? 'space-data known-space)
+                         (eqv? sz (constant byte-alignment)))]
+           [within-segment? (or (memq 'within-segment flags)
+                                (and sz
+                                     (< sz (constant bytes-per-segment))))]
+           [no-sweep? (or (memq 'no-sweep flags)
+                          (eq? known-space 'space-data))]
+           [within-loop-statement
+            (lambda (decl si step count?)
+              (code-block
+               "uptr offset = 0;"
+               "while (offset < p_sz) {"
+               "  ptr mark_p = (ptr)((uptr)p + offset);"
+               decl
+               (format "  ~a->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p);" si)
+               (and count? (format "  ~a->marked_count += ~a;" si step))
+               (format "  offset += ~a;" step)
+               "}"))]
+           [type (let ([t (lookup 'basetype config)])
+                   (if (eq? t 'typemod)
+                       #f
+                       (as-c 'type (lookup 'basetype config))))]
+           [untype (lambda ()
+                     (if type
+                         (format "(uptr)UNTYPE(p, ~a)" type)
+                         (format "(uptr)p")))])
+      (hashtable-set! (lookup 'used config) 'p_sz #t)
+      (code
+       (cond
+         [one-bit?
+          (code
+           "si->marked_mask[segment_bitmap_byte(p)] |= segment_bitmap_bit(p);"
+           (cond
+             [within-segment?
+              "si->marked_count += p_sz;"]
+             [else
+              (code-block
+               (format "uptr addr = ~a;" (untype))
+               "uptr seg = addr_get_segment(addr);"
+               "uptr end_seg = addr_get_segment(addr + p_sz - 1);"
+               "if (seg == end_seg) {"
+               "  si->marked_count += p_sz;"
+               "} else {"
+               "  seginfo *mark_si;"
+               "  si->marked_count += ((uptr)build_ptr(seg+1,0)) - addr;"
+               "  seg++;"
+               "  while (seg < end_seg) {"
+               "    mark_si = SegInfo(seg);"
+               "    if (!fully_marked_mask) init_fully_marked_mask();"
+               "    mark_si->marked_mask = fully_marked_mask;"
+               "    mark_si->marked_count = segment_bitmap_bytes;"
+               "    seg++;"
+               "  }"
+               "  mark_si = SegInfo(end_seg);"
+               (ensure-segment-mark-mask "mark_si" "  " '())
+               "    /* no need to set a bit: just make sure `marked_mask` is non-NULL */"
+               "  mark_si->marked_count += addr + p_sz - (uptr)build_ptr(end_seg,0);"
+               "}")]))]
+         [within-segment?
+          (code
+           "si->marked_count += p_sz;"
+           (cond
+             [sz
+              (code-block
+               "ptr mark_p = p;"
+               (let loop ([sz sz])
+                 (code
+                  "si->marked_mask[segment_bitmap_byte(mark_p)] |= segment_bitmap_bit(mark_p);"
+                  (let ([sz (- sz (constant byte-alignment))])
+                    (if (zero? sz)
+                        #f
+                        (code
+                         "mark_p = (ptr)((uptr)mark_p + byte_alignment);"
+                         (loop sz)))))))]
+             [else
+              (within-loop-statement #f "si" "byte_alignment" #f)]))]
+         [else
+          (let ([step "byte_alignment"])
+            (code-block
+             (format "uptr addr = (uptr)UNTYPE(p, ~a);" type)
+             "if (addr_get_segment(addr) == addr_get_segment(addr + p_sz - 1))"
+             (code-block
+              "si->marked_count += p_sz;"
+              (within-loop-statement #f "si" step #f))
+             "else"
+             (within-loop-statement (code
+                                     "  seginfo *mark_si = SegInfo(ptr_get_segment(mark_p));"
+                                     (ensure-segment-mark-mask "mark_si" "  " '()))
+                                    "mark_si"
+                                    step
+                                    #t)))])
+       (cond
+         [no-sweep? #f]
+         [else
+          (let ([push "push_sweep(p);"])
+            (cond
+              [(and (memq 'counting-root flags)
+                    (lookup 'counts? config #f))
+               (code "if (!is_counting_root(si, p))"
+                     (code-block push))]
+              [else push]))]))))
+
   (define (field-expression field config arg protect?)
     (if (symbol? field)
         (cond
@@ -1954,6 +2230,26 @@
          (when (and index (not (eq? index 0)))
            (error 'field-ref "index not allowed for non-array field ~s" acc-name))
          (format "~a(~a)" c-ref obj)])))
+  
+  (define (ensure-segment-mark-mask si inset flags)
+    (code
+     (format "~aif (!~a->marked_mask) {" inset si)
+     (format "~a  find_room(space_data, target_generation, typemod, ptr_align(segment_bitmap_bytes), ~a->marked_mask);"
+             inset si)
+     (if (memq 'no-clear flags)
+         (format "~a  /* no clearing needed */" inset)
+         (format "~a  memset(~a->marked_mask, 0, segment_bitmap_bytes);" inset si))
+     (format "~a}" inset)))
+
+  (define (just-mark-bit-space? sp)
+    (case sp
+      [(space-symbol space-port) #t]
+      [else (atomic-space? sp)]))
+
+  (define (atomic-space? sp)
+    (case sp
+      [(space-data) #t]
+      [else #f]))
 
   ;; Slightly hacky way to check whether `op` is an accessor
   (define (get-offset-value op)
@@ -2121,6 +2417,11 @@
                              `((mode sweep)
                                (maybe-backreferences? ,count?)
                                (counts? ,count?))))
+       (print-code (generate "sweep_dirty_object"
+                             `((mode sweep)
+                               (maybe-backreferences? ,count?)
+                               (counts? ,count?)
+                               (as-dirty? #t))))
        (letrec ([sweep1
                  (case-lambda
                   [(type) (sweep1 type (format "sweep_~a" type) '())]
@@ -2146,8 +2447,18 @@
          (sweep1 'code "sweep_code_object"))
        (print-code (generate "size_object"
                              `((mode size))))
+       (print-code (generate "mark_object"
+                             `((mode mark)
+                               (counts? ,count?))))
        (print-code (generate "object_directly_refers_to_self"
                              `((mode self-test))))
+       (print-code (code "static void mark_typemod_data_object(ptr p, uptr p_sz, seginfo *si)"
+                         (code-block
+                          (ensure-segment-mark-mask "si" "" '())
+                          (mark-statement '(one-bit no-sweep)
+                                          (cons
+                                           (list 'used (make-eq-hashtable))
+                                           '((basetype typemod)))))))
        (when measure?
          (print-code (generate "measure" `((mode measure))))))))
 
diff --git a/src/ChezScheme/s/mkheader.ss b/src/ChezScheme/s/mkheader.ss
index 84bf8e91e0..4d4b216057 100644
--- a/src/ChezScheme/s/mkheader.ss
+++ b/src/ChezScheme/s/mkheader.ss
@@ -656,8 +656,8 @@
             (pr "                        \"cmp r12, #0\\n\\t\"\\~%")
             (pr "                        \"bne 1f\\n\\t\"\\~%")
             (pr "                        \"mov r12, #1\\n\\t\"\\~%")
-            (pr "                        \"strex r11, r12, [%0]\\n\\t\"\\~%")
-            (pr "                        \"cmp r11, #0\\n\\t\"\\~%")
+            (pr "                        \"strex r7, r12, [%0]\\n\\t\"\\~%")
+            (pr "                        \"cmp r7, #0\\n\\t\"\\~%")
             (pr "                        \"beq 2f\\n\\t\"\\~%")
             (pr "                        \"1:\\n\\t\"\\~%")
             (pr "                        \"ldr r12, [%0, #0]\\n\\t\"\\~%")
@@ -667,7 +667,7 @@
             (pr "                        \"2:\\n\\t\"\\~%")
             (pr "                        :                \\~%")
             (pr "                        : \"r\" (addr)\\~%")
-            (pr "                        : \"cc\", \"memory\", \"r12\", \"r11\")~%")
+            (pr "                        : \"cc\", \"memory\", \"r12\", \"r7\")~%")
 
             (nl)
             (pr "#define UNLOCK(addr)     \\~%")
@@ -683,14 +683,14 @@
             (pr "                        \"0:\\n\\t\"\\~%")
             (pr "                        \"ldrex r12, [%1, #0]\\n\\t\"\\~%")
             (pr "                        \"add r12, r12, #1\\n\\t\"\\~%")
-            (pr "                        \"strex r11, r12, [%1]\\n\\t\"\\~%")
-            (pr "                        \"cmp r11, #0\\n\\t\"\\~%")
+            (pr "                        \"strex r7, r12, [%1]\\n\\t\"\\~%")
+            (pr "                        \"cmp r7, #0\\n\\t\"\\~%")
             (pr "                        \"bne 0b\\n\\t\"\\~%")
             (pr "                        \"cmp r12, #0\\n\\t\"\\~%")
             (pr "                        \"moveq %0, #1\\n\\t\"\\~%")
             (pr "                        : \"=&r\" (ret)\\~%")
             (pr "                        : \"r\" (addr)\\~%")
-            (pr "                        : \"cc\", \"memory\", \"r12\", \"r11\")~%")
+            (pr "                        : \"cc\", \"memory\", \"r12\", \"r7\")~%")
 
             (nl)
             (pr "#define LOCKED_DECR(addr, ret) \\~%")
@@ -698,14 +698,83 @@
             (pr "                        \"0:\\n\\t\"\\~%")
             (pr "                        \"ldrex r12, [%1, #0]\\n\\t\"\\~%")
             (pr "                        \"sub r12, r12, #1\\n\\t\"\\~%")
-            (pr "                        \"strex r11, r12, [%1]\\n\\t\"\\~%")
-            (pr "                        \"cmp r11, #0\\n\\t\"\\~%")
+            (pr "                        \"strex r7, r12, [%1]\\n\\t\"\\~%")
+            (pr "                        \"cmp r7, #0\\n\\t\"\\~%")
             (pr "                        \"bne 0b\\n\\t\"\\~%")
             (pr "                        \"cmp r12, #0\\n\\t\"\\~%")
             (pr "                        \"moveq %0, #1\\n\\t\"\\~%")
             (pr "                        : \"=&r\" (ret)\\~%")
             (pr "                        : \"r\" (addr)\\~%")
-            (pr "                        : \"cc\", \"memory\", \"r12\", \"r11\")~%")]
+            (pr "                        : \"cc\", \"memory\", \"r12\", \"r7\")~%")]
+          [(arm64)
+            (pr "#define INITLOCK(addr)     \\~%")
+            (pr "  __asm__ __volatile__ (\"mov x12, #0\\n\\t\"\\~%")
+            (pr "                        \"str x12, [%0, #0]\\n\\t\"\\~%")
+            (pr "                        :             \\~%")
+            (pr "                        : \"r\" (addr)\\~%")
+            (pr "                        :\"memory\", \"x12\")~%")
+
+            (nl)
+            (pr "#define SPINLOCK(addr)      \\~%")
+            (pr "  __asm__ __volatile__ (\"0:\\n\\t\"\\~%")
+            (pr "                        \"ldxr x12, [%0, #0]\\n\\t\"\\~%")
+            (pr "                        \"cmp x12, #0\\n\\t\"\\~%")
+            (pr "                        \"bne 1f\\n\\t\"\\~%")
+            (pr "                        \"mov x12, #1\\n\\t\"\\~%")
+            (pr "                        \"stxr w7, x12, [%0]\\n\\t\"\\~%")
+            (pr "                        \"cmp w7, #0\\n\\t\"\\~%")
+            (pr "                        \"beq 2f\\n\\t\"\\~%")
+            (pr "                        \"1:\\n\\t\"\\~%")
+            (pr "                        \"ldr x12, [%0, #0]\\n\\t\"\\~%")
+            (pr "                        \"cmp x12, #0\\n\\t\"\\~%")
+            (pr "                        \"beq 0b\\n\\t\"\\~%")
+            (pr "                        \"b 1b\\n\\t\"\\~%")
+            (pr "                        \"2:\\n\\t\"\\~%")
+            (pr "                        :                \\~%")
+            (pr "                        : \"r\" (addr)\\~%")
+            (pr "                        : \"cc\", \"memory\", \"x12\", \"x7\")~%")
+
+            (nl)
+            (pr "#define UNLOCK(addr)     \\~%")
+            (pr "  __asm__ __volatile__ (\"mov x12, #0\\n\\t\"\\~%")
+            (pr "                        \"str x12, [%0, #0]\\n\\t\"\\~%")
+            (pr "                        :             \\~%")
+            (pr "                        : \"r\" (addr)\\~%")
+            (pr "                        :\"memory\", \"x12\")~%")
+
+            (nl)
+            (pr "#define LOCKED_INCR(addr, ret) \\~%")
+            (pr "  __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%")
+            (pr "                        \"0:\\n\\t\"\\~%")
+            (pr "                        \"ldxr x12, [%1, #0]\\n\\t\"\\~%")
+            (pr "                        \"add x12, x12, #1\\n\\t\"\\~%")
+            (pr "                        \"stxr w7, x12, [%1]\\n\\t\"\\~%")
+            (pr "                        \"cmp w7, #0\\n\\t\"\\~%")
+            (pr "                        \"bne 0b\\n\\t\"\\~%")
+            (pr "                        \"cmp x12, #0\\n\\t\"\\~%")
+            (pr "                        \"bne 1f\\n\\t\"\\~%")
+            (pr "                        \"mov %0, #1\\n\\t\"\\~%")
+            (pr "                        \"1:\\n\\t\"\\~%")
+            (pr "                        : \"=&r\" (ret)\\~%")
+            (pr "                        : \"r\" (addr)\\~%")
+            (pr "                        : \"cc\", \"memory\", \"x12\", \"x7\")~%")
+
+            (nl)
+            (pr "#define LOCKED_DECR(addr, ret) \\~%")
+            (pr "  __asm__ __volatile__ (\"mov %0, #0\\n\\t\"\\~%")
+            (pr "                        \"0:\\n\\t\"\\~%")
+            (pr "                        \"ldxr x12, [%1, #0]\\n\\t\"\\~%")
+            (pr "                        \"sub x12, x12, #1\\n\\t\"\\~%")
+            (pr "                        \"stxr w7, x12, [%1]\\n\\t\"\\~%")
+            (pr "                        \"cmp w7, #0\\n\\t\"\\~%")
+            (pr "                        \"bne 0b\\n\\t\"\\~%")
+            (pr "                        \"cmp x12, #0\\n\\t\"\\~%")
+            (pr "                        \"bne 1f\\n\\t\"\\~%")
+            (pr "                        \"mov %0, #1\\n\\t\"\\~%")
+            (pr "                        \"1:\\n\\t\"\\~%")
+            (pr "                        : \"=&r\" (ret)\\~%")
+            (pr "                        : \"r\" (addr)\\~%")
+            (pr "                        : \"cc\", \"memory\", \"x12\", \"x7\")~%")]
           [else
             ($oops who "asm locking code is not yet defined for ~s" (constant architecture))]))))
 
@@ -814,10 +883,10 @@
         (definit INITBOXREF box ref)
         (defset SETBOXREF box ref)
 
+        (defref EPHEMERONPREVREF ephemeron prev-ref)
+        (definit INITEPHEMERONPREVREF ephemeron prev-ref)
         (defref EPHEMERONNEXT ephemeron next)
         (definit INITEPHEMERONNEXT ephemeron next)
-        (defref EPHEMERONTRIGGERNEXT ephemeron trigger-next)
-        (definit INITEPHEMERONTRIGGERNEXT ephemeron trigger-next)
 
         (defref TLCTYPE tlc type)
         (defref TLCKEYVAL tlc keyval)
diff --git a/src/ChezScheme/s/np-languages.ss b/src/ChezScheme/s/np-languages.ss
index 250f8c26c0..169371e7d0 100644
--- a/src/ChezScheme/s/np-languages.ss
+++ b/src/ChezScheme/s/np-languages.ss
@@ -17,7 +17,7 @@
 (module np-languages ()
   (export sorry! var? var-index var-index-set! prelex->uvar make-tmp make-assigned-tmp
     make-unspillable make-cpvar make-restricted-unspillable
-    uvar? uvar-name uvar-type uvar-source
+    uvar? uvar-name uvar-type uvar-type-set! uvar-source
     uvar-referenced? uvar-referenced! uvar-assigned? uvar-assigned!
     uvar-was-closure-ref? uvar-was-closure-ref!
     uvar-unspillable? uvar-spilled? uvar-spilled! uvar-local-save? uvar-local-save!
@@ -29,13 +29,13 @@
     uvar-ref-weight uvar-ref-weight-set! uvar-save-weight uvar-save-weight-set!
     uvar-live-count uvar-live-count-set!
     uvar
-    fv-offset
+    fv-offset fv-type
     var-spillable-conflict* var-spillable-conflict*-set!
     var-unspillable-conflict* var-unspillable-conflict*-set!
     uvar-degree uvar-degree-set!
     uvar-info-lambda uvar-info-lambda-set!
     uvar-iii uvar-iii-set!
-    ur?
+    ur? fpur?
     block make-block block? block-label block-effect* block-src* block-pseudo-src block-in-link* block-flags
     block-label-set! block-effect*-set! block-src*-set! block-pseudo-src-set! block-in-link*-set! block-flags-set! 
     block-live-in block-live-in-set! block-fp-offset block-fp-offset-set!
@@ -57,7 +57,7 @@
     live-info make-live-info live-info-live live-info-live-set! live-info-useless live-info-useless-set!
     primitive-pure? primitive-type primitive-handler primitive-handler-set!
     %primitive value-primitive? pred-primitive? effect-primitive?
-    fv? $make-fv make-reg reg? reg-name reg-tc-disp reg-callee-save? reg-mdinfo
+    fv? $make-fv make-reg reg? reg-name reg-tc-disp reg-callee-save? reg-mdinfo reg-type
     reg-precolored reg-precolored-set!
     label? label-name
     libspec-label? make-libspec-label libspec-label-libspec libspec-label-live-reg*
@@ -92,13 +92,13 @@
 
   (define-record-type (fv $make-fv fv?)
     (parent var)
-    (fields offset)
+    (fields offset type)
     (nongenerative)
     (sealed #t)
     (protocol
       (lambda (pargs->new)
-        (lambda (offset)
-          ((pargs->new) offset)))))
+        (lambda (offset type)
+          ((pargs->new) offset type)))))
 
   (module ()
     (record-writer (record-type-descriptor fv)
@@ -107,13 +107,13 @@
 
   (define-record-type reg
     (parent var)
-    (fields name mdinfo tc-disp callee-save? (mutable precolored))
+    (fields name mdinfo tc-disp callee-save? type (mutable precolored))
     (nongenerative)
     (sealed #t)
     (protocol
       (lambda (pargs->new)
-        (lambda (name mdinfo tc-disp callee-save?)
-          ((pargs->new) name mdinfo tc-disp callee-save? #f)))))
+        (lambda (name mdinfo tc-disp callee-save? type)
+          ((pargs->new) name mdinfo tc-disp callee-save? type #f)))))
 
   (module ()
     (record-writer (record-type-descriptor reg)
@@ -169,7 +169,7 @@
     (fields 
       name
       source
-      type
+      (mutable type)
       conflict*
       (mutable flags)
       (mutable info-lambda)
@@ -206,8 +206,8 @@
       [(name) (make-assigned-tmp name 'ptr)]
       [(name type) ($make-uvar name #f type '() (uvar-flags-mask referenced assigned))]))
   (define make-unspillable
-    (lambda (name)
-      ($make-uvar name #f 'ptr '() (uvar-flags-mask referenced unspillable))))
+    (lambda (name type)
+      ($make-uvar name #f type '() (uvar-flags-mask referenced unspillable))))
   (define make-cpvar
     (lambda ()
       (include "types.ss")
@@ -220,7 +220,9 @@
   (module ()
     (record-writer (record-type-descriptor uvar)
       (lambda (x p wr)
-        (write (lookup-unique-uvar x) p))))
+        (write (lookup-unique-uvar x) p)
+        (when (eq? (uvar-type x) 'fp)
+          (write 'fp p)))))
 
   (define lookup-unique-uvar
     (let ([ht (make-eq-hashtable)])
@@ -439,6 +441,12 @@
       (- (clause (x* ...) interface body))
       (+ (clause (x* ...) mcp interface body))))
 
+  (define (mref-type? t)
+    ;; Currently, only 'fp vesus non-'fp matters
+    (or (eq? t 'ptr)
+        (eq? t 'uptr)
+        (eq? t 'fp)))
+
  ; move labels to top level and expands closures forms to more primitive operations
   (define-language L7 (extends L6)
     (terminals
@@ -446,7 +454,8 @@
          (fixnum (interface)))
       (+ (var (x))
          (primitive (prim)) ; moved up one language to support closure instrumentation
-         (fixnum (interface offset))))
+         (fixnum (interface offset))
+         (mref-type (type))))
     (entry Program)
     (Program (prog)
       (+ (labels ([l* le*] ...) l)                     => (labels ([l* le*] ...) (l))))
@@ -454,7 +463,7 @@
       (+ (fcallable info l)                            => (fcallable info l)))
     (Lvalue (lvalue)
       (+ x
-         (mref e1 e2 imm)))
+         (mref e1 e2 imm type)))
     (Expr (e body)
       (- x
          (fcallable info)
@@ -471,7 +480,9 @@
          (set! lvalue e)
          ; these two forms are added here so expand-inline handlers can expand into them
          (values info e* ...)
-         (goto l))))
+         (goto l)
+         ; for floating-point unboxing during expand-line:
+         (unboxed-fp e))))
 
   (define-record-type primitive
     (fields name type pure? (mutable handler))
@@ -525,22 +536,12 @@
   (declare-primitive c-simple-call effect #f)
   (declare-primitive c-simple-return effect #f)
   (declare-primitive deactivate-thread effect #f) ; threaded version only
-  (declare-primitive fl* effect #f)
-  (declare-primitive fl+ effect #f)
-  (declare-primitive fl- effect #f)
-  (declare-primitive fl/ effect #f)
   (declare-primitive fldl effect #f) ; x86
   (declare-primitive flds effect #f) ; x86
-  (declare-primitive flsqrt effect #f) ; not implemented for some ppc32 (so we don't use it)
-  (declare-primitive flt effect #f)
   (declare-primitive inc-cc-counter effect #f)
   (declare-primitive inc-profile-counter effect #f)
   (declare-primitive invoke-prelude effect #f)
   (declare-primitive keep-live effect #f)
-  (declare-primitive load-double effect #f)
-  (declare-primitive load-double->single effect #f)
-  (declare-primitive load-single effect #f)
-  (declare-primitive load-single->double effect #f)
   (declare-primitive locked-decr! effect #f)
   (declare-primitive locked-incr! effect #f)
   (declare-primitive pause effect #f)
@@ -553,23 +554,28 @@
   (declare-primitive save-flrv effect #f)
   (declare-primitive save-lr effect #f) ; ppc
   (declare-primitive store effect #f)
-  (declare-primitive store-double effect #f)
-  (declare-primitive store-single effect #f)
-  (declare-primitive store-single->double effect #f)
+  (declare-primitive store-single effect #f); not required by cpnanopass
+  (declare-primitive store-double->single effect #f)
   (declare-primitive store-with-update effect #f) ; ppc
   (declare-primitive unactivate-thread effect #f) ; threaded version only
-  (declare-primitive vpush-multiple effect #f) ; arm
+  (declare-primitive vpush-multiple effect #f) ; arm32
+  (declare-primitive vpop-multiple effect #f) ; arm32
+  (declare-primitive push-fpmultiple effect #f) ; arm64
+  (declare-primitive pop-fpmultiple effect #f) ; arm64
   (declare-primitive cas effect #f)
-
+  (declare-primitive store-store-fence effect #f)
+  (declare-primitive acquire-fence effect #f)
+  (declare-primitive release-fence effect #f)
+  
   (declare-primitive < pred #t)
   (declare-primitive <= pred #t)
   (declare-primitive > pred #t)
   (declare-primitive >= pred #t)
   (declare-primitive condition-code pred #t)
   (declare-primitive eq? pred #t)
-  (declare-primitive fl< pred #t)
-  (declare-primitive fl<= pred #t)
-  (declare-primitive fl= pred #t)
+  (declare-primitive fp< pred #t)
+  (declare-primitive fp<= pred #t)
+  (declare-primitive fp= pred #t)
   (declare-primitive lock! pred #f)
   (declare-primitive logtest pred #t)
   (declare-primitive log!test pred #t)
@@ -610,11 +616,29 @@
   (declare-primitive sll value #t)
   (declare-primitive srl value #t)
   (declare-primitive sra value #t)
-  (declare-primitive trunc value #t)
   (declare-primitive zext8 value #t)
   (declare-primitive zext16 value #t)
   (declare-primitive zext32 value #t) ; 64-bit only
 
+  (declare-primitive fpmove value #t)
+  (declare-primitive fp+ value #t)
+  (declare-primitive fp- value #t)
+  (declare-primitive fp* value #t)
+  (declare-primitive fp/ value #t)
+  (declare-primitive fpt value #t)
+  (declare-primitive fpsqrt value #t) ; not implemented for some ppc32 (so we don't use it)
+  (declare-primitive fptrunc value #t)
+  (declare-primitive double->single value #t) ; not required by cpnanopass
+  (declare-primitive single->double value #t) ; not required by cpnanopass
+
+  (declare-primitive load-single value #t) ; not required by cpnanopass
+  (declare-primitive load-single->double value #t)
+
+  (declare-primitive fpcastto value #t) ; 64-bit only
+  (declare-primitive fpcastto/hi value #t) ; 32-bit only
+  (declare-primitive fpcastto/lo value #t) ; 32-bit only
+  (declare-primitive fpcastfrom value #t) ; 64-bit: 1 argument; 32-bit: 2 arguments
+
   (define immediate?
     (let ([low (- (bitwise-arithmetic-shift-left 1 (fx- (constant ptr-bits) 1)))]
           [high (- (bitwise-arithmetic-shift-left 1 (constant ptr-bits)) 1)])
@@ -652,7 +676,8 @@
       (+ (hand-coded sym)))
     (Expr (e body)
       (- (quote d)
-         pr)))
+         pr
+         (unboxed-fp e))))
 
  ; determine where we should be placing interrupt and overflow
   (define-language L9.5 (extends L9)
@@ -683,8 +708,8 @@
       (- (clause (x* ...) mcp interface body))
       (+ (clause (x* ...) (local* ...) mcp interface body)))
     (Lvalue (lvalue)
-      (- (mref e1 e2 imm))
-      (+ (mref x1 x2 imm)))
+      (- (mref e1 e2 imm type))
+      (+ (mref x1 x2 imm type)))
     (Triv (t)
       (+ lvalue
          (literal info)                          => info
@@ -854,7 +879,8 @@
       (label (l rpl))
       (source-object (src))
       (symbol (sym))
-      (boolean (as-fallthrough)))
+      (boolean (as-fallthrough))
+      (mref-type (type)))
     (Program (prog)
       (labels ([l* le*] ...) l)                   => (letrec ([l* le*] ...) (l)))
     (CaseLambdaExpr (le)
@@ -862,7 +888,7 @@
       (hand-coded sym))
     (Lvalue (lvalue)
       x
-      (mref x1 x2 imm))
+      (mref x1 x2 imm type))
     (Triv (t)
       lvalue
       (literal info)                              => info
@@ -985,7 +1011,8 @@
       (return-label (mrvl))
       (boolean (error-on-values as-fallthrough))
       (fixnum (max-fv offset))
-      (block (block entry-block)))
+      (block (block entry-block))
+      (mref-type (type)))
     (Program (pgm)
       (labels ([l* le*] ...) l)                  => (letrec ([l* le*] ...) (l)))
     (CaseLambdaExpr (le)
@@ -993,7 +1020,7 @@
     (Dummy (dumdum) (dummy))
     (Lvalue (lvalue)
       x
-      (mref x1 x2 imm))
+      (mref x1 x2 imm type))
     (Triv (t)
       lvalue
       (literal info)                            => info
@@ -1049,14 +1076,21 @@
     (lambda (x)
       (or (reg? x) (uvar? x))))
 
+  (define fpur?
+    (lambda (x)
+      (or (and (reg? x)
+               (eq? (reg-type x) 'fp))
+          (and (uvar? x)
+               (eq? (uvar-type x) 'fp)))))
+
   (define-language L15c (extends L15b)
     (terminals
       (- (var (x var)))
       (+ (ur (x))))
     ; NB: base and index are really either regs or (mref %sfp %zero imm)
     (Lvalue (lvalue)
-      (- (mref x1 x2 imm))
-      (+ (mref lvalue1 lvalue2 imm)))
+      (- (mref x1 x2 imm type))
+      (+ (mref lvalue1 lvalue2 imm type)))
     (Effect (e)
       (- (fp-offset live-info imm))))
 
@@ -1068,8 +1102,8 @@
       (+ (procedure (proc)) => $procedure-name))
     (entry Program)
     (Lvalue (lvalue)
-      (- (mref lvalue1 lvalue2 imm))
-      (+ (mref x1 x2 imm)))
+      (- (mref lvalue1 lvalue2 imm type))
+      (+ (mref x1 x2 imm type)))
     (Rhs (rhs)
       (- (inline info value-prim t* ...))
       (+ (asm info proc t* ...) => (asm proc t* ...)))
diff --git a/src/ChezScheme/s/ppc32.ss b/src/ChezScheme/s/ppc32.ss
index 266f2d8c29..55fa85f45b 100644
--- a/src/ChezScheme/s/ppc32.ss
+++ b/src/ChezScheme/s/ppc32.ss
@@ -44,74 +44,74 @@
 
 (define-registers
   (reserved
-    [%tc        %r29              #t 29]
-    [%sfp       %r23              #t 23]
-    [%ap        %r31              #t 31]
-    [%esp       %r21              #t 21]
-    [%eap       %r26              #t 26]
-    [%trap      %r22              #t 22]
-    [%real-zero %r0               #f  0])
+    [%tc        %r29              #t 29 uptr]
+    [%sfp       %r23              #t 23 uptr]
+    [%ap        %r31              #t 31 uptr]
+    [%esp       %r21              #t 21 uptr]
+    [%eap       %r26              #t 26 uptr]
+    [%trap      %r22              #t 22 uptr]
+    [%real-zero %r0               #f  0 uptr])
   (allocable
-    #;[%zero                      #f  0]
-    [%ac0   %r11                  #f 11]
-    [%xp    %r20                  #t 20]
-    [%ts    %r14                  #t 14]
-    [%td    %r15                  #t 15]
-    [%ac1   %r12 %deact           #f 12]
-    [%ret   %r17                  #t 17]
-    [%cp    %r24                  #t 24]
-    [%yp    %r27                  #t 27]
-    [%tp    %r28                  #t 28]
-    [       %r3  %Carg1  %Cretval  %Cretval-high  #f  3]
-    [       %r4  %Carg2            %Cretval-low   #f  4]
-    [       %r5  %Carg3                           #f  5]
-    [       %r6  %Carg4                           #f  6]
-    [       %r7  %Carg5                           #f  7]
-    [       %r8  %Carg6                           #f  8]
-    [       %r9  %Carg7                           #f  9]
-    [       %r10 %Carg8                           #f 10]
-    [       %r16                                  #t 16]
-    [       %r18                                  #t 18]
-    [       %r19                                  #t 19]
-    [       %r25                                  #t 25]
-    [       %r30                                  #t 30]
+    #;[%zero                      #f  0 uptr]
+    [%ac0   %r11                  #f 11 uptr]
+    [%xp    %r20                  #t 20 uptr]
+    [%ts    %r14                  #t 14 uptr]
+    [%td    %r15                  #t 15 uptr]
+    [%ac1   %r12 %deact           #f 12 uptr]
+    [%ret   %r17                  #t 17 uptr]
+    [%cp    %r24                  #t 24 uptr]
+    [%yp    %r27                  #t 27 uptr]
+    [%tp    %r28                  #t 28 uptr]
+    [       %r3  %Carg1  %Cretval  %Cretval-high  #f  3 uptr]
+    [       %r4  %Carg2            %Cretval-low   #f  4 uptr]
+    [       %r5  %Carg3                           #f  5 uptr]
+    [       %r6  %Carg4                           #f  6 uptr]
+    [       %r7  %Carg5                           #f  7 uptr]
+    [       %r8  %Carg6                           #f  8 uptr]
+    [       %r9  %Carg7                           #f  9 uptr]
+    [       %r10 %Carg8                           #f 10 uptr]
+    [       %r16                                  #t 16 uptr]
+    [       %r18                                  #t 18 uptr]
+    [       %r19                                  #t 19 uptr]
+    [       %r25                                  #t 25 uptr]
+    [       %r30                                  #t 30 uptr]
+    [%fpreg1               #f  0 fp]
+    [%fpreg2               #f  9 fp]
   )
   (machine-dependent
-    [%sp       %Csp        #t  1]
-    [%Ctoc                 #f  2] ;; operating system reserved
-    [%Csda                 #f 13] ;; might point to small data area, if used
-    [%flreg1               #f  0]
-    [%Cfparg1  %Cfpretval  #f  1]
-    [%Cfparg2              #f  2]
-    [%Cfparg3              #f  3]
-    [%Cfparg4              #f  4]
-    [%Cfparg5              #f  5]
-    [%Cfparg6              #f  6]
-    [%Cfparg7              #f  7]
-    [%Cfparg8              #f  8]
-    [%flreg2               #f  9]
-    [%flreg3               #f 10]
-    [%flreg4               #f 11]
-    [%flreg5               #f 12]
-    [%flreg6               #f 13]
-    [%flreg7               #t 14]
-    [%flreg8               #t 15]
-    [%flreg9               #t 16]
-    [%flreg10              #t 17]
-    [%flreg11              #t 18]
-    [%flreg12              #t 19]
-    [%flreg13              #t 20]
-    [%flreg14              #t 21]
-    [%flreg15              #t 22]
-    [%flreg16              #t 23]
-    [%flreg17              #t 24]
-    [%flreg18              #t 25]
-    [%flreg19              #t 26]
-    [%flreg20              #t 27]
-    [%flreg21              #t 28]
-    [%flreg22              #t 29]
-    [%flreg23              #t 30]
-    [%flreg24              #t 31]
+    [%sp       %Csp        #t  1 uptr]
+    [%Ctoc                 #f  2 uptr] ;; operating system reserved
+    [%Csda                 #f 13 uptr] ;; might point to small data area, if used
+    [%Cfparg1  %Cfpretval  #f  1 fp]
+    [%Cfparg2              #f  2 fp]
+    [%Cfparg3              #f  3 fp]
+    [%Cfparg4              #f  4 fp]
+    [%Cfparg5              #f  5 fp]
+    [%Cfparg6              #f  6 fp]
+    [%Cfparg7              #f  7 fp]
+    [%Cfparg8              #f  8 fp]
+    [%flreg3 %fptmp1       #f 10 fp]
+    [%flreg4               #f 11 fp]
+    [%flreg5               #f 12 fp]
+    [%flreg6               #f 13 fp]
+    [%flreg7               #t 14 fp]
+    [%flreg8               #t 15 fp]
+    [%flreg9               #t 16 fp]
+    [%flreg10              #t 17 fp]
+    [%flreg11              #t 18 fp]
+    [%flreg12              #t 19 fp]
+    [%flreg13              #t 20 fp]
+    [%flreg14              #t 21 fp]
+    [%flreg15              #t 22 fp]
+    [%flreg16              #t 23 fp]
+    [%flreg17              #t 24 fp]
+    [%flreg18              #t 25 fp]
+    [%flreg19              #t 26 fp]
+    [%flreg20              #t 27 fp]
+    [%flreg21              #t 28 fp]
+    [%flreg22              #t 29 fp]
+    [%flreg23              #t 30 fp]
+    [%flreg24              #t 31 fp]
     ))
 
 ;;; SECTION 2: instructions
@@ -136,6 +136,12 @@
     (lambda (x)
       (or (lmem? x) (literal@? x))))
 
+  (define fpmem?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
+        [else #f])))
+
   (define-syntax define-imm-pred
     (lambda (x)
       (syntax-case x ()
@@ -173,27 +179,27 @@
   (define mref->mref
     (lambda (a k)
       (define return
-        (lambda (x0 x1 imm)
+        (lambda (x0 x1 imm type)
           ; ppc load & store instructions support index or offset but not both
           (safe-assert (or (eq? x1 %zero) (eqv? imm 0)))
-          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))
+          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))
       (nanopass-case (L15c Triv) a
-        [(mref ,lvalue0 ,lvalue1 ,imm)
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type)
          (lvalue->ur lvalue0
            (lambda (x0)
              (lvalue->ur lvalue1
                (lambda (x1)
                  (cond
-                   [(and (eq? x1 %zero) (integer16? imm)) (return x0 %zero imm)]
+                   [(and (eq? x1 %zero) (integer16? imm)) (return x0 %zero imm type)]
                    [else
                     (let ([u (make-tmp 'u)])
                       (seq
                         (build-set! ,u (immediate ,imm))
                         (if (eq? x1 %zero)
-                            (return x0 u 0)
+                            (return x0 u 0 type)
                             (seq
                               (build-set! ,u (asm ,null-info ,asm-add ,u ,x1))
-                              (return x0 u 0)))))])))))])))
+                              (return x0 u 0 type)))))])))))])))
 
   (define mem->mem
     (lambda (a k)
@@ -202,12 +208,12 @@
          (let ([u (make-tmp 'u)])
            (seq
              (build-set! ,u ,(literal@->literal a))
-             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0)))))]
+             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))]
         [else (mref->mref a k)])))
 
   (define-pass imm->negative-imm : (L15c Triv) (ir) -> (L15d Triv) ()
     (Lvalue : Lvalue (ir) -> Lvalue ()
-      [(mref ,lvalue1 ,lvalue2 ,imm) (sorry! who "unexpected mref ~s" ir)])
+      [(mref ,lvalue1 ,lvalue2 ,imm ,type) (sorry! who "unexpected mref ~s" ir)])
     (Triv : Triv (ir) -> Triv ()
       [(immediate ,imm) `(immediate ,(- imm))]))
 
@@ -215,7 +221,8 @@
     (syntax-rules ()
       [(_ ?a ?aty*)
        (let ([a ?a] [aty* ?aty*])
-         (or (memq 'ur aty*)
+         (or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
+             (and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
              (and (memq 'shift-count aty*) (imm-shift-count? a))
              (and (memq 'unsigned16 aty*) (imm-unsigned16? a))
              (and (memq 'shifted-unsigned16 aty*) (imm-shifted-unsigned16? a))
@@ -224,7 +231,8 @@
              (and (memq 'negated-integer16 aty*) (imm-negatable-integer16? a))
              (and (memq 'negated-shifted-integer16 aty*) (imm-negatable-shifted-integer16? a))
              (and (memq 'imm-constant aty*) (imm-constant? a))
-             (and (memq 'mem aty*) (mem? a))))]))
+             (and (memq 'mem aty*) (mem? a))
+             (and (memq 'fpmem aty*) (fpmem? a))))]))
 
   (define-syntax coerce-opnd ; passes k something compatible with aty*
     (syntax-rules ()
@@ -232,6 +240,7 @@
        (let ([a ?a] [aty* ?aty*] [k ?k])
          (cond
            [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
+           [(and (memq 'fpmem aty*) (fpmem? a)) (mem->mem a k)]
            [(or (and (memq 'shift-count aty*) (imm-shift-count? a))
                 (and (memq 'unsigned16 aty*) (imm-unsigned16? a))
                 (and (memq 'shifted-unsigned16 aty*) (imm-shifted-unsigned16? a))
@@ -258,6 +267,17 @@
                        (build-set! ,u ,a)
                        (k u)))))]
               [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
+           [(memq 'fpur aty*)
+            (cond
+              [(fpur? a) (k a)]
+              [(fpmem? a)
+               (mem->mem a
+                 (lambda (a)
+                   (let ([u (make-tmp 'u 'fp)])
+                     (seq
+                       (build-set! ,u ,a)
+                       (k u)))))]
+              [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
            [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
 
   (define set-ur=mref
@@ -294,24 +314,16 @@
     (lambda (x)
       (define make-value-clause
         (lambda (fmt)
-          (syntax-case fmt (mem ur)
-            [(op (c mem) (a ur))
-             #`(lambda (c a)
-                 (if (lmem? c)
-                     (coerce-opnd a '(ur)
-                       (lambda (a)
-                         (mem->mem c
-                           (lambda (c)
-                             (rhs c a)))))
-                     (next c a)))]
-            [(op (c ur) (a aty ...) ...)
+          (syntax-case fmt (mem ur fpmem fpur)
+            [(op (c xur) (a aty ...) ...)
+             (memq (syntax->datum #'xur) '(ur fpur))
              #`(lambda (c a ...)
                  (if (and (coercible? a '(aty ...)) ...)
                      #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
                          (if (null? a*)
-                             #'(if (ur? c)
+                             #`(if (#,(if (eq? (syntax->datum #'xur) 'ur) #'ur? #'fpur?) c)
                                    (rhs c a ...)
-                                   (let ([u (make-tmp 'u)])
+                                   (let ([u (make-tmp 'u '#,(if (eq? (syntax->datum #'xur) 'ur) #'uptr #'fp))])
                                      (seq
                                        (rhs u a ...)
                                        (mref->mref c
@@ -319,6 +331,19 @@
                                            (build-set! ,c ,u))))))
                              #`(coerce-opnd #,(car a*) '#,(car aty**)
                                  (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
+                     (next c a ...)))]
+            [(op (c xmem) (a aty ...) ...)
+             (memq (syntax->datum #'xmem) '(mem fpmem))
+             #`(lambda (c a ...)
+                 (if (and (#,(if (eq? (syntax->datum #'xmem) 'mem) #'lmem? #'fpmem?) c)
+                          (coercible? a '(aty ...)) ...)
+                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
+                         (if (null? a*)
+                             #`(mem->mem c
+                                 (lambda (c)
+                                   (rhs c a ...)))
+                             #`(coerce-opnd #,(car a*) '#,(car aty**)
+                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
                      (next c a ...)))])))
 
       (define-who make-pred-clause
@@ -600,39 +625,69 @@
     [(op (x ur) (y ur) (z ur integer16))
      `(asm ,info ,asm-store-with-update ,x ,y ,z)])
 
-  (define-instruction effect (load-single load-single->double load-double load-double->single
-                              store-single store-single->double store-double)
-    [(op (x ur) (y ur) (z integer16 ur))
-     (if (eq? y %zero)
-         (if (ur? z)
-             `(asm ,info ,(asm-fl-load/store op (info-loadfl-flreg info)) ,x ,z (immediate 0))
-             `(asm ,info ,(asm-fl-load/store op (info-loadfl-flreg info)) ,x ,y ,z))
-         (if (and (not (ur? z)) (fx= (nanopass-case (L15d Triv) z [(immediate ,imm) imm]) 0))
-             `(asm ,info ,(asm-fl-load/store op (info-loadfl-flreg info)) ,x ,y ,z)
-             (let ([u (make-tmp 'u)])
-               (seq
-                 `(set! ,(make-live-info) ,u (asm ,null-info ,asm-add ,y ,z))
-                 `(asm ,info ,(asm-fl-load/store op (info-loadfl-flreg info)) ,x ,u (immediate 0))))))])
-
-  (define-instruction effect (flt)
-    [(op (x ur) (y ur))
+  (define-instruction value (fpmove)
+    [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
+    [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)])
+
+  (let ()
+    (define (end->delta dir)
+      (constant-case native-endianness
+        [(little) (if (eq? dir 'lo) 0 4)]
+        [(big) (if (eq? dir 'hi) 0 4)]))
+    
+    (define (fpmem->mem mem dir)
+      (with-output-language (L15d Triv)
+        (nanopass-case (L15d Triv) mem
+          [(mref ,x1 ,x2 ,imm ,type)
+           (safe-assert (eq? type 'fp))
+           `(mref ,x1 ,x2 ,(fx+ imm (end->delta dir)) uptr)]
+          [else (sorry! 'fpmem->mem "unexpected reference ~s" mem)])))
+    
+    (define-instruction value (fpcastto/hi)
+      [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'hi))]
+      [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto (end->delta 'hi)) ,y))])
+    
+    (define-instruction value (fpcastto/lo)
+      [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(fpmem->mem y 'lo))]
+      [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto (end->delta 'lo)) ,y))])
+    
+    (define-instruction value (fpcastfrom)
+      [(op (x fpmem) (hi ur) (lo ur)) (seq
+                                       `(set! ,(make-live-info) ,(fpmem->mem x 'lo) ,lo)
+                                       `(set! ,(make-live-info) ,(fpmem->mem x 'hi) ,hi))]
+      [(op (x fpur) (hi ur) (lo ur))
+       `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastfrom (end->delta 'lo) (end->delta 'hi)) ,lo ,hi))]))
+
+  (define-instruction value (load-single->double)
+    [(op (x fpur) (y fpmem))
+     `(set! ,(make-live-info) ,x (asm ,null-info ,asm-load-single->double ,y))])
+
+  (define-instruction effect (store-double->single)
+    [(op (x fpmem) (y fpur))
+     `(asm ,null-info ,asm-store-double->single ,x ,y)])
+
+  ;; Note: PPC FP registers always hold double-precision values, so
+  ;; there are no single<->double conversion operators.
+
+  (define-instruction value (fpt)
+    [(op (x fpur) (y ur))
      (let ([u (make-tmp 'u)])
        (seq
          `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
-         `(asm ,info ,asm-flt ,x ,y ,u)))])
-
-  (define-instruction effect (fl+ fl- fl/ fl*)
-    [(op (x ur) (y ur) (z ur))
-     `(asm ,info ,(asm-flop-2 op) ,x ,y ,z)])
-
-  (define-instruction value (trunc)
-    [(op (z ur) (x ur))
+         `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y ,u))))])
+  
+  (define-instruction value (fptrunc)
+    [(op (z ur) (x fpur))
      `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x))])
 
-  (define-instruction pred (fl= fl< fl<=)
-    [(op (x ur) (y ur))
+  (define-instruction value (fp+ fp- fp/ fp*)
+    [(op (x fpur) (y fpur) (z fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
+
+  (define-instruction pred (fp= fp< fp<=)
+    [(op (x fpur) (y fpur))
      (let ([info (make-info-condition-code op #f #f)])
-        (values '() `(asm ,info ,(asm-fl-relop info) ,x ,y)))])
+        (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
 
   (define-instruction effect (inc-cc-counter)
     [(op (x ur) (w shifted-integer16 integer16 ur) (z ur))
@@ -817,32 +872,32 @@
      (let ([n (nanopass-case (L15d Triv) z [(immediate ,imm) imm])])
        (seq
          `(set! ,(make-live-info) ,%real-zero (asm ,info ,(asm-get-lr)))
-         `(set! ,(make-live-info) (mref ,%Csp ,%zero ,n) ,%real-zero)))])
+         `(set! ,(make-live-info) (mref ,%Csp ,%zero ,n uptr) ,%real-zero)))])
 
   (define-instruction effect (restore-lr)
     [(op (z integer16))
      (let ([n (nanopass-case (L15d Triv) z [(immediate ,imm) imm])])
        (seq
-         `(set! ,(make-live-info) ,%real-zero (mref ,%Csp ,%zero ,n))
+         `(set! ,(make-live-info) ,%real-zero (mref ,%Csp ,%zero ,n uptr))
          `(asm ,info ,(asm-set-lr) ,%real-zero)))])
 )
 
 ;;; SECTION 3: assembler
 (module asm-module ( ; required exports
-                     asm-move asm-move/extend asm-load asm-store asm-library-call asm-library-call! asm-library-jump
+                     asm-move asm-move/extend asm-fpmove asm-load asm-store asm-library-call asm-library-call! asm-library-jump
                      asm-div asm-mul asm-mul/ovfl asm-add asm-add/ovfl asm-sub-from asm-sub-from/ovfl
                      asm-add/carry asm-sub-from/eq
                      asm-logand asm-logor asm-logxor asm-sra asm-srl asm-sll
                      asm-logand asm-lognot
-                     asm-logtest asm-fl-relop asm-relop asm-logrelop
+                     asm-logtest asm-fp-relop asm-relop asm-logrelop
                      asm-indirect-jump asm-literal-jump
                      asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
                      asm-rp-header asm-rp-compact-header
                      asm-indirect-call asm-condition-code
-                     asm-trunc asm-flt
+                     asm-trunc asm-fpt asm-fpcastto asm-fpcastfrom
                      asm-lock asm-lock+/- asm-cas
-                     asm-fl-load/store
-                     asm-flop-2 asm-c-simple-call
+                     asm-load-single->double asm-store-double->single
+                     asm-fpop-2 asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                      asm-enter asm-foreign-call asm-foreign-callable
                      asm-read-counter
@@ -1016,6 +1071,8 @@
   (define-op fmul flmul-op #b0)
   (define-op fsub flreg-op #b010100 #b0)
 
+  (define-op fmr  fmr-op)
+
   (define-op cror cror-op)
 
   (define-op fcmpu compare-op     #b111111 #b0000000000)
@@ -1299,6 +1356,16 @@
         [1  #b0111000001]
         [0  #b0])))
 
+  (define fmr-op
+    (lambda (op dest-ea src-ea code*)
+      (emit-code (op dest-ea src-ea code*)
+        [26 #b111111]
+        [21 (ax-ea-reg-code dest-ea)]
+        [16 #b00000]
+        [11 (ax-ea-reg-code src-ea)]
+        [1  #b0001001000]
+        [0  #b0])))
+
   (define isync-op
     (lambda (op code*)
       (emit-code (op code*)
@@ -1494,6 +1561,35 @@
                [else (sorry! who "unexpected op ~s" op)])]
             [else (sorry! who "unexpected src ~s" src)])))))
 
+  (define-who asm-fpmove
+    (lambda (code* dest src)
+      ; fpmove pseudo instruction used by set! case in select-instruction
+      ; guarantees dest is a reg and src is reg or mem OR dest is
+      ; mem and src is reg.
+      (Trivit (dest src)
+        (define (bad!) (sorry! who "unexpected combination of src ~s and dest ~s" src dest))
+        (cond
+          [(ax-reg? dest)
+           (record-case src
+             [(reg) ignore (emit fmr dest src code*)]
+             [(disp) (n breg)
+              (safe-assert (integer16? n))
+              (emit lfd dest `(reg . ,breg) `(imm ,n) code*)]
+             [(index) (n ireg breg)
+              (safe-assert (eqv? n 0))
+              (emit lfdx dest `(reg . ,breg) `(reg . ,ireg) code*)]
+             [else (bad!)])]
+          [(ax-reg? src)
+           (record-case dest
+             [(disp) (n breg)
+              (safe-assert (or (unsigned16? n) (unsigned16? (- n))))
+              (emit stfd src `(reg . ,breg) `(imm ,n) code*)]
+             [(index) (n ireg breg)
+              (safe-assert (eqv? n 0))
+              (emit stfdx src `(reg . ,breg) `(reg . ,ireg) code*)]
+             [else (bad!)])]
+          [else (bad!)]))))
+
   (define asm-add
     (lambda (code* dest src0 src1)
       (Trivit (dest src0 src1)
@@ -1669,81 +1765,90 @@
                    [else (sorry! who "unexpected mref type ~s" type)])]
                 [else (sorry! who "expected %zero base or 0 offset, got ~s and ~s" base offset)])))))))
 
-  ;; load single->double
-  ;; lfs  frD <- [rA + d]
-  ;; lfsx frD <- [rA + rB]
-  ;; load double
-  ;; lfd  frD <- [rA + d]
-  ;; lfdx frD <- [rA + rB]
-  ;; store double
-  ;; stfd  [rA + d] <- frS
-  ;; stfdx [rA + rB] <- frS
-  ;; store double->single
-  ;; stfs  [rA + d] <- frS
-  ;; stfsx [rA + rB] <- frS
-  (define asm-fl-load/store
-    (lambda (op flreg)
-      (lambda (code* base index offset)
-        (Trivit (flreg base)
-          (define-syntax finish
-            (syntax-rules ()
-              [(_ op opx code*)
-               (if (eq? index %zero)
-                   (Trivit (offset)
-                     (emit op flreg base offset code*))
-                   (Trivit (index)
-                     (emit opx flreg base index code*)))]))
-          (case op
-            [(load-single load-single->double) (finish lfs lfsx code*)]
-            [(load-double) (finish lfd lfdx code*)]
-            [(load-double->single) 
-             (finish lfd lfdx (emit frsp flreg flreg code*))]
-            [(store-single) (finish stfs stfsx code*)]
-            [(store-double) (finish stfd stfdx code*)]
-            [(store-single->double) 
-             (emit frsp flreg flreg
-               (finish stfd stfdx code*))])))))
-
-  (define-who asm-flop-2
+  (define select-addressing-mode
+    (lambda (mem k kx)
+      (record-case mem
+        [(disp) (n reg)
+         (safe-assert (integer16? n))
+         (k `(reg . ,reg) `(imm ,n))]
+        [(index) (n ireg reg)
+         (safe-assert (eqv? n 0))
+         (kx `(reg . ,reg) `(reg . ,ireg))])))
+
+  (define asm-load-single->double
+    (lambda (code* dest-reg src-mem)
+      (Trivit (dest-reg src-mem)
+        (select-addressing-mode
+         src-mem
+         (lambda (src-reg src-offset)
+           (emit lfs dest-reg src-reg src-offset code*))
+         (lambda (src-reg index-reg)
+           (emit lfsx dest-reg src-reg index-reg code*))))))
+  
+  (define asm-store-double->single
+    (lambda (code* dest-mem src-reg)
+      (Trivit (dest-mem src-reg)
+        (let ([tmp `(reg . ,%fptmp1)])
+          (emit frsp tmp src-reg
+            (select-addressing-mode
+             dest-mem
+             (lambda (dest-reg dest-offset)
+               (emit stfs tmp dest-reg dest-offset code*))
+             (lambda (dest-reg index-reg)
+               (emit stfsx tmp dest-reg index-reg code*))))))))
+
+  (define-who asm-fpop-2
     (lambda (op)
-      (lambda (code* src1 src2 dest)
-        (let ([flreg1 `(reg . ,%flreg1)] [flreg2 `(reg . ,%flreg2)])
-          (Trivit (src1 src2 dest)
-            (emit lfd flreg1 src1 `(imm ,(constant flonum-data-disp))
-              (emit lfd flreg2 src2 `(imm ,(constant flonum-data-disp))
-                (let ([code* (emit stfd flreg1 dest `(imm ,(constant flonum-data-disp)) code*)])
-                  (case op
-                    [(fl+) (emit fadd flreg1 flreg1 flreg2 code*)]
-                    [(fl-) (emit fsub flreg1 flreg1 flreg2 code*)]
-                    [(fl*) (emit fmul flreg1 flreg1 flreg2 code*)]
-                    [(fl/) (emit fdiv flreg1 flreg1 flreg2 code*)]
-                    [else (sorry! who "unrecognized op ~s" op)])))))))))
+      (lambda (code* dest src1 src2)
+        (Trivit (src1 src2 dest)
+          (case op
+            [(fp+) (emit fadd dest src1 src2 code*)]
+            [(fp-) (emit fsub dest src1 src2 code*)]
+            [(fp*) (emit fmul dest src1 src2 code*)]
+            [(fp/) (emit fdiv dest src1 src2 code*)]
+            [else (sorry! who "unrecognized op ~s" op)])))))
 
   (define asm-trunc
     (lambda (code* dest src)
-      (let ([flreg1 `(reg . ,%flreg1)] [Csp `(reg . ,%Csp)])
-        (Trivit (dest src)
-          (emit lfd flreg1 src `(imm ,(constant flonum-data-disp))
-            (emit fctiwz flreg1 flreg1
-              (emit stfd flreg1 Csp `(imm -8)
-                (emit lwz dest Csp `(imm -4) code*))))))))
-
-  (define asm-flt
-    (lambda (code* src dest tmp)
+      (Trivit (dest src)
+        (let ([flreg1 `(reg . ,%fptmp1)]
+              [Csp `(reg . ,%Csp)])
+          (emit fctiwz flreg1 src
+            (emit stfd flreg1 Csp `(imm -8)
+              (emit lwz dest Csp `(imm -4) code*)))))))
+
+  (define asm-fpt
+    (lambda (code* dest src tmp)
       (Trivit (src dest tmp)
-        (let ([flreg1 `(reg . ,%flreg1)]
-              [flreg2 `(reg . ,%flreg2)]
+        (let ([Csp `(reg . ,%Csp)]
+              [fptmp `(reg . ,%fptmp1)]
               [flodat-disp `(imm ,(constant flonum-data-disp))])
           (emit xoris tmp src `(imm #x8000)
-            (emit stw tmp dest `(imm ,(+ (constant flonum-data-disp) 4))
+            (emit stw tmp Csp `(imm -4)
               (emit addis tmp `(reg . ,%real-zero) `(imm #x4330)
-                (emit stw tmp dest flodat-disp
-                  (emit lfd flreg1 dest flodat-disp
+                (emit stw tmp Csp `(imm -8)
+                  (emit lfd dest Csp `(imm -8)
                     (ax-move-literal tmp `(literal 0 (object 4503601774854144.0))
-                      (emit lfd flreg2 tmp flodat-disp
-                        (emit fsub flreg1 flreg1 flreg2 
-                          (emit stfd flreg1 dest flodat-disp
-                            code*)))))))))))))
+                      (emit lfd fptmp tmp flodat-disp
+                        (emit fsub dest dest fptmp
+                              code*))))))))))))
+
+  (define asm-fpcastto
+    (lambda (delta)
+      (lambda (code* dest src)
+        (Trivit (dest src)
+          (let ([Csp `(reg . ,%Csp)])
+            (emit stfd src Csp `(imm -8)
+              (emit lwz dest Csp `(imm ,(fx+ delta -8)) code*)))))))
+
+  (define asm-fpcastfrom
+    (lambda (delta1 delta2)
+      (lambda (code* dest src1 src2)
+        (Trivit (dest src1 src2)
+          (let ([Csp `(reg . ,%Csp)])
+            (emit stw src1 Csp `(imm ,(fx+ -8 delta1))
+              (emit stw src2 Csp `(imm ,(fx+ -8 delta2))
+                (emit lfd dest Csp `(imm -8) code*))))))))
 
   (define asm-lock
     (lambda (info)
@@ -1801,19 +1906,16 @@
               (emit stwcx. new base index
                 code*)))))))
 
-  (define asm-fl-relop
+  (define asm-fp-relop
     (lambda (info)
       (lambda (l1 l2 offset x y)
-        (let ([flreg1 `(reg . ,%flreg1)] [flreg2 `(reg . ,%flreg2)])
-          (Trivit (x y)
-            (values
-              (emit lfd flreg1 x `(imm ,(constant flonum-data-disp))
-                (emit lfd flreg2 y `(imm ,(constant flonum-data-disp))
-                  (emit fcmpu flreg1 flreg2
-                    (if (eq? (info-condition-code-type info) 'fl<=)
-                        (emit cror 1 1 3 '())
-                        '()))))
-              (asm-conditional-jump info l1 l2 offset)))))))
+        (Trivit (x y)
+          (values
+            (emit fcmpu x y
+              (if (eq? (info-condition-code-type info) 'fp<=)
+                  (emit cror 1 1 3 '())
+                  '()))
+            (asm-conditional-jump info l1 l2 offset))))))
 
   (module (asm-relop asm-logrelop)
     (define-syntax define-asm-relop
@@ -1903,7 +2005,8 @@
 
   (define asm-direct-jump
     (lambda (l offset)
-      (asm-helper-jump '() (make-funcrel 'ppc32-jump l offset))))
+      (let ([offset (adjust-return-point-offset offset l)])
+        (asm-helper-jump '() (make-funcrel 'ppc32-jump l offset)))))
 
   (define asm-literal-jump
     (lambda (info)
@@ -2036,9 +2139,9 @@
                      (case op
                        [(ops ...) (if i? r1 r2)] ...))))])))
       (define-pred-emitter emit-branch
-        [(fl= eq?) (i? bne beq)]
-        [(fl< < u<) (i? (r? ble bge) (r? bgt blt))]
-        [(fl<= <=) (i? (r? blt bgt) (r? bge ble))]
+        [(fp= eq?) (i? bne beq)]
+        [(fp< < u<) (i? (r? ble bge) (r? bgt blt))]
+        [(fp<= <=) (i? (r? blt bgt) (r? bge ble))]
         [(>) (i? (r? bge ble) (r? blt bgt))]
         [(>=) (i? (r? bgt blt) (r? ble bge))]
         [(carry multiply-overflow overflow) (i? bns bso)])
@@ -2236,8 +2339,8 @@
 	    (let ([offset (align 8 offset)])
 	      (move-registers regs (fx- fp-reg-count 1) (cdr fp-regs) load? (fx+ offset 8)
 			      (cond
-			       [load? `(seq ,e (inline ,(make-info-loadfl (car fp-regs)) ,%load-double ,%sp ,%zero (immediate ,offset)))]
-			       [else  `(seq (inline ,(make-info-loadfl (car fp-regs)) ,%store-double ,%sp ,%zero (immediate ,offset)) ,e)])))]
+			       [load? `(seq ,e (set! ,(car fp-regs) ,(%mref ,%sp ,%zero ,offset fp)))]
+			       [else  `(seq (set! ,(%mref ,%sp ,%zero ,offset fp) ,(car fp-regs)) ,e)])))]
 	   [(pair? regs)
 	    (move-registers (cdr regs) 0 '() load? (fx+ offset 4)
 			    (cond
@@ -2255,16 +2358,18 @@
       (with-output-language (L13 Effect)
         (define load-double-stack
           (lambda (offset fp-disp)
-            (lambda (x) ; requires var
-              (%seq
-                (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero (immediate ,fp-disp))
-                (inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset))))))
+            (if fp-disp
+                (lambda (x) ; requires var
+                  `(set! ,(%mref ,%sp ,%zero ,offset fp) ,(%mref ,x ,%zero ,fp-disp fp)))
+                (lambda (x) ; unboxed
+                  `(set! ,(%mref ,%sp ,%zero ,offset fp) ,x)))))
         (define load-single-stack
-          (lambda (offset fp-disp single?)
-            (lambda (x) ; requires var
-              (%seq
-                (inline ,(make-info-loadfl %flreg1) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))
-                (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset))))))
+          (lambda (offset fp-disp)
+            (if fp-disp
+                (lambda (x) ; requires var
+                  `(set! ,(%mref ,%sp ,offset) ,(%mref ,x ,fp-disp)))
+                (lambda (x) ; unboxed
+                  (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))))
         (define load-int-stack
           (lambda (offset)
             (lambda (rhs) ; requires rhs
@@ -2291,25 +2396,44 @@
 		(set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x 4))))))
         (define load-double-reg
           (lambda (fpreg fp-disp)
-            (lambda (x) ; requires var
-              `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp)))))
+            (if fp-disp
+                (lambda (x) ; requires var
+                  `(set! ,fpreg ,(%mref ,x ,%zero ,fp-disp fp)))
+                (lambda (x) ; unboxed
+                  `(set! ,fpreg ,x)))))
+        (define fpmem->mem
+          (lambda (mem delta)
+            (nanopass-case (L13 Lvalue) mem
+              [(mref ,x1 ,x2 ,imm ,type)
+               (with-output-language (L13 Lvalue)
+                 `(mref ,x1 ,x2 ,(+ imm delta) uptr))]
+              [else (sorry! 'foreign-call "unexpected fpmem ~s" mem)])))
         (define load-soft-double-reg
           (lambda (loreg hireg fp-disp)
-            (lambda (x)
-               (%seq
-                 (set! ,loreg ,(%mref ,x ,(fx+ fp-disp 4)))
-                 (set! ,hireg ,(%mref ,x ,fp-disp))))))
+            (safe-assert (eq? (constant native-endianness) 'big))
+            (if fp-disp
+                (lambda (x) ; requires var
+                  (%seq
+                   (set! ,loreg ,(%mref ,x ,(fx+ fp-disp 4)))
+                   (set! ,hireg ,(%mref ,x ,fp-disp))))
+                (lambda (x) ; unboxed
+                  (%seq
+                   (set! ,loreg ,(fpmem->mem x 4))
+                   (set! ,hireg ,(fpmem->mem x 0)))))))
         (define load-single-reg
-          (lambda (fpreg fp-disp single?)
-            (lambda (x) ; requires var
-              `(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp)))))
+          (lambda (fpreg fp-disp)
+            (if fp-disp
+                (lambda (x) ; requires var
+                  `(set! ,fpreg ,(%inline load-single->double ,(%mref ,x ,%zero ,fp-disp fp))))
+                (lambda (x)
+                  `(set! ,fpreg ,x)))))
         (define load-soft-single-reg
-          (lambda (ireg fp-disp single?)
-            (lambda (x)
-              (%seq
-                (inline ,(make-info-loadfl %flreg1) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))
-                (inline ,(make-info-loadfl %flreg1) ,%store-single ,%tc ,%zero (immediate ,(constant tc-ac0-disp)))
-                (set! ,ireg ,(%tc-ref ac0))))))
+          (lambda (ireg fp-disp)
+            (if fp-disp
+                (lambda (x) ; requires var
+                  `(set! ,ireg ,(%mref ,x ,fp-disp)))
+                (lambda (x) ; unboxed
+                  `(set! ,ireg ,(fpmem->mem x 0))))))
         (define load-int-reg
           (lambda (ireg)
             (lambda (x) ; requires rhs
@@ -2346,7 +2470,7 @@
 		       ;; needed when adjusting active:
 		       [fp-live-count 0]
 		       ;; configured for `ftd-fp&` unpacking of floats:
-		       [fp-disp (constant flonum-data-disp)] [single? #f])
+		       [fp-disp #f])
               (if (null? types)
                   (values isp locs live* fp-live-count)
                   (nanopass-case (Ltype Type) (car types)
@@ -2358,51 +2482,51 @@
                                  (loop (cdr types)
                                    (cons (load-double-stack isp fp-disp) locs)
                                    live* '() flt* (fx+ isp 8) fp-live-count
-				   (constant flonum-data-disp) #f))
+				   #f))
                                (loop (cdr types)
                                  (cons (load-soft-double-reg (cadr int*) (car int*) fp-disp) locs)
                                  (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count
-				 (constant flonum-data-disp) #f)))
+				 #f)))
                          (if (null? flt*)
                              (let ([isp (align 8 isp)])
                                (loop (cdr types)
                                  (cons (load-double-stack isp fp-disp) locs)
                                  live* int* '() (fx+ isp 8) fp-live-count
-				 (constant flonum-data-disp) #f))
+				 #f))
                              (loop (cdr types)
                                (cons (load-double-reg (car flt*) fp-disp) locs)
                                live* int* (cdr flt*) isp (fx+ fp-live-count 1)
-			       (constant flonum-data-disp) #f)))]
+			       #f)))]
                     [(fp-single-float)
                      (if (constant software-floating-point)
                          (if (null? int*)
                              ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't
                              (loop (cdr types)
-                               (cons (load-single-stack isp fp-disp single?) locs)
+                               (cons (load-single-stack isp fp-disp) locs)
                                live* '() flt* (fx+ isp 4) fp-live-count
-			       (constant flonum-data-disp) #f)
+			       #f)
                              (loop (cdr types)
-                               (cons (load-soft-single-reg (car int*) fp-disp single?) locs)
+                               (cons (load-soft-single-reg (car int*) fp-disp) locs)
                                (cons (car int*) live*) (cdr int*) flt* isp fp-live-count
-			       (constant flonum-data-disp) #f))
+			       #f))
                          (if (null? flt*)
                              ; NB: ABI says singles are passed as doubles on the stack, but gcc/linux doesn't
                              (let ([isp (align 4 isp)])
                                (loop (cdr types)
-                                 (cons (load-single-stack isp fp-disp single?) locs)
+                                 (cons (load-single-stack isp fp-disp) locs)
                                  live* int* '() (fx+ isp 4) fp-live-count
-				 (constant flonum-data-disp) #f))
+				 #f))
                              (loop (cdr types)
-                               (cons (load-single-reg (car flt*) fp-disp single?) locs)
+                               (cons (load-single-reg (car flt*) fp-disp) locs)
                                live* int* (cdr flt*) isp (fx+ fp-live-count 1)
-			       (constant flonum-data-disp) #f)))]
+			       #f)))]
                     [(fp-ftd& ,ftd)
                      (cond
                       [($ftd-compound? ftd)
                        ;; pass as pointer
 		       (let ([pointer-type (with-output-language (Ltype Type) `(fp-integer 32))])
 			 (loop (cons pointer-type (cdr types)) locs live* int* flt* isp fp-live-count
-			       (constant flonum-data-disp) #f))]
+			       #f))]
                       [else
                        ;; extract content and pass that content
 		       (let ([category ($ftd-atomic-category ftd)])
@@ -2415,9 +2539,7 @@
 						    [else `(fp-double-float)]))])
 			     (loop (cons unpacked-type (cdr types)) locs live* int* flt* isp fp-live-count
 				   ;; no floating displacement within pointer:
-				   0
-				   ;; in case of float, load as single-float:
-				   (= ($ftd-size ftd) 4)))]
+				   0))]
 			  [(and (memq category '(integer unsigned))
 				(fx= 8 ($ftd-size ftd)))
 			   (let ([int* (if (even? (length int*)) int* (cdr int*))])
@@ -2426,21 +2548,21 @@
                                  (loop (cdr types)
                                    (cons (load-indirect-int64-stack isp) locs)
                                    live* '() flt* (fx+ isp 8) fp-live-count
-				   (constant flonum-data-disp) #f))
+				   #f))
                                (loop (cdr types)
                                  (cons (load-indirect-int64-reg (cadr int*) (car int*)) locs)
                                  (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count
-				 (constant flonum-data-disp) #f)))]
+				 #f)))]
 			  [else
 			   (if (null? int*)
 			       (loop (cdr types)
                                  (cons (load-indirect-int-stack isp ($ftd-size ftd)) locs)
                                  live* '() flt* (fx+ isp 4) fp-live-count
-  			         (constant flonum-data-disp) #f)
+  			         #f)
 			       (loop (cdr types)
                                  (cons (load-indirect-int-reg (car int*) ($ftd-size ftd) category) locs)
                                  (cons (car int*) live*) (cdr int*) flt* isp fp-live-count
-				 (constant flonum-data-disp) #f))]))])]
+				 #f))]))])]
                     [else
                      (if (nanopass-case (Ltype Type) (car types)
                            [(fp-integer ,bits) (fx= bits 64)]
@@ -2452,20 +2574,20 @@
                                  (loop (cdr types)
                                    (cons (load-int64-stack isp) locs)
                                    live* '() flt* (fx+ isp 8) fp-live-count
-				   (constant flonum-data-disp) #f))
+				   #f))
                                (loop (cdr types)
                                  (cons (load-int64-reg (cadr int*) (car int*)) locs)
                                  (cons* (car int*) (cadr int*) live*) (cddr int*) flt* isp fp-live-count
-				 (constant flonum-data-disp) #f)))
+				 #f)))
                          (if (null? int*)
                              (loop (cdr types)
                                (cons (load-int-stack isp) locs)
                                live* '() flt* (fx+ isp 4) fp-live-count
-			       (constant flonum-data-disp) #f)
+			       #f)
                              (loop (cdr types)
                                (cons (load-int-reg (car int*)) locs)
                                (cons (car int*) live*) (cdr int*) flt* isp fp-live-count
-			       (constant flonum-data-disp) #f)))])))))
+			       #f)))])))))
 	(define do-indirect-result-from-registers
 	  (lambda (ftd offset)
 	    (let ([tmp %Carg8])
@@ -2474,8 +2596,9 @@
 	       ,(cond
 		 [(and (not (constant software-floating-point))
 		       (eq? 'float ($ftd-atomic-category ftd)))
-		  `(inline ,(make-info-loadfl %Cfpretval) ,(if (= 4 ($ftd-size ftd)) %store-single %store-double)
-			   ,tmp ,%zero (immediate 0))]
+                  (if (= 4 ($ftd-size ftd))
+                      (%inline store-double->single ,(%mref ,tmp ,%zero 0 fp) ,%Cfpretval)
+                      `(set! ,(%mref ,tmp ,%zero 0 fp) ,%Cfpretval))]
 		 [else
 		  (case ($ftd-size ftd)
 		    [(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,tmp ,%zero (immediate 0) ,%Cretval)]
@@ -2528,13 +2651,13 @@
 			;; stash extra argument on the stack to be retrieved after call and filled with the result:
 			(cons (load-int-stack fill-stash-offset) locs)]
 		       [else locs]))
-                    (lambda (t0)
+                    (lambda (t0 not-varargs?)
 		      (define (make-call result-live* result-fp-live-count)
 			(cond
 			 [adjust-active?
 			  (add-deactivate t0 deactivate-save-offset live* fp-live-count result-live* result-fp-live-count
 					  `(inline ,(make-info-kill*-live* result-live* live*) ,%c-call ,%deact))]
-			 [else `(inline ,(make-info-kill*-live* result-live* live*) ,%c-call ,t0)]))
+			 [else `(inline ,(make-info-kill*-live* (add-caller-save-registers result-live*) live*) ,%c-call ,t0)]))
 		      (if (constant software-floating-point)
                           (let ()
                             (define handle-64-bit
@@ -2590,22 +2713,17 @@
                               [else (make-call (reg-list %Cretval) 0)]))))
                     (nanopass-case (Ltype Type) result-type
                       [(fp-double-float)
-                       (lambda (lvalue)
+                       (lambda (lvalue) ; unboxed
                          (if (constant software-floating-point)
-                             (%seq
-                               (set! ,(%mref ,lvalue ,(constant flonum-data-disp)) ,%Cretval-high)
-                               (set! ,(%mref ,lvalue ,(fx+ (constant flonum-data-disp) 4)) ,%Cretval-low))
-                             `(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
-                                ,(%constant flonum-data-disp))))]
+                             `(set! ,lvalue ,(%inline fpcastfrom ,%Cretval-high ,%Cretval-low))
+                             `(set! ,lvalue ,%Cfpretval)))]
                       [(fp-single-float)
                        (lambda (lvalue)
                          (if (constant software-floating-point)
                              (%seq
                                (set! ,(%tc-ref ac0) ,%Cretval)
-                               (inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%tc ,%zero (immediate ,(constant tc-ac0-disp)))
-                               (inline ,(make-info-loadfl %flreg1) ,%store-double ,lvalue ,%zero ,(%constant flonum-data-disp)))
-                             `(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double
-                                ,lvalue ,%zero ,(%constant flonum-data-disp))))]
+                               (set! ,lvalue ,(%inline load-single->double ,(%mref ,%tc ,%zero ,(constant tc-ac0-disp) fp))))
+                             `(set! ,lvalue ,%Cfpretval)))]
                       [(fp-integer ,bits)
                        (case bits
                          [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%Cretval)))]
@@ -2748,15 +2866,13 @@
           (define load-double-stack
             (lambda (offset)
               (lambda (x) ; requires var
-                (%seq
-                  (inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
-                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%mref ,%sp ,%zero ,offset fp)))))
           (define load-soft-single-stack
             (lambda (offset)
               (lambda (x) ; requires var
-                (%seq
-                  (inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
-                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
           (define load-int-stack
             (lambda (type offset)
               (lambda (lvalue)
@@ -2790,8 +2906,8 @@
 		(%seq
 		 ;; Overwrite argument on stack with single-precision version
 		 ;; FIXME: is the callee allowed to do this if the argument is passed on the stack?
-		 (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,%sp ,%zero (immediate ,offset))
-		 (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset))
+		 (set! ,%fptmp1 ,(%mref ,%sp ,%zero ,offset fp))
+                 ,(%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,%fptmp1)
 		 (set! ,lvalue ,(%inline + ,%sp (immediate ,offset)))))))
           (define count-reg-args
             (lambda (types gp-reg-count fp-reg-count synthesize-first-argument?)
@@ -2956,7 +3072,7 @@
               (if (null? regs)
                   `(nop)
                   (let f ([regs regs] [offset offset])
-                    (let ([inline `(inline ,(make-info-loadfl (car regs)) ,%store-double ,%Csp ,%zero (immediate ,offset))])
+                    (let ([inline `(set! ,(%mref ,%Csp ,%zero ,offset fp) ,(car regs))])
                       (let ([regs (cdr regs)])
                         (if (null? regs)
                             inline
@@ -2980,8 +3096,8 @@
 		    (values
 		     (lambda ()
 		       (case ($ftd-size ftd)
-			 [(4) `(inline ,(make-info-loadfl %Cfpretval) ,%load-single ,%sp ,%zero (immediate ,return-space-offset))]
-			 [else `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,%sp ,%zero (immediate ,return-space-offset))]))
+			 [(4) `(set! ,%Cfpretval ,(%inline load-single->double ,(%mref ,%sp ,%zero ,return-space-offset fp)))]
+			 [else `(set! ,%Cfpretval ,(%mref ,%sp ,%zero ,return-space-offset fp))]))
 		     '()
 		     1)]
 		   [else
@@ -3010,12 +3126,12 @@
 		       0)])])]
                 [(fp-double-float)
                  (values (lambda (x)
-			   `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)))
+                           `(set! ,%Cfpretval ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)))
 			 '()
 			 1)]
                 [(fp-single-float)
                  (values (lambda (x)
-			   `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)))
+                           `(set! ,%Cfpretval ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)))
 			 '()
 			 1)]
                 [(fp-void)
diff --git a/src/ChezScheme/s/ppc32le.def b/src/ChezScheme/s/ppc32le.def
index 0b83600c2a..74015aa860 100644
--- a/src/ChezScheme/s/ppc32le.def
+++ b/src/ChezScheme/s/ppc32le.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 14)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/primdata.ss b/src/ChezScheme/s/primdata.ss
index 520fbf9f0c..182cde33fa 100644
--- a/src/ChezScheme/s/primdata.ss
+++ b/src/ChezScheme/s/primdata.ss
@@ -91,11 +91,11 @@
 (define-symbol-flags* ([libraries (rnrs) (rnrs arithmetic flonums)] [flags primitive proc])
   (flonum? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (real->flonum [sig [(real) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])             ; restricted to 2+ arguments
-  (fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])             ; restricted to 2+ arguments
-  (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])            ; restricted to 2+ arguments
-  (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])             ; restricted to 2+ arguments
-  (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])            ; restricted to 2+ arguments
+  (fl=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])  ; restricted to 2+ arguments
+  (fl<? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])  ; restricted to 2+ arguments
+  (fl<=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments
+  (fl>? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])  ; restricted to 2+ arguments
+  (fl>=? [sig [(flonum flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments]) ; restricted to 2+ arguments
   (flinteger? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
   (flzero? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
   (flpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
@@ -107,11 +107,11 @@
   (flnan? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
   (flmax [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
   (flmin [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
-  (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
-  (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
-  (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs])
-  (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (fl* [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
+  (fl+ [sig [(flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
+  (fl- [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
+  (fl/ [sig [(flonum flonum ...) -> (flonum)]] [flags arith-op partial-folder safeongoodargs unboxed-arguments])
+  (flabs [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
   (fldiv-and-mod [sig [(flonum flonum) -> (flonum flonum)]] [flags discard])
   (fldiv [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
   (flmod [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
@@ -120,20 +120,20 @@
   (flmod0 [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard])
   (flnumerator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
   (fldenominator [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard])
-  (flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs])
+  (flfloor [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flceiling [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (fltruncate [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flround [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flexp [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (fllog [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flsin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flcos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (fltan [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flasin [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flacos [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flatan [sig [(flonum) (flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flsqrt [sig [(flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
+  (flexpt [sig [(flonum flonum) -> (flonum)]] [flags arith-op mifoldable discard safeongoodargs unboxed-arguments])
   (make-no-infinities-violation [sig [() -> (condition)]] [flags pure unrestricted alloc])
   (no-infinities-violation? [sig [(ptr) -> (ptr)]] [flags pure unrestricted mifoldable discard])
   (make-no-nans-violation [sig [() -> (condition)]] [flags pure unrestricted alloc])
@@ -979,9 +979,11 @@
   (gensym-prefix [sig [() -> (ptr)] [(ptr) -> (void)]] [flags unrestricted])
   (heap-reserve-ratio [sig [() -> (number)] [(sub-number) -> (void)]] [flags])
   (import-notify [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
+  (in-place-minimum-generation [sig [() -> (ufixnum)] [(sub-ufixnum) -> (void)]] [flags])
   (interaction-environment [sig [() -> (environment)] [(environment) -> (void)]] [flags ieee r5rs])
   (internal-defines-as-letrec* [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
   (invoke-library [sig [(ptr) -> (void)]] [flags true])
+  (keep-live [sig [(ptr) -> (void)]] [flags])
   (keyboard-interrupt-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
   (library-directories [sig [() -> (list)] [(sub-ptr) -> (void)]] [flags])
   (library-exports [sig [(sub-list) -> (list)]] [flags])
@@ -1160,11 +1162,13 @@
   (box [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (box-cas! [sig [(box ptr ptr) -> (boolean)]] [flags])
+  (box-immobile [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (box-immutable [sig [(ptr) -> (box)]] [flags unrestricted alloc])
   (break [sig [(ptr ...) -> (ptr ...)]] [flags])
   (bwp-object? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard])
   (bytes-allocated [sig [() -> (uint)] [(ptr) -> (uint)] [(ptr maybe-sub-symbol) -> (uint)]] [flags alloc])
   (bytes-deallocated [sig [() -> (uint)]] [flags unrestricted alloc])
+  (bytes-finalized [sig [() -> (uint)]] [flags unrestricted alloc])
   (bytevector [sig [(u8/s8 ...) -> (bytevector)]] [flags alloc cp02])
   (bytevector->s8-list [sig [(bytevector) -> (list)]] [flags alloc])
   (bytevector-truncate! [sig [(bytevector length) -> (bytevector)]] [flags true])
@@ -1320,14 +1324,14 @@
   (file-symbolic-link? [sig [(pathname) -> (boolean)]] [flags discard])
   (fllp [sig [(flonum) -> (ufixnum)]] [flags arith-op mifoldable discard safeongoodargs])
   (fl-make-rectangular [sig [(flonum flonum) -> (inexactnum)]] [flags arith-op mifoldable discard safeongoodargs])
-  (flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02])
+  (flonum->fixnum [sig [(flonum) -> (fixnum)]] [flags arith-op cp02 unboxed-arguments])
   (flnonpositive? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
   (flnonnegative? [sig [(flonum) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])
-  (fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
-  (fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
-  (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])  ; not restricted to 2+ arguments
-  (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])   ; not restricted to 2+ arguments
-  (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs])  ; not restricted to 2+ arguments
+  (fl= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])   ; not restricted to 2+ arguments
+  (fl< [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])   ; not restricted to 2+ arguments
+  (fl<= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])  ; not restricted to 2+ arguments
+  (fl> [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])   ; not restricted to 2+ arguments
+  (fl>= [sig [(flonum flonum ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs unboxed-arguments])  ; not restricted to 2+ arguments
   (flush-output-port [sig [() (output-port) -> (void)]] [flags true])   ; not restricted to 1 argument
   (foreign-entry? [sig [(string) -> (boolean)]] [flags discard])
   (foreign-entry [sig [(string) -> (uptr)]] [flags discard true])
@@ -1435,6 +1439,7 @@
   (last-pair [sig [(pair) -> ((ptr . ptr))]] [flags mifoldable discard])
   (list* [sig [(ptr) -> (ptr)] [(ptr ptr ptr ...) -> ((ptr . ptr))]] [flags unrestricted discard cp02])
   (list->fxvector [sig [(sub-list) -> (fxvector)]] [flags alloc])
+  (list-assuming-immutable? [sig [(ptr) -> (boolean)]] [flags unrestricted mifoldable discard])
   (list-copy [sig [(list) -> (list)]] [flags alloc])
   (list-head [sig [(sub-ptr sub-index) -> (list)]] [flags alloc])
   (literal-identifier=? [sig [(identifier identifier) -> (boolean)]] [flags pure mifoldable discard cp03])
@@ -1473,6 +1478,8 @@
   (make-fxvector [sig [(length) (length fixnum) -> (fxvector)]] [flags alloc])
   (make-guardian [sig [() (ptr) -> (procedure)]] [flags alloc cp02])
   (make-hash-table [sig [() (ptr) -> (old-hash-table)]] [flags unrestricted alloc])
+  (make-immobile-bytevector [sig [(length) (length u8/s8) -> (bytevector)]] [flags alloc])
+  (make-immobile-vector [sig [(length) (length ptr) -> (vector)]] [flags alloc])
   (make-input-port [sig [(procedure string) -> (textual-input-port)]] [flags alloc])
   (make-input/output-port [sig [(procedure string string) -> (textual-input/output-port)]] [flags alloc])
   (make-list [sig [(length) (length ptr) -> (list)]] [flags alloc])
@@ -1483,7 +1490,7 @@
   (make-phantom-bytevector [sig [(uptr) -> (phantom-bytevector)]] [flags true])
   (make-pseudo-random-generator [sig [() -> (pseudo-random-generator)]] [flags true])
   (make-record-type [sig [(sub-ptr sub-list) (maybe-rtd sub-ptr sub-list) -> (rtd)]] [flags pure alloc cp02])
-  (make-record-type-descriptor* [sig [(symbol maybe-rtd maybe-symbol ptr ptr fixnum exact-integer) -> (rtd)]] [flags pure alloc cp02])
+  (make-record-type-descriptor* [sig [(symbol maybe-rtd maybe-symbol ptr ptr ufixnum exact-integer) -> (rtd)]] [flags pure alloc cp02])
   (make-source-condition [sig [(ptr) -> (condition)]] [flags pure unrestricted mifoldable discard])
   (make-source-file-descriptor [sig [(string binary-input-port) (string binary-input-port ptr) -> (sfd)]] [flags true])
   (make-source-object [sig [(sfd uint uint) (sfd uint uint nzuint nzuint) -> (source-object)]] [flags pure true mifoldable discard])
@@ -1497,6 +1504,8 @@
   (maybe-compile-file [sig [(pathname) (pathname pathname) -> (void)]] [flags true])
   (maybe-compile-library [sig [(pathname) (pathname pathname) -> (void)]] [flags true])
   (maybe-compile-program [sig [(pathname) (pathname pathname) -> (void)]] [flags true])
+  (memory-order-acquire [sig [() -> (void)]] [flags true])
+  (memory-order-release [sig [() -> (void)]] [flags true])
   (merge [sig [(procedure list list) -> (list)]] [flags true])
   (merge! [sig [(procedure list list) -> (list)]] [flags true])
   (mkdir [sig [(pathname) (pathname sub-uint) -> (void)]] [flags])
@@ -1863,11 +1872,15 @@
   ($continuation? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($continuation-link [flags single-valued])
   ($continuation-return-code [flags single-valued])
+  ($continuation-return-frame-words [flags single-valued])
   ($continuation-return-livemask [flags single-valued])
   ($continuation-return-offset [flags single-valued])
   ($continuation-stack-clength [flags single-valued])
   ($continuation-stack-length [flags single-valued])
   ($continuation-stack-ref [flags single-valued])
+  ($continuation-stack-return-code [flags single-valued])
+  ($continuation-stack-return-offset [flags single-valued])
+  ($continuation-stack-return-frame-words [flags single-valued])
   ($continuation-winders [flags single-valued])
   ($continuation-attachments [flags single-valued])
   ($cp0 [flags single-valued])
@@ -2091,6 +2104,7 @@
   ($ftd-atomic-category [flags single-valued])
   ($ftd-compound? [sig [(sub-ptr) -> (boolean)]] [flags discard])
   ($ftd-size [flags single-valued])
+  ($ftd-unsigned? [flags single-valued])
   ($ftd->members [flags single-valued])
   ($ftype-guardian-oops [flags])
   ($ftype-pointer? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
@@ -2149,10 +2163,11 @@
   ($invoke-library [flags single-valued])
   ($invoke-program [flags single-valued])
   ($io-init [flags single-valued])
-  ($keep-live [flags single-valued])
   ($last-new-vector-element [flags single-valued])
   ($lexical-error [flags single-valued])
   ($library-search [flags])
+  ($list-bits-ref [flags single-valued])
+  ($list-bits-set! [flags single-valued])
   ($list-length [flags single-valued])
   ($load-library [flags single-valued])
   ($locate-source [flags])
@@ -2286,6 +2301,7 @@
   ($sc-put-property! [flags single-valued])
   ($script [flags single-valued])
   ($sealed-record? [sig [(ptr rtd) -> (boolean)]] [flags pure mifoldable cptypes2]) ; first argument may be not a record
+  ($seginfo [flags single-valued])
   ($seginfo-generation [flags single-valued])
   ($seginfo-space [flags single-valued])
   ($set-code-byte! [flags single-valued])
diff --git a/src/ChezScheme/s/prims.ss b/src/ChezScheme/s/prims.ss
index 14ffc67bfc..2cf077a0e7 100644
--- a/src/ChezScheme/s/prims.ss
+++ b/src/ChezScheme/s/prims.ss
@@ -321,6 +321,18 @@
          ($oops who "~s is not a valid vector length" n))
        (make-vector n)]))
 
+(define-who make-immobile-vector
+  (let ([$make-immobile-vector (foreign-procedure "(cs)make_immobile_vector" (uptr ptr) ptr)])
+   (case-lambda
+      [(n x)
+       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
+         ($oops who "~s is not a valid vector length" n))
+       ($make-immobile-vector n x)]
+      [(n)
+       (unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
+         ($oops who "~s is not a valid vector length" n))
+       ($make-immobile-vector n 0)])))
+
 (define $make-eqhash-vector
   (case-lambda
     [(n)
@@ -604,6 +616,36 @@
          ($oops '$continuation-return-offset "~s is not a continuation" x))
       ($continuation-return-offset x)))
 
+(define-who $continuation-return-frame-words
+   (lambda (x)
+      (unless ($continuation? x)
+         ($oops who "~s is not a continuation" x))
+      ($continuation-return-frame-words x)))
+
+(define-who $continuation-stack-return-code
+   (lambda (x i)
+      (unless ($continuation? x)
+         ($oops who "~s is not a continuation" x))
+      (unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x)))
+         ($oops who "invalid index ~s" i))
+      ($continuation-stack-return-code x i)))
+
+(define-who $continuation-stack-return-offset
+   (lambda (x i)
+      (unless ($continuation? x)
+         ($oops who "~s is not a continuation" x))
+      (unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x)))
+         ($oops who "invalid index ~s" i))
+      ($continuation-stack-return-offset x i)))
+
+(define-who $continuation-stack-return-frame-words
+   (lambda (x i)
+      (unless ($continuation? x)
+         ($oops who "~s is not a continuation" x))
+      (unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x)))
+         ($oops who "invalid index ~s" i))
+      ($continuation-stack-return-frame-words x i)))
+
 (define void
    (lambda ()
       (void)))
@@ -1125,6 +1167,14 @@
         ($top-level-bound? s)
         ($oops '$top-level-bound? "~s is not a symbol" s))))
 
+(define memory-order-acquire
+  (lambda ()
+    (memory-order-acquire)))
+
+(define memory-order-release
+  (lambda ()
+    (memory-order-release)))
+
 (define-who $bignum-length
   (lambda (n)
     (unless (bignum? n) ($oops who "~s is not a bignum" n))
@@ -1279,6 +1329,8 @@
 
 (define box-immutable (lambda (x) (box-immutable x)))
 
+(define box-immobile (foreign-procedure "(cs)box_immobile" (ptr) ptr))
+
 (define unbox
    (lambda (b)
       (if (box? b)
@@ -1804,7 +1856,7 @@
        (when (eq? addr 0)
          ($oops 'mutex-acquire "mutex is defunct"))
        (let ([r ((if block? ma ma-nb) addr)])
-         ($keep-live m)
+         (keep-live m)
          r))]))
 
 (set! mutex-release
@@ -1849,8 +1901,8 @@
       (when (eq? maddr 0)
         ($oops 'condition-wait "mutex is defunct"))
       (let ([r (cw caddr maddr t)])
-        ($keep-live c)
-        ($keep-live m)
+        (keep-live c)
+        (keep-live m)
         r))]))
 
 (set! condition-broadcast
@@ -1995,12 +2047,21 @@
 (define $maybe-seginfo
   (lambda (x)
     ($maybe-seginfo x)))
+(define $seginfo
+  (lambda (x)
+    ($seginfo x)))
 (define $seginfo-generation
   (lambda (x)
     ($seginfo-generation x)))
 (define $seginfo-space
   (lambda (x)
     ($seginfo-space x)))
+(define-who $list-bits-ref
+  (lambda (x)
+    (unless (pair? x) ($oops who "~s is not a pair" x))
+    ($list-bits-ref x)))
+(define-who $list-bits-set!
+  (foreign-procedure "(cs)list_bits_set" (ptr iptr) void))
 
 (let ()
   (define $phantom-bytevector-adjust!
@@ -2538,9 +2599,9 @@
   (lambda ()
     (#3%$read-time-stamp-counter)))
 
-(define $keep-live
+(define keep-live
   (lambda (x)
-    (#2%$keep-live x)))
+    (#2%keep-live x)))
 
 (when-feature windows
 (let ()
diff --git a/src/ChezScheme/s/print.ss b/src/ChezScheme/s/print.ss
index 09758ee691..3e6c216f1d 100644
--- a/src/ChezScheme/s/print.ss
+++ b/src/ChezScheme/s/print.ss
@@ -1058,7 +1058,15 @@ floating point returns with (1 0 -1 ...).
                    (if (fx< s 0)
                        (write-char #\- p)
                        (when force-sign (write-char #\+ p)))
-                   (if (or (fx> r 10) (fx< -4 e 10))
+                   (if (or (fx> r 10) (cond
+                                        [(fx< e -4) #f]
+                                        [(fx< e 14) #t]
+                                        [else
+                                         (let ([digits (let loop ([ls ls] [digits 0])
+                                                         (if (fx< (car ls) 0)
+                                                             digits
+                                                             (loop (cdr ls) (fx+ digits 1))))])
+                                           (fx< (fx- e digits) 3))]))
                        (free-format e ls p)
                        (free-format-exponential e ls r p))))
               (cond
diff --git a/src/ChezScheme/s/setup.ss b/src/ChezScheme/s/setup.ss
index feac02a6be..9355e44969 100644
--- a/src/ChezScheme/s/setup.ss
+++ b/src/ChezScheme/s/setup.ss
@@ -15,6 +15,7 @@
 
 (include "debug.ss")
 
+(unless (getenv "DEBUGNOW")
 (base-exception-handler
   (lambda (c)
     (fresh-line)
@@ -26,3 +27,5 @@
   (lambda ()
     (display "interrupted---aborting\n")
     (reset)))
+)
+
diff --git a/src/ChezScheme/s/syntax.ss b/src/ChezScheme/s/syntax.ss
index 4c185b439f..425f30410b 100644
--- a/src/ChezScheme/s/syntax.ss
+++ b/src/ChezScheme/s/syntax.ss
@@ -8920,39 +8920,40 @@
     (define squawk
       (lambda (x)
         (syntax-error x (format "invalid ~s convention" who))))
-    (let loop ([conv* conv*] [accum '()] [keep-accum '()])
+    (let loop ([conv* conv*] [selected #f] [accum '()] [keep-accum '()])
       (cond
         [(null? conv*) (datum->syntax #'filter-conv keep-accum)]
         [else
          (let* ([orig-c (car conv*)]
-                [c (syntax->datum orig-c)]
-                [c (cond
-                     [(not c) #f]
-                     [(eq? c '__collect_safe) 'adjust-active]
-                     [else
-                      (case ($target-machine)
-                        [(i3nt ti3nt)
-                         (case c
-                           [(__stdcall) 'i3nt-stdcall]
-                           [(__cdecl) #f]
-                           [(__com) 'i3nt-com]
-                           [else (squawk orig-c)])]
-                        [(ppcnt)
-                         (case c
-                           [(__stdcall __cdecl) #f]
-                           [else (squawk orig-c)])]
-                        [else (squawk orig-c)])])])
-           (when (member c accum)
-             (syntax-error orig-c (format "redundant ~s convention" who)))
-           (unless (or (null? accum)
-                       (eq? c 'adjust-active)
-                       (and (eq? 'adjust-active (car accum))
-                            (null? (cdr accum))))
-             (syntax-error orig-c (format "conflicting ~s convention" who)))
-           (loop (cdr conv*) (cons c accum)
-                 (if c
-                     (cons c keep-accum)
-                     keep-accum)))]))))
+                [c (syntax->datum orig-c)])
+           (let-values ([(c select?)
+                         (cond
+                           [(not c) (values #f #f)]
+                           [(eq? c '__collect_safe) (values 'adjust-active #f)]
+                           [(eq? c '__varargs) (values 'varargs #f)]
+                           [else
+                            (values
+                             (case ($target-machine)
+                               [(i3nt ti3nt)
+                                (case c
+                                  [(__stdcall) 'i3nt-stdcall]
+                                  [(__cdecl) #f]
+                                  [(__com) 'i3nt-com]
+                                  [else (squawk orig-c)])]
+                               [(ppcnt)
+                                (case c
+                                  [(__stdcall __cdecl) #f]
+                                  [else (squawk orig-c)])]
+                               [else (squawk orig-c)])
+                             #t)])])
+             (when (member c accum)
+               (syntax-error orig-c (format "redundant ~s convention" who)))
+             (when (and select? selected)
+               (syntax-error orig-c (format "conflicting ~s convention" who)))
+             (loop (cdr conv*) (if select? c selected) (cons c accum)
+                   (if c
+                       (cons c keep-accum)
+                       keep-accum))))]))))
 
 (define $make-foreign-procedure
   (lambda (who conv* foreign-name ?foreign-addr type* result-type)
@@ -8960,6 +8961,9 @@
       (define (check-strings-allowed)
         (when (memq 'adjust-active (syntax->datum conv*))
           ($oops who "string argument not allowed with __collect_safe procedure")))
+      (define (check-floats-allowed)
+        (when (memq 'varargs (syntax->datum conv*))
+          ($oops who "float argument not allowed for __varargs procedure")))
       (with-syntax ([conv* conv*]
                     [foreign-name foreign-name]
                     [?foreign-addr ?foreign-addr]
@@ -9056,6 +9060,9 @@
                                                         ($fp-string->utf32 x 'big)
                                                         (err ($moi) x)))))
                                        (u32*))]
+                                   [(single-float)
+                                    (check-floats-allowed)
+                                    #f]
                                    [else #f])
                                  (if (or ($ftd? type) ($ftd-as-box? type))
                                      (let ([ftd (if ($ftd? type) type (unbox type))])
@@ -9151,6 +9158,9 @@
       (define (check-strings-allowed)
         (when (memq 'adjust-active (syntax->datum conv*))
           ($oops who "string result not allowed with __collect_safe callable")))
+      (define (check-floats-allowed)
+        (when (memq 'varargs (syntax->datum conv*))
+          ($oops who "float argument not allowed for __varargs procedure")))
       (with-syntax ([conv* conv*] [?proc ?proc])
         (with-syntax ([((actual (t ...) (arg ...)) ...)
                        (map
@@ -9240,6 +9250,9 @@
                                     #`((mod x #x100000000000000)
                                        (x)
                                        (unsigned-64)))]
+                                 [(single-float)
+                                  (check-floats-allowed)
+                                  #f]
                                  [else #f])
                                (with-syntax ([(x) (generate-temporaries #'(*))])
                                  #`(x (x) (#,(datum->syntax #'foreign-callable type))))))
diff --git a/src/ChezScheme/s/ta6fb.def b/src/ChezScheme/s/ta6fb.def
index f92d222abe..72f79b4d44 100644
--- a/src/ChezScheme/s/ta6fb.def
+++ b/src/ChezScheme/s/ta6fb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/ta6le.def b/src/ChezScheme/s/ta6le.def
index af06b6a07f..ecdc95ffad 100644
--- a/src/ChezScheme/s/ta6le.def
+++ b/src/ChezScheme/s/ta6le.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/ta6nb.def b/src/ChezScheme/s/ta6nb.def
index 9917918934..3cf1d39ad8 100644
--- a/src/ChezScheme/s/ta6nb.def
+++ b/src/ChezScheme/s/ta6nb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/ta6nt.def b/src/ChezScheme/s/ta6nt.def
index 567f30463b..8e4674bbb4 100644
--- a/src/ChezScheme/s/ta6nt.def
+++ b/src/ChezScheme/s/ta6nt.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long long int")
 (define-constant typedef-uptr "unsigned long long int")
diff --git a/src/ChezScheme/s/ta6ob.def b/src/ChezScheme/s/ta6ob.def
index 3fe1a6c169..3d1e019f4d 100644
--- a/src/ChezScheme/s/ta6ob.def
+++ b/src/ChezScheme/s/ta6ob.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/ta6osx.def b/src/ChezScheme/s/ta6osx.def
index b0fba2c935..438b13b681 100644
--- a/src/ChezScheme/s/ta6osx.def
+++ b/src/ChezScheme/s/ta6osx.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/ta6s2.def b/src/ChezScheme/s/ta6s2.def
index 326db66e1e..4c91ab8d9c 100644
--- a/src/ChezScheme/s/ta6s2.def
+++ b/src/ChezScheme/s/ta6s2.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 5)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "long int")
 (define-constant typedef-uptr "unsigned long int")
diff --git a/src/ChezScheme/s/tarm32le.def b/src/ChezScheme/s/tarm32le.def
new file mode 100644
index 0000000000..5426a04e51
--- /dev/null
+++ b/src/ChezScheme/s/tarm32le.def
@@ -0,0 +1,52 @@
+;;; tarm32le.def
+;;; Copyright 1984-2017 Cisco Systems, Inc.
+;;; 
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;; http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-constant machine-type (constant machine-type-tarm32le))
+(define-constant architecture 'arm32)
+(define-constant address-bits 32)
+(define-constant ptr-bits 32)
+(define-constant int-bits 32)
+(define-constant short-bits 16)
+(define-constant long-bits 32)
+(define-constant long-long-bits 64)
+(define-constant size_t-bits 32)
+(define-constant ptrdiff_t-bits 32)
+(define-constant wchar-bits 32)
+(define-constant time-t-bits 32)
+(define-constant max-float-alignment 8)
+(define-constant max-integer-alignment 8)
+(define-constant asm-arg-reg-max 5)
+(define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
+(define-constant typedef-ptr "void *")
+(define-constant typedef-iptr "int")
+(define-constant typedef-uptr "unsigned int")
+(define-constant typedef-i8 "char")
+(define-constant typedef-u8 "unsigned char")
+(define-constant typedef-i16 "short")
+(define-constant typedef-u16 "unsigned short")
+(define-constant typedef-i32 "int")
+(define-constant typedef-u32 "unsigned int")
+(define-constant typedef-i64 "long long")
+(define-constant typedef-u64 "unsigned long long")
+(define-constant typedef-string-char "unsigned int")
+(define-constant native-endianness 'little)
+(define-constant unaligned-floats #f)
+(define-constant unaligned-integers #t)
+(define-constant integer-divide-instruction #f)
+(define-constant popcount-instruction #f)
+(define-constant software-floating-point #f)
+(define-constant segment-table-levels 1)
+(features iconv expeditor pthreads)
diff --git a/src/ChezScheme/s/tarm64le.def b/src/ChezScheme/s/tarm64le.def
new file mode 100644
index 0000000000..2a11ab0403
--- /dev/null
+++ b/src/ChezScheme/s/tarm64le.def
@@ -0,0 +1,39 @@
+;;; tarm64le.def
+
+(define-constant machine-type (constant machine-type-tarm64le))
+(define-constant architecture 'arm64)
+(define-constant address-bits 64)
+(define-constant ptr-bits 64)
+(define-constant int-bits 32)
+(define-constant short-bits 16)
+(define-constant long-bits 64)
+(define-constant long-long-bits 64)
+(define-constant size_t-bits 64)
+(define-constant ptrdiff_t-bits 64)
+(define-constant wchar-bits 32)
+(define-constant time-t-bits 64)
+(define-constant max-float-alignment 8)
+(define-constant max-integer-alignment 8)
+(define-constant asm-arg-reg-max 9)
+(define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
+(define-constant typedef-ptr "void *")
+(define-constant typedef-iptr "long")
+(define-constant typedef-uptr "unsigned long")
+(define-constant typedef-i8 "char")
+(define-constant typedef-u8 "unsigned char")
+(define-constant typedef-i16 "short")
+(define-constant typedef-u16 "unsigned short")
+(define-constant typedef-i32 "int")
+(define-constant typedef-u32 "unsigned int")
+(define-constant typedef-i64 "long")
+(define-constant typedef-u64 "unsigned long")
+(define-constant typedef-string-char "unsigned int")
+(define-constant native-endianness 'little)
+(define-constant unaligned-floats #f)
+(define-constant unaligned-integers #t)
+(define-constant integer-divide-instruction #f)
+(define-constant popcount-instruction #f)
+(define-constant software-floating-point #f)
+(define-constant segment-table-levels 3)
+(features iconv expeditor pthreads)
diff --git a/src/ChezScheme/s/ti3fb.def b/src/ChezScheme/s/ti3fb.def
index 18cc4bc36e..9752f79f2f 100644
--- a/src/ChezScheme/s/ti3fb.def
+++ b/src/ChezScheme/s/ti3fb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/ti3le.def b/src/ChezScheme/s/ti3le.def
index e25b8422a8..a5db0b2b1f 100644
--- a/src/ChezScheme/s/ti3le.def
+++ b/src/ChezScheme/s/ti3le.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/ti3nb.def b/src/ChezScheme/s/ti3nb.def
index 127f7c0a05..4cd1fc60f4 100644
--- a/src/ChezScheme/s/ti3nb.def
+++ b/src/ChezScheme/s/ti3nb.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/ti3nt.def b/src/ChezScheme/s/ti3nt.def
index 4cbe1486bf..391625d27a 100644
--- a/src/ChezScheme/s/ti3nt.def
+++ b/src/ChezScheme/s/ti3nt.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/ti3ob.def b/src/ChezScheme/s/ti3ob.def
index 4b285d71b7..ba8fa99c1f 100644
--- a/src/ChezScheme/s/ti3ob.def
+++ b/src/ChezScheme/s/ti3ob.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/ti3osx.def b/src/ChezScheme/s/ti3osx.def
index 7427f15e08..47ffb4ed7f 100644
--- a/src/ChezScheme/s/ti3osx.def
+++ b/src/ChezScheme/s/ti3osx.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/ti3s2.def b/src/ChezScheme/s/ti3s2.def
index be35e15492..4b02a94bf6 100644
--- a/src/ChezScheme/s/ti3s2.def
+++ b/src/ChezScheme/s/ti3s2.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 4)
 (define-constant asm-arg-reg-max 1)
 (define-constant asm-arg-reg-cnt 1)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/tppc32le.def b/src/ChezScheme/s/tppc32le.def
index 5951c0e924..5f6e225407 100644
--- a/src/ChezScheme/s/tppc32le.def
+++ b/src/ChezScheme/s/tppc32le.def
@@ -29,6 +29,7 @@
 (define-constant max-integer-alignment 8)
 (define-constant asm-arg-reg-max 14)
 (define-constant asm-arg-reg-cnt 3)
+(define-constant asm-fpreg-max 2)
 (define-constant typedef-ptr "void *")
 (define-constant typedef-iptr "int")
 (define-constant typedef-uptr "unsigned int")
diff --git a/src/ChezScheme/s/x86.ss b/src/ChezScheme/s/x86.ss
index a59ca5bd5e..5a2904bd42 100644
--- a/src/ChezScheme/s/x86.ss
+++ b/src/ChezScheme/s/x86.ss
@@ -16,26 +16,28 @@
 ;;; SECTION 1: registers
 (define-registers
   (reserved
-    [%tc  %edi #t 7]
-    [%sfp %ebp #t 5]
+    [%tc  %edi #t 7 uptr]
+    [%sfp %ebp #t 5 uptr]
     #;[%ap]
     #;[%esp]
     #;[%eap]
     #;[%trap])
   (allocable ; keep in sync with all-but-byte-registers below
-    [%ac0 %edx #f 2]
-    [%xp  %ecx #f 1]
-    [%ts  %eax #f 0]
-    [%td  %ebx #t 3]
+    [%ac0 %edx #f 2 uptr]
+    [%xp  %ecx #f 1 uptr]
+    [%ts  %eax #f 0 uptr]
+    [%td  %ebx #t 3 uptr]
     #;[%ret]
     #;[%cp]
     #;[%ac1]
     #;[%yp]
-    [%esi      #t 6])
+    [%esi      #t 6 uptr]
+    [%fp1      #f 2 fp]
+    [%fp2      #f 3 fp])
   (machine-dependent
-    [%flreg1   #f 0]
-    [%flreg2   #f 1]
-    [%sp       #t 4]
+    [%fptmp1   #f 0 fp]
+    [%fptmp2   #f 1 fp]
+    [%sp       #t 4 uptr]
     #;[%esi      #f 6]))
 
 ;;; SECTION 2: instructions
@@ -66,6 +68,18 @@
     (lambda (x)
       (or (lmem? x) (literal@? x))))
 
+  (define fpmem?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
+        [else #f])))
+
+  (define-syntax mem-of-type?
+    (lambda (stx)
+      (syntax-case stx (mem fpmem)
+        [(_ mem e) #'(lmem? e)]
+        [(_ fpmem e) #'(fpmem? e)])))
+
   (define real-imm32?
     (lambda (x)
       (nanopass-case (L15c Triv) x
@@ -100,12 +114,12 @@
     (lambda (a k)
       (nanopass-case (L15c Triv) a
         ; NOTE: x86_64 and risc arch's will need to deal with limitations on the offset
-        [(mref ,lvalue0 ,lvalue1 ,imm)
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type)
          (lvalue->ur lvalue0
            (lambda (x0)
              (lvalue->ur lvalue1
                (lambda (x1)
-                 (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))))])))
+                 (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))))])))
 
   (define mem->mem
     (lambda (a k)
@@ -117,13 +131,15 @@
     (syntax-rules ()
       [(_ ?a ?aty*)
        (let ([a ?a] [aty* ?aty*])
-         (or (memq 'ur aty*)
+         (or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
+             (and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
              (or (and (memq 'imm32 aty*) (imm32? a))
                  (and (memq 'imm aty*) (imm? a))
                  (and (memq 'zero aty*) (imm0? a))
                  (and (memq 'real-imm32 aty*) (real-imm32? a))
                  (and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
-                 (and (memq 'mem aty*) (mem? a)))))]))
+                 (and (memq 'mem aty*) (mem? a))
+                 (and (memq 'fpmem aty*) (fpmem? a)))))]))
 
   (define-syntax coerce-opnd ; passes k something compatible with aty*
     (syntax-rules ()
@@ -131,6 +147,7 @@
        (let ([a ?a] [aty* ?aty*] [k ?k])
          (cond
            [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
+           [(and (memq 'fpmem aty*) (fpmem? a)) (mem->mem a k)]
            [(and (memq 'imm32 aty*) (imm32? a)) (k (imm->imm a))]
            [(and (memq 'imm aty*) (imm? a)) (k (imm->imm a))]
            [(and (memq 'zero aty*) (imm0? a)) (k (imm->imm a))]
@@ -152,6 +169,18 @@
                        (build-set! ,u ,a)
                        (k u)))))]
               [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
+           [(memq 'fpur aty*)
+            (cond
+              [(fpur? a) (k a)]
+              [(fpmem? a)
+               (mem->mem a
+                 (lambda (a)
+                   (let ([u (make-tmp 'u 'fp)])
+                     (seq
+                       (build-set! ,u ,a)
+                       (k u)))))]
+              [else
+               (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
            [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
 
   (define set-ur=mref
@@ -212,22 +241,29 @@
                         [(mref? c)
                          (nanopass-case (L15c Triv) c
                            ; NOTE: x86_64 and risc arch's will need to deal with limitations on the offset
-                           [(mref ,lvalue0 ,lvalue1 ,imm)
+                           [(mref ,lvalue0 ,lvalue1 ,imm ,type)
                             (lvalue->ur lvalue0
                               (lambda (x0)
                                 (lvalue->ur lvalue1
                                   (lambda (x1)
                                     (let ([u (make-tmp 'u)])
                                       (seq
-                                        (build-set! ,u (mref ,x0 ,x1 ,imm))
+                                        (build-set! ,u (mref ,x0 ,x1 ,imm ,type))
                                         (#,k u b)
-                                        (build-set! (mref ,x0 ,x1 ,imm) ,u)))))))])]
+                                        (build-set! (mref ,x0 ,x1 ,imm ,type) ,u)))))))])]
                         [else (sorry! '#,(datum->syntax #'* who) "unexpected operand ~s" c)])))
                   (next c a b)))))
 
+      (define mem-type?
+        (lambda (t)
+          (syntax-case t (mem fpmem)
+            [mem #t]
+            [fpmem #t]
+            [else #f])))
+
       (define make-value-clause
         (lambda (fmt)
-          (syntax-case fmt (mem ur xp)
+          (syntax-case fmt (mem ur fpur xp fpmem)
             [(op (c mem) (a ?c) (b bty* ...))
              (bound-identifier=? #'?c #'c)
              (acsame-mem #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
@@ -240,9 +276,10 @@
             [(op (c ur) (a aty* ...) (b ?c))
              (bound-identifier=? #'?c #'c)
              (acsame-ur #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
-            [(op (c mem) (a aty ...) (b bty ...))
+            [(op (c xmem) (a aty ...) (b bty ...))
+             (mem-type? #'xmem)
              #`(lambda (c a b)
-                 (if (and (lmem? c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
+                 (if (and (mem-of-type? xmem c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
                      (coerce-opnd b '(bty ...)
                        (lambda (b)
                          (coerce-opnd a '(aty ...)
@@ -265,6 +302,22 @@
                                        (lambda (c)
                                          (build-set! ,c ,u))))))))))
                      (next c a b)))]
+            [(op (c fpur) (a aty ...) (b bty ...))
+             #`(lambda (c a b)
+                 (if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
+                     (coerce-opnd b '(bty ...)
+                       (lambda (b)
+                         (coerce-opnd a '(aty ...)
+                           (lambda (a)
+                             (if (fpur? c)
+                                 (rhs c a b)
+                                 (let ([u (make-tmp 'u 'fp)])
+                                   (seq
+                                     (rhs u a b)
+                                     (mref->mref c
+                                       (lambda (c)
+                                         (build-set! ,c ,u))))))))))
+                     (next c a b)))]
             ; four-operand case below can require four unspillables
             [(op (c ur) (a ur) (b ur) (d dty ...))
              (not (memq 'mem (datum (dty ...))))
@@ -307,9 +360,10 @@
                                  (rhs u u)
                                  (build-set! ,c ,u))))))
                      (next c a)))]
-            [(op (c mem) (a aty ...))
+            [(op (c xmem) (a aty ...))
+             (mem-type? #'xmem)
              #`(lambda (c a)
-                 (if (and (lmem? c) (coercible? a '(aty ...)))
+                 (if (and (mem-of-type? xmem c) (coercible? a '(aty ...)))
                      (coerce-opnd a '(aty ...)
                        (lambda (a)
                          (mem->mem c
@@ -330,6 +384,20 @@
                                      (rhs u a)
                                      (build-set! ,c ,u))))))))
                      (next c a)))]
+            [(op (c fpur) (a aty ...))
+             #`(lambda (c a)
+                 (if (coercible? a '(aty ...))
+                     (coerce-opnd a '(aty ...)
+                       (lambda (a)
+                         (if (fpur? c)
+                             (rhs c a)
+                             (mem->mem c
+                               (lambda (c)
+                                 (let ([u (make-tmp 'u 'fp)])
+                                   (seq
+                                     (rhs u a)
+                                     (build-set! ,c ,u))))))))
+                     (next c a)))]
             [(op (c ur))
              #`(lambda (c)
                  (if (ur? c)
@@ -346,6 +414,23 @@
                      (mem->mem c
                        (lambda (c)
                          (rhs c)))
+                     (next c)))]
+            [(op (c fpur))
+             #`(lambda (c)
+                 (if (fpur? c)
+                     (rhs c)
+                     (let ([u (make-tmp 'u 'fp)])
+                       (seq
+                        (rhs u)
+                        (mref->mref c
+                                    (lambda (c)
+                                      (build-set! ,c ,u)))))))]
+            [(op (c fpmem))
+             #`(lambda (c)
+                 (if (fpmem? c)
+                     (mem->mem c
+                       (lambda (c)
+                         (rhs c)))
                      (next c)))])))
 
       (define-who make-pred-clause
@@ -731,37 +816,56 @@
                        `(asm ,info ,(asm-store type) ,x ,u (immediate 0) ,w)))))))))])
 
   (define-instruction value (fstpl)
-    [(op (z mem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstpl))])
+    [(op (z fpmem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstpl))]
+    [(op (z fpur)) (seq
+                    `(set! ,(make-live-info) ,(%mref ,%sp ,%zero -8 fp) (asm ,info ,asm-fstpl))
+                    `(set! ,(make-live-info) ,z ,(%mref ,%sp ,%zero -8 fp)))])
 
   (define-instruction value (fstps)
-    [(op (z mem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstps))])
+    [(op (z fpmem)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fstps))])
 
   (define-instruction effect (fldl)
-    [(op (z mem)) `(asm ,info ,asm-fldl ,z)])
+    [(op (z fpmem)) `(asm ,info ,asm-fldl ,z)])
 
   (define-instruction effect (flds)
     [(op (z mem)) `(asm ,info ,asm-flds ,z)])
 
-  (define-instruction effect (load-single->double load-double->single)
-    [(op (x ur) (y ur) (z imm32))
-     `(asm ,info ,(asm-fl-cvt op (info-loadfl-flreg info)) ,x ,y ,z)])
+  (define-instruction value (load-single->double)
+    [(op (x fpur) (y fpmem))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,y))])
 
-  (define-instruction effect (store-single store-double)
-    [(op (x ur) (y ur) (z imm32))
-     `(asm ,info ,(asm-fl-store op (info-loadfl-flreg info)) ,x ,y ,z)])
+  (define-instruction effect (store-double->single)
+    [(op (x fpmem) (y fpmem fpur))
+     (let ([u (make-tmp 'u 'fp)])
+       (seq
+        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
+        `(asm ,info ,asm-store-single ,x ,u)))])
+
+  (define-instruction value (fpt)
+    [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])
+
+  (define-instruction value (fpmove)
+    [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
+    [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))])
 
-  (define-instruction effect (load-double load-single)
-    [(op (x ur) (y ur) (z imm32))
-     `(asm ,info ,(asm-fl-load op (info-loadfl-flreg info)) ,x ,y ,z)])
+  (define-instruction value (fpcastto/hi) ; little endian: high bytes are at +4
+    [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-movefrom 4) ,y))]
+    [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 32) ,y))])
 
-  (define-instruction effect (flt)
-    [(op (x mem ur) (y ur)) `(asm ,info ,asm-flt ,x ,y)])
+  (define-instruction value (fpcastto/lo) ; little endian: low byte are immediate bytes
+    [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-move ,y))]
+    [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 0) ,y))])
 
-  (define-instruction effect (fl+ fl- fl/ fl*)
-    [(op (x ur) (y ur) (z ur)) `(asm ,info ,(asm-flop-2 op) ,x ,y ,z)])
+  (define-instruction value (fpcastfrom)
+    [(op (x fpmem) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmovefrom ,lo ,hi))]
+    [(op (x fpur) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,lo ,hi))])
 
-  (define-instruction effect (flsqrt)
-    [(op (x ur) (y ur)) `(asm ,info ,asm-flsqrt ,x ,y)])
+  (define-instruction value (fp+ fp- fp* fp/)
+    [(op (x fpur) (y fpmem fpur) (z fpmem fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
+
+  (define-instruction value (fpsqrt)
+    [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
 
   (define-instruction effect inc-cc-counter
     [(op (x ur) (y imm32 ur) (z imm32 ur)) `(asm ,info ,asm-inc-cc-counter ,x ,y ,z)])
@@ -769,8 +873,8 @@
   (define-instruction effect inc-profile-counter 
     [(op (x ur mem) (y imm32 ur)) `(asm ,info ,asm-inc-profile-counter ,x ,y)])
 
-  (define-instruction value (trunc)
-    [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x))])
+  (define-instruction value (fptrunc)
+    [(op (z ur) (x fpmem fpur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x))])
 
   ;; no kills since we expect to be called when all necessary state has already been saved
   (define-instruction value get-tc
@@ -807,10 +911,13 @@
   (define-instruction value pop
     [(op (z ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-pop))])
 
-  (define-instruction pred (fl= fl< fl<=)
-    [(op (x ur) (y ur))
+  (define-instruction pred (fp= fp< fp<=)
+    [(op (x fpmem) (y fpur))
+     (let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
+       (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]
+    [(op (x fpur) (y fpur))
      (let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
-       (values '() `(asm ,info ,(asm-fl-relop info) ,x ,y)))])
+       (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
 
   (define-instruction pred (eq? u< < > <= >=)
     ; the idea (following from the intel x86/x86_64 documentation)
@@ -871,7 +978,7 @@
                   `(set! ,(make-live-info) ,uts (immediate 1))
                   `(set! ,(make-live-info) ,uts
                      (asm ,info ,asm-exchange ,uts
-                       (mref ,x ,y ,imm)))))])
+                       (mref ,x ,y ,imm uptr)))))])
            `(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))]))
 
   (define-instruction effect (locked-incr!)
@@ -924,25 +1031,25 @@
   (define-instruction effect invoke-prelude
     [(op)
      (constant-case machine-type-name
-       [(i3osx ti3osx)
+       [(i3nt ti3nt) `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4 uptr))]
+       [else
         (seq
-          `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4))
-          `(set! ,(make-live-info) ,%sp (asm ,info ,asm-sub ,%sp (immediate 12))))]
-       [else `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4))])])
+          `(set! ,(make-live-info) ,%tc (mref ,%sp ,%zero 4 uptr))
+          `(set! ,(make-live-info) ,%sp (asm ,info ,asm-sub ,%sp (immediate 12))))])])
   )
 
 ;;; SECTION 3: assembler
 (module asm-module (; required exports
-                     asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-jump
+                     asm-move asm-move/extend asm-movefrom asm-load asm-store asm-swap asm-library-call asm-library-jump
                      asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate
                      asm-pop asm-shiftop asm-sll asm-logand asm-lognot
-                     asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
+                     asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
                      asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
                      asm-rp-header asm-rp-compact-header
                      asm-lea1 asm-lea2 asm-indirect-call asm-fstpl asm-fstps asm-fldl asm-flds asm-condition-code
-                     asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div
+                     asm-fl-cvt asm-store-single asm-fpt asm-fptrunc asm-div
                      asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
-                     asm-flop-2 asm-flsqrt asm-c-simple-call
+                     asm-fpop-2 asm-fpmove asm-fpmovefrom asm-fpcastfrom asm-fpcastto asm-fpsqrt asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                      asm-enter asm-foreign-call asm-foreign-callable
                      asm-inc-profile-counter
@@ -961,6 +1068,9 @@
       [(x) (record-case x [(reg) r #t] [else #f])]
       [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])]))
 
+  (define ax-fp-register?
+    (lambda (x) (record-case x [(reg) r (eq? 'fp (reg-type r))] [else #f])))
+
   (define ax-ea-reg-code
     (lambda (ea)
       (record-case ea
@@ -1131,6 +1241,9 @@
   (define-op sse.subsd     sse-op1 #xF2 #x5C)
   (define-op sse.ucomisd   sse-op1 #x66 #x2E)
   (define-op sse.xorpd     sse-op1 #x66 #x57)
+  (define-op sse.psllq     sse-shift 6)
+  (define-op sse.psrlq     sse-shift 2)
+  (define-op sse.orpd      sse-op1 #x66 #x56)
 
   (define sse-op1
     (lambda (op prefix-code op-code source dest-reg code*)
@@ -1145,7 +1258,7 @@
   (define sse-op2
     (lambda (op prefix-code dstreg-op-code srcreg-op-code source dest code*)
       (cond
-        [(ax-register? source)
+        [(ax-fp-register? source)
          (emit-code (op source dest code*)
            (build byte prefix-code)
            (build byte #x0F)
@@ -1153,7 +1266,7 @@
            (ax-ea-modrm-reg dest source)
            (ax-ea-sib dest)
            (ax-ea-addr-disp dest))]
-        [(ax-register? dest)
+        [(ax-fp-register? dest)
          (emit-code (op source dest code*)
            (build byte prefix-code)
            (build byte #x0F)
@@ -1162,7 +1275,16 @@
            (ax-ea-sib source)
            (ax-ea-addr-disp source))]
         [else
-          ($oops 'assembler-internal "sse-op2 source=~s dest=~s" source dest)])))
+         ($oops 'assembler-internal "sse-op2 source=~s dest=~s" source dest)])))
+
+  (define sse-shift
+    (lambda (op op-code dest-reg amt code*)
+      (emit-code (op dest-reg amt code*)
+        (build byte #x66)
+        (build byte #x0F)
+        (build byte #x73)
+        (ax-ea-modrm-ttt dest-reg op-code)
+        (build byte amt))))
 
   (define float-op2
     (lambda (op op-code1 op-code2 source-ea code*)
@@ -1660,6 +1782,13 @@
         [(word) 2]
         [else 4])))
 
+  (define shift-address
+    (lambda (src offset)
+      (record-case src
+        [(disp) (imm x1) `(disp ,(fx+ imm offset) ,x1)]
+        [(index) (imm x2 x1) `(index ,(fx+ imm offset) ,x2 ,x1)]
+        [else ($oops 'shift-address "unexpected shift-address argument ~s" src)])))
+
   (define asm-move
     (lambda (code* dest src)
       (Trivit (dest src)
@@ -1682,6 +1811,12 @@
             [(zext16) (emit movzw src dest code*)]
             [else (sorry! who "unexpected op ~s" op)])))))
 
+  (define asm-movefrom
+    (lambda (offset)
+      (lambda (code* dest src)
+        (Trivit (dest src)
+          (emit mov (shift-address src offset) dest code*)))))
+
   (define asm-fstpl
     (lambda (code* dest)
       (Trivit (dest)
@@ -1703,63 +1838,89 @@
         (emit flds src code*))))
 
   (define asm-fl-cvt
-    (lambda (op flreg)
-      (lambda (code* base index offset)
-        (let ([src (build-mem-opnd base index offset)])
+    (lambda (op)
+      (lambda (code* dest-reg src)
+        (Trivit (src)
           (case op
-            [(load-single->double) (emit sse.cvtss2sd src (cons 'reg flreg) code*)]
-            [(load-double->single) (emit sse.cvtsd2ss src (cons 'reg flreg) code*)])))))
+            [(single->double) (emit sse.cvtss2sd src (cons 'reg dest-reg) code*)]
+            [(double->single) (emit sse.cvtsd2ss src (cons 'reg dest-reg) code*)])))))
 
-  (define asm-fl-store
-    (lambda (op flreg)
-      (lambda (code* base index offset)
-        (let ([dest (build-mem-opnd base index offset)])
-          (case op
-            [(store-single) (emit sse.movss (cons 'reg flreg) dest code*)]
-            [(store-double) (emit sse.movsd (cons 'reg flreg) dest code*)])))))
+  (define asm-store-single
+    (lambda (code* dest flreg)
+      (Trivit (dest)
+        (emit sse.movss (cons 'reg flreg) dest code*))))
+
+  (define asm-fpt
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit sse.cvtsi2sd src dest code*))))
 
-  (define asm-fl-load
-    (lambda (op flreg)
-      (lambda (code* base index offset)
-        (let ([src (build-mem-opnd base index offset)])
+  (define asm-fpop-2
+    (lambda (op)
+      (lambda (code* dest-reg src1 src2)
+        (define (emit-it src dest code*)
           (case op
-            [(load-single) (emit sse.movss src (cons 'reg flreg) code*)]
-            [(load-double) (emit sse.movsd src (cons 'reg flreg) code*)])))))
+            [(fp+) (emit sse.addsd src dest code*)]
+            [(fp-) (emit sse.subsd src dest code*)]
+            [(fp*) (emit sse.mulsd src dest code*)]
+            [(fp/) (emit sse.divsd src dest code*)]))
+        (cond
+          [(eq? dest-reg src1)
+           (Trivit (dest-reg src2)
+             (emit-it src2 dest-reg code*))]
+          [(eq? dest-reg src2)
+           (if (memq op '(fp+ fp*))
+               (Trivit (dest-reg src1)
+                 (emit-it src1 dest-reg code*))
+               (Trivit (dest-reg src1 src2)
+                 (emit sse.movsd src2 (cons 'reg %fptmp1)
+                   (emit sse.movsd src1 dest-reg
+                         (emit-it (cons 'reg %fptmp1) dest-reg code*)))))]
+          [else
+           (Trivit (dest-reg src1 src2)
+             (emit sse.movsd src1 dest-reg
+                   (emit-it src2 dest-reg code*)))]))))
 
-  (define asm-flt
-    (lambda (code* src flonumreg)
-      (Trivit (src)
-        (let ([dest `(disp ,(constant flonum-data-disp) ,flonumreg)]
-              [flreg (cons 'reg %flreg1)])
-          (emit sse.cvtsi2sd src flreg
-            (emit sse.movsd flreg dest code*))))))
+  (define asm-fpsqrt
+    (lambda (code* dest-reg src)
+      (Trivit (dest-reg src)
+        (emit sse.sqrtsd src dest-reg code*))))
 
-  (define asm-flop-2
-    (lambda (op)
-      (lambda (code* src1 src2 dest)
-        (let ([src1 `(disp ,(constant flonum-data-disp) ,src1)]
-              [src2 `(disp ,(constant flonum-data-disp) ,src2)]
-              [dest `(disp ,(constant flonum-data-disp) ,dest)])
-          (let ([code* (emit sse.movsd (cons 'reg %flreg1) dest code*)])
-            (let ([code* (case op
-                           [(fl+) (emit sse.addsd src2 (cons 'reg %flreg1) code*)]
-                           [(fl-) (emit sse.subsd src2 (cons 'reg %flreg1) code*)]
-                           [(fl*) (emit sse.mulsd src2 (cons 'reg %flreg1) code*)]
-                           [(fl/) (emit sse.divsd src2 (cons 'reg %flreg1) code*)])])
-              (emit sse.movsd src1 (cons 'reg %flreg1) code*)))))))
-
-  (define asm-flsqrt
-    (lambda (code* src dest)
-      (let ([src `(disp ,(constant flonum-data-disp) ,src)]
-            [dest `(disp ,(constant flonum-data-disp) ,dest)])
-        (emit sse.sqrtsd src (cons 'reg %flreg1)
-          (emit sse.movsd (cons 'reg %flreg1) dest code*)))))
-
-  (define asm-trunc
-    (lambda (code* dest flonumreg)
-      (Trivit (dest)
-        (let ([src `(disp ,(constant flonum-data-disp) ,flonumreg)])
-          (emit sse.cvttsd2si src dest code*)))))
+  (define asm-fpmove
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit sse.movsd src dest code*))))
+
+  (define asm-fpmovefrom
+    (lambda (code* dest src1 src2)
+      (Trivit (dest src1 src2)
+        (emit mov src1 dest
+          (emit mov src2 (shift-address dest 4) code*)))))
+
+  (define asm-fpcastfrom
+    (lambda (code* dest-reg src1 src2)
+      (Trivit (dest-reg src1 src2)
+        (emit sse.movd src1 dest-reg
+          (emit sse.movd src2 (cons 'reg %fptmp1)
+            (emit sse.psllq (cons 'reg %fptmp1) 32
+              (emit sse.orpd (cons 'reg %fptmp1) dest-reg code*)))))))
+
+  (define asm-fpcastto
+    (lambda (shift)
+      (lambda (code* dest src)
+        (Trivit (dest src)
+          (cond
+            [(eqv? shift 0)
+             (emit sse.movd src dest code*)]
+            [else
+             (emit sse.movsd src (cons 'reg %fptmp1)
+               (emit sse.psrlq (cons 'reg %fptmp1) shift
+                 (emit sse.movd (cons 'reg %fptmp1) dest code*)))])))))
+
+  (define asm-fptrunc
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit sse.cvttsd2si src dest code*))))
 
   (define asm-load
     (lambda (type)
@@ -1919,8 +2080,8 @@
     (lambda ()
       (constant-case machine-type-name
         ; remove padding added by asm-enter
-        [(i3osx ti3osx) (emit addi '(imm 12) (cons 'reg %sp) (emit ret '()))]
-        [else (emit ret '())])))
+        [(i3nt ti3nt) (emit ret '())]
+        [else (emit addi '(imm 12) (cons 'reg %sp) (emit ret '()))])))
 
   (define asm-c-return
     (lambda (info)
@@ -2073,14 +2234,12 @@
             (let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))])
               (asm-conditional-jump info l2 l1 offset)))))))
 
-  (define asm-fl-relop
+  (define asm-fp-relop
     (lambda (info)
       (lambda (l1 l2 offset x y)
         (values
-          (let ([x `(disp ,(constant flonum-data-disp) ,x)]
-                [y `(disp ,(constant flonum-data-disp) ,y)])
-            (emit sse.movsd y (cons 'reg %flreg1)
-              (emit sse.ucomisd x (cons 'reg %flreg1) '())))
+          (Trivit (x y)
+            (emit sse.ucomisd x y '()))
           (asm-conditional-jump info l1 l2 offset)))))
 
   (define asm-relop
@@ -2113,17 +2272,17 @@
   (define asm-save-flrv
     (lambda (code*)
       ; we normally need 8 to store the floating point return variable, but
-      ; on the x86 mac we need 16 in order to get the required 16-byte alignment
-      (emit subi `(imm ,(constant-case machine-type-name [(i3osx ti3osx) 16] [else 8]))
+      ; on some OS's we need 16 in order to get the required 16-byte alignment
+      (emit subi `(imm ,(constant-case machine-type-name [(i3nt ti3nt) 8] [else 16]))
         (cons 'reg %sp)
         (emit fstpl `(disp 0 ,%sp) code*))))
 
   (define asm-restore-flrv
     (lambda (code*)
       ; we normally need 8 to store the floating point return variable, but
-      ; on the x86 mac we need 16 in order to get the required 16-byte alignment
+      ; on some OS's we need 16 in order to get the required 16-byte alignment
       (emit fldl `(disp 0 ,%sp)
-        (emit addi `(imm ,(constant-case machine-type-name [(i3osx ti3osx) 16] [else 8]))
+        (emit addi `(imm ,(constant-case machine-type-name [(i3nt ti3nt) 8] [else 16]))
           (cons 'reg %sp) code*))))
 
   (define asm-library-jump
@@ -2173,7 +2332,8 @@
 
   (define asm-direct-jump
     (lambda (l offset)
-      (emit bra (make-funcrel 'literal l offset) '())))
+      (let ([offset (adjust-return-point-offset offset l)])
+        (emit bra (make-funcrel 'literal l offset) '()))))
 
   (define asm-literal-jump
     (lambda (info)
@@ -2277,11 +2437,11 @@
               [(carry) (i? bcc bcs)]
               ; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100
               ; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1
-              [(fl<) bls]
+              [(fp<) bls]
               ; reversed & inverted: !(fl<= y x) = !(fl>= x y) iff cf = 1
-              [(fl<=) bcs]
+              [(fp<=) bcs]
               ; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
-              [(fl=) (or bne bcs)]))))))
+              [(fp=) (or bne bcs)]))))))
 
   (define asm-data-label
     (lambda (code* l offset func code-size)
@@ -2329,7 +2489,8 @@
         code*)))
 
   (constant-case machine-type-name
-    [(i3osx ti3osx)
+    [(i3nt ti3nt) (define asm-enter values)]
+    [else
      (define-syntax asm-enter
        (lambda (x)
          (syntax-case x ()
@@ -2338,8 +2499,7 @@
               #'(%seq
                  ; adjust to 16-byte boundary, accounting for 4-byte return address pushed by call
                  (set! ,%sp ,(%inline - ,%sp (immediate 12)))
-                 ,e))])))]
-    [else (define asm-enter values)])
+                 ,e))])))])
 
   (define callee-expects-result-pointer?
     (lambda (result-type)
@@ -2368,8 +2528,8 @@
           (let ([offset (fx- offset 8)])
             (move-registers regs (fx- fp-reg-count 1) load? offset
                             (cond
-                             [load? `(seq ,(%inline fldl ,(%mref ,%sp ,offset)) ,e)]
-                             [else  `(seq ,e ,(%inline fstpl ,(%mref ,%sp ,offset)))])))]
+                             [load? `(seq ,(%inline fldl ,(%mref ,%sp ,%zero ,offset fp)) ,e)]
+                             [else  `(seq ,e (set! ,(%mref ,%sp ,%zero ,offset fp) ,(%inline fstpl)))])))]
          [(pair? regs)
           (let ([offset (fx- offset 4)])
             (move-registers (cdr regs) 0 load? offset
@@ -2382,10 +2542,10 @@
       ;; will be pushed later, before a function call
       (let ([offset (fx+ (fx* 4 (length regs)) (fx* 8 fp-reg-count))])
         (constant-case machine-type-name
-          [(i3osx ti3osx)
+          [(i3nt ti3nt) offset]
+          [else
            (fx- (fxlogand (fx+ offset (fx* 4 arg-count) 15) -16)
-                 (fx* 4 arg-count))]
-          [else offset])))
+                 (fx* 4 arg-count))])))
     (define (push-registers regs fp-reg-count arg-count)
       (let ([offset (push-registers-size regs fp-reg-count arg-count)])
         (move-registers regs fp-reg-count #f offset
@@ -2401,16 +2561,12 @@
     (with-output-language (L13 Effect)
       (letrec ([load-double-stack
                 (lambda (offset)
-                  (lambda (x) ; requires var
-                    (%seq
-                      (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
-                      (inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
+                  (lambda (x) ; unboxed
+                    `(set! ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                [load-single-stack
                 (lambda (offset)
-                  (lambda (x) ; requires var
-                    (%seq
-                      (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
-                      (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
+                  (lambda (x) ; unboxed
+                    (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                [load-stack
                  (lambda (offset)
                    (lambda (rhs) ; requires rhs
@@ -2559,8 +2715,8 @@
             (let ([frame-size (constant-case machine-type-name
                                 ; maintain 16-byte alignment not including the return address pushed
                                 ; by the call instruction, which counts as part of callee's frame
-                                [(i3osx ti3osx) (fxlogand (fx+ orig-frame-size 15) -16)]
-                                [else orig-frame-size])])
+                                [(i3nt ti3nt) orig-frame-size]
+                                [else (fxlogand (fx+ orig-frame-size 15) -16)])])
               (values (lambda ()
                         (if (fx= frame-size 0)
                             `(nop)
@@ -2584,10 +2740,11 @@
             (with-values (do-stack arg-type* '() 0 result-type)
               (lambda (frame-size locs)
                 (returnem conv* frame-size locs result-type
-                  (lambda (t0)
+                  (lambda (t0 not-varargs?)
                     (let* ([fill-result-here? (fill-result-pointer-from-registers? result-type)]
                            [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
                            [t (if adjust-active? %edx t0)] ; need a register if `adjust-active?`
+                           [live* (add-caller-save-registers (reg-list %eax %edx))]
                            [call
                             (add-deactivate adjust-active? fill-result-here? t0 result-type
                               (cond
@@ -2600,8 +2757,8 @@
                                   (set! ,%eax ,(%mref ,%sp 0))
                                   (set! ,%eax ,(%mref ,%eax 0))
                                   (set! ,%eax ,(%inline + ,%eax ,t))
-                                  (inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,(%mref ,%eax 0)))]
-                                [else `(inline ,(make-info-kill*-live* (reg-list %eax %edx) '()) ,%c-call ,t)]))])
+                                  (inline ,(make-info-kill*-live* live* '()) ,%c-call ,(%mref ,%eax 0)))]
+                                [else `(inline ,(make-info-kill*-live* live* '()) ,%c-call ,t)]))])
                       (cond
                        [fill-result-here?
                         (let* ([ftd (nanopass-case (Ltype Type) result-type
@@ -2621,14 +2778,14 @@
                                (cond
                                 [(and (if-feature windows (not ($ftd-compound? ftd)) #t)
 				      (equal? '((float 4 0)) ($ftd->members ftd)))
-                                 `(set! ,(%mref ,%ecx 0) ,(%inline fstps))]
+                                 `(set! ,(%mref ,%ecx ,%zero 0 fp) ,(%inline fstps))]
                                 [else
                                  `(set! ,(%mref ,%ecx 0) ,%eax)])]
                               [(8)
                                (cond
                                 [(and (if-feature windows (not ($ftd-compound? ftd)) #t)
 				      (equal? '((float 8 0)) ($ftd->members ftd)))
-                                 `(set! ,(%mref ,%ecx 0) ,(%inline fstpl))]
+                                 `(set! ,(%mref ,%ecx ,%zero 0 fp) ,(%inline fstpl))]
                                 [else
                                  `(seq
                                    (set! ,(%mref ,%ecx 0) ,%eax)
@@ -2636,13 +2793,11 @@
                        [else call])))
                   (nanopass-case (Ltype Type) result-type
                     [(fp-double-float)
-                     (lambda (x)
-                       `(set! ,(%mref ,x ,(constant flonum-data-disp))
-                          ,(%inline fstpl)))]
+                     (lambda (x) ; unboxed
+                       `(set! ,x ,(%inline fstpl)))]
                     [(fp-single-float)
-                     (lambda (x)
-                       `(set! ,(%mref ,x ,(constant flonum-data-disp))
-                          ,(%inline fstpl)))]
+                     (lambda (x) ; unboxed
+                       `(set! ,x ,(%inline fstpl)))]
                     [(fp-integer ,bits)
                      (case bits
                        [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%eax)))]
@@ -2682,7 +2837,7 @@
                    |                           |
                    |    incoming stack args    |
          sp+X+Y+Z: |                           |
-                   +---------------------------+ <- i3osx: 16-byte boundary
+                   +---------------------------+ <- i3nt/ti3nt: 4-byte boundary. other: 16-byte boundary
                    |   incoming return address | one word
                    +---------------------------+
                    |                           | 
@@ -2691,9 +2846,9 @@
                    +---------------------------+
              sp+X: |      unactivate mode      | 0 words or 1 word
                    +---------------------------+
-                   |   indirect result space   | i3osx: 3 words
-                   |  (for & results via regs) | other: 2 words
-             sp+0: +---------------------------+<- i3osx: 16-byte boundary
+                   |   indirect result space   | i3nt/ti3nt: 2 words
+                   |  (for & results via regs) | other: 3 words
+             sp+0: +---------------------------+<- i3nt/ti3nt: 4-byte boundary. other: 16-byte boundary
       |#
 
 
@@ -2701,16 +2856,14 @@
       (let ()
         (define load-double-stack
           (lambda (offset)
-            (lambda (x) ; requires var
-              (%seq
-                (inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
-                (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+            (lambda (x) ; boxed (always a var)
+              `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                     ,(%mref ,%sp ,%zero ,offset fp)))))
         (define load-single-stack
           (lambda (offset)
-            (lambda (x) ; requires var
-              (%seq
-                (inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
-                (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+            (lambda (x) ; boxed (always a var)
+              `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                     ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
         (define load-stack
           (lambda (type offset)
             (lambda (lvalue) ; requires lvalue
@@ -2789,7 +2942,7 @@
                   [(and (if-feature windows (not ($ftd-compound? ftd)) #t)
                         (equal? '((float 8 0)) ($ftd->members ftd)))
                    (values (lambda ()
-                             (%inline fldl ,(%mref ,%sp 0)))
+                             (%inline fldl ,(%mref ,%sp ,%zero 0 fp)))
                            '()
                            1)]
                   [(fx= ($ftd-size ftd) 8)
@@ -2811,13 +2964,13 @@
                          (list %eax)
                          0)])]
               [(fp-double-float)
-               (values (lambda (x)
-                         (%inline fldl ,(%mref ,x ,(constant flonum-data-disp))))
+               (values (lambda (x) ; boxed (always a var)
+                         (%inline fldl ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)))
                        '()
                        1)]
               [(fp-single-float)
-               (values (lambda (x)
-                         (%inline fldl ,(%mref ,x ,(constant flonum-data-disp))))
+               (values (lambda (x) ; boxed (always a var)
+                         (%inline fldl ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)))
                        '()
                        1)]
               [(fp-void)
@@ -2859,13 +3012,13 @@
                  [arg-type* (info-foreign-arg-type* info)]
                  [result-type (info-foreign-result-type info)]
                  [indirect-result-space (constant-case machine-type-name
-                                          [(i3osx ti3osx)
-                                           ;; maintain 16-bit alignment for i3osx, taking into account
+                                          [(i3nt ti3nt) (if adjust-active? 12 8)]
+                                          [else
+                                           ;; maintain 16-bit alignment, taking into account
                                            ;; 16 bytes pushed above + 4 for RA pushed by asmCcall;
                                            ;; 8 of these bytes are used for &-return space, if needed;
                                            ;; the extra 4 bytes may be used for the unactivate mode
-                                           12]
-                                          [else (if adjust-active? 12 8)])]
+                                           12])]
                  [init-stack-offset (fx+ 20 indirect-result-space)]
 		 [indirect-result-to-registers? (fill-result-pointer-from-registers? result-type)])
               (let-values ([(get-result result-regs result-num-fp-regs)
diff --git a/src/ChezScheme/s/x86_64.ss b/src/ChezScheme/s/x86_64.ss
index 5c187b9915..f759150539 100644
--- a/src/ChezScheme/s/x86_64.ss
+++ b/src/ChezScheme/s/x86_64.ss
@@ -17,66 +17,66 @@
 (if-feature windows
   (define-registers
     (reserved
-      [%tc  %r14           #t 14]
-      [%sfp %r13           #t 13]
-      [%ap  %rdi           #t  7]
+      [%tc  %r14           #t 14 uptr]
+      [%sfp %r13           #t 13 uptr]
+      [%ap  %rdi           #t  7 uptr]
       #;[%esp]
       #;[%eap]
       #;[%trap])
     (allocable
-      [%ac0 %rbp           #t  5]
-      [%xp  %r12           #t 12]
-      [%ts  %rax %Cretval  #f  0]
-      [%td  %rbx           #t  3]
-      [%ac1 %r10 %deact    #f 10]
-      [%yp  %r11           #f 11]
-      [%cp  %r15           #t 15]
-      [#;%ret %rsi           #t  6]
-      [     %rdx %Carg2    #f  2]
-      [     %r8  %Carg3    #f  8]
-      [     %r9  %Carg4    #f  9]
-      [     %rcx %Carg1    #f  1]) ; last to avoid use as a Scheme argument
+      [%ac0 %rbp           #t  5 uptr]
+      [%xp  %r12           #t 12 uptr]
+      [%ts  %rax %Cretval  #f  0 uptr]
+      [%td  %rbx           #t  3 uptr]
+      [%ac1 %r10 %deact    #f 10 uptr]
+      [%yp  %r11           #f 11 uptr]
+      [%cp  %r15           #t 15 uptr]
+      [#;%ret %rsi         #t  6 uptr]
+      [     %rdx %Carg2    #f  2 uptr]
+      [     %r8  %Carg3    #f  8 uptr]
+      [     %r9  %Carg4    #f  9 uptr]
+      [     %rcx %Carg1    #f  1 uptr] ; last to avoid use as a Scheme argument
+      [%fp1                #f  4 fp]
+      [%fp2                #f  5 fp])
     (machine-dependent
-      [%Cfparg1 %Cfpretval #f  0]
-      [%Cfparg2            #f  1]
-      [%Cfparg3            #f  2]
-      [%Cfparg4            #f  3]
-      [%flreg1             #f  4]  ; xmm 0-5 are caller-save
-      [%flreg2             #f  5]  ; xmm 6-15 are callee-save
-      [%sp                 #t  4]))
+      [%Cfparg1 %Cfpretval #f  0 fp]  ; xmm 0-5 are caller-save
+      [%Cfparg2            #f  1 fp]  ; xmm 6-15 are callee-save
+      [%Cfparg3            #f  2 fp]
+      [%Cfparg4            #f  3 fp]
+      [%sp                 #t  4 uptr]))
   (define-registers
     (reserved
-      [%tc  %r14           #t 14]
-      [%sfp %r13           #t 13]
-      [%ap  %r9  %Carg6    #f  9]
+      [%tc  %r14           #t 14 uptr]
+      [%sfp %r13           #t 13 uptr]
+      [%ap  %r9  %Carg6    #f  9 uptr]
       #;[%esp]
       #;[%eap]
       #;[%trap])
     (allocable
-      [%ac0 %rbp           #t  5]
-      [%xp  %r12           #t 12]
-      [%ts  %rax %Cretval  #f  0]
-      [%td  %rbx           #t  3]
-      [%ac1 %r10 %deact    #f 10]
-      [%yp  %r11           #f 11]
-      [%cp  %r15           #t 15]
-      [#;%ret %r8  %Carg5    #f  8]
-      [     %rdi %Carg1    #f  7]
-      [     %rsi %Carg2    #f  6]
-      [     %rdx %Carg3    #f  2]
-      [     %rcx %Carg4    #f  1])
+      [%ac0 %rbp           #t  5 uptr]
+      [%xp  %r12           #t 12 uptr]
+      [%ts  %rax %Cretval  #f  0 uptr]
+      [%td  %rbx           #t  3 uptr]
+      [%ac1 %r10 %deact    #f 10 uptr]
+      [%yp  %r11           #f 11 uptr]
+      [%cp  %r15           #t 15 uptr]
+      [#;%ret %r8  %Carg5  #f  8 uptr]
+      [     %rdi %Carg1    #f  7 uptr]
+      [     %rsi %Carg2    #f  6 uptr]
+      [     %rdx %Carg3    #f  2 uptr]
+      [     %rcx %Carg4    #f  1 uptr]
+      [%fp1                #f  8 fp]
+      [%fp2                #f  9 fp])
     (machine-dependent
-      [%Cfparg1 %Cfpretval #f  0]
-      [%Cfparg2            #f  1]
-      [%Cfparg3            #f  2]
-      [%Cfparg4            #f  3]
-      [%Cfparg5            #f  4]
-      [%Cfparg6            #f  5]
-      [%Cfparg7            #f  6]
-      [%Cfparg8            #f  7]
-      [%flreg1             #f  8]
-      [%flreg2             #f  9]
-      [%sp                 #t  4])))
+      [%Cfparg1 %Cfpretval #f  0 fp]
+      [%Cfparg2            #f  1 fp]
+      [%Cfparg3            #f  2 fp]
+      [%Cfparg4            #f  3 fp]
+      [%Cfparg5            #f  4 fp]
+      [%Cfparg6            #f  5 fp]
+      [%Cfparg7            #f  6 fp]
+      [%Cfparg8            #f  7 fp]
+      [%sp                 #t  4 uptr])))
 
 ;;; SECTION 2: instructions
 (module (md-handle-jump) ; also sets primitive handlers
@@ -100,6 +100,18 @@
     (lambda (x)
       (or (lmem? x) (literal@? x))))
 
+  (define fpmem?
+    (lambda (x)
+      (nanopass-case (L15c Triv) x
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type) (eq? type 'fp)]
+        [else #f])))
+
+  (define-syntax mem-of-type?
+    (lambda (stx)
+      (syntax-case stx (mem fpmem)
+        [(_ mem e) #'(lmem? e)]
+        [(_ fpmem e) #'(fpmem? e)])))
+
   (define real-imm32?
     (lambda (x)
       (nanopass-case (L15c Triv) x
@@ -117,6 +129,7 @@
 
   (define lvalue->ur
     (lambda (x k)
+      (safe-assert (not (fpmem? x)))
       (if (mref? x)
           (let ([u (make-tmp 'u)])
             (seq
@@ -127,24 +140,24 @@
   (define mref->mref
     (lambda (a k)
       (define return
-        (lambda (x0 x1 imm)
-          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))
+        (lambda (x0 x1 imm type)
+          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type)))))
       (nanopass-case (L15c Triv) a
-        [(mref ,lvalue0 ,lvalue1 ,imm)
+        [(mref ,lvalue0 ,lvalue1 ,imm ,type)
          (lvalue->ur lvalue0
            (lambda (x0)
              (lvalue->ur lvalue1
                (lambda (x1)
                  (if (signed-32? imm)
-                     (return x0 x1 imm)
+                     (return x0 x1 imm type)
                      (let ([u (make-tmp 'u)])
                        (seq
                          (build-set! ,u (immediate ,imm))
                          (if (eq? x1 %zero)
-                             (return x0 u 0)
+                             (return x0 u 0 type)
                              (seq
                                (build-set! ,u (asm ,null-info ,asm-add ,u ,x1))
-                               (return x0 u 0))))))))))])))
+                               (return x0 u 0 type))))))))))])))
 
   (define mem->mem
     (lambda (a k)
@@ -153,20 +166,27 @@
          (let ([u (make-tmp 'u)])
            (seq
              (build-set! ,u ,(literal@->literal a))
-             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0)))))]
+             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 ptr)))))]
         [else (mref->mref a k)])))
 
+  (define literal->literal
+    (lambda (a)
+      (nanopass-case (L15c Triv) a
+        [(literal ,info) (with-output-language (L15d Triv) `(literal ,info))])))
+
   (define-syntax coercible?
     (syntax-rules ()
       [(_ ?a ?aty*)
        (let ([a ?a] [aty* ?aty*])
-         (or (memq 'ur aty*)
+         (or (and (memq 'ur aty*) (not (or (fpmem? a) (fpur? a))))
+             (and (memq 'fpur aty*) (or (fpmem? a) (fpur? a)))
              (or (and (memq 'imm32 aty*) (imm32? a))
                  (and (memq 'imm aty*) (imm? a))
                  (and (memq 'zero aty*) (imm0? a))
                  (and (memq 'real-imm32 aty*) (real-imm32? a))
                  (and (memq 'negatable-real-imm32 aty*) (negatable-real-imm32? a))
-                 (and (memq 'mem aty*) (mem? a)))))]))
+                 (and (memq 'mem aty*) (mem? a))
+                 (and (memq 'fpmem aty*) (fpmem? a)))))]))
 
   (define-syntax coerce-opnd ; passes k something compatible with aty*
     (syntax-rules ()
@@ -174,6 +194,7 @@
        (let ([a ?a] [aty* ?aty*] [k ?k])
          (cond
            [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
+           [(and (memq 'fpmem aty*) (fpmem? a)) (mem->mem a k)]
            [(and (memq 'imm32 aty*) (imm32? a)) (k (imm->imm a))]
            [(and (memq 'imm aty*) (imm? a)) (k (imm->imm a))]
            [(and (memq 'zero aty*) (imm0? a)) (k (imm->imm a))]
@@ -195,6 +216,18 @@
                        (build-set! ,u ,a)
                        (k u)))))]
               [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
+           [(memq 'fpur aty*)
+            (cond
+              [(fpur? a) (k a)]
+              [(fpmem? a)
+               (mem->mem a
+                 (lambda (a)
+                   (let ([u (make-tmp 'u 'fp)])
+                     (seq
+                       (build-set! ,u ,a)
+                       (k u)))))]
+              [else
+               (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
            [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))
 
   (define set-ur=mref
@@ -254,7 +287,7 @@
                         [(ur? c) (#,k c b)]
                         [(mref? c)
                          (nanopass-case (L15c Triv) c
-                           [(mref ,lvalue0 ,lvalue1 ,imm)
+                           [(mref ,lvalue0 ,lvalue1 ,imm ,type)
                            ; TODO: does this use too many registers? (no longer special casing fv x0, x1 case)
                             (lvalue->ur lvalue0
                               (lambda (x0)
@@ -263,23 +296,30 @@
                                     (let ([u1 (make-tmp 'u)])
                                       (if (signed-32? imm)
                                           (seq
-                                            (build-set! ,u1 (mref ,x0 ,x1 ,imm))
+                                            (build-set! ,u1 (mref ,x0 ,x1 ,imm ,type))
                                             (#,k u1 b)
-                                            (build-set! (mref ,x0 ,x1 ,imm) ,u1))
+                                            (build-set! (mref ,x0 ,x1 ,imm ,type) ,u1))
                                           (let ([u2 (make-tmp 'u)])
                                             (seq
                                               (build-set! ,u2 ,imm)
                                               (build-set! ,x1 (asm ,null-info ,asm-add ,x1 ,u2))
-                                              (build-set! ,u1 (mref ,x0 ,x1 0))
+                                              (build-set! ,u1 (mref ,x0 ,x1 0 ,type))
                                               (#,k u1 b)
-                                              (build-set! (mref ,x0 ,x1 0) ,u1)))))))))])]
+                                              (build-set! (mref ,x0 ,x1 0 ,type) ,u1)))))))))])]
                         ; can't be literal@ since literals can't be lvalues
                         [else (sorry! '#,(datum->syntax #'* who) "unexpected operand ~s" c)])))
                   (next c a b)))))
 
+      (define mem-type?
+        (lambda (t)
+          (syntax-case t (mem fpmem)
+            [mem #t]
+            [fpmem #t]
+            [else #f])))
+
       (define make-value-clause
         (lambda (fmt)
-          (syntax-case fmt (mem ur xp)
+          (syntax-case fmt (mem fpmem ur fpur xp)
             [(op (c mem) (a ?c) (b bty* ...))
              (bound-identifier=? #'?c #'c)
              (acsame-mem #'c #'a #'b #'(bty* ...) #'(lambda (c b) (rhs c c b)))]
@@ -292,9 +332,10 @@
             [(op (c ur) (a aty* ...) (b ?c))
              (bound-identifier=? #'?c #'c)
              (acsame-ur #'c #'b #'a #'(aty* ...) #'(lambda (c a) (rhs c a c)))]
-            [(op (c mem) (a aty ...) (b bty ...))
+            [(op (c xmem) (a aty ...) (b bty ...))
+             (mem-type? #'xmem)
              #`(lambda (c a b)
-                 (if (and (lmem? c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
+                 (if (and (mem-of-type? xmem c) (coercible? a '(aty ...)) (coercible? b '(bty ...)))
                      (coerce-opnd b '(bty ...)
                        (lambda (b)
                          (coerce-opnd a '(aty ...)
@@ -317,6 +358,22 @@
                                        (lambda (c)
                                          (build-set! ,c ,u))))))))))
                      (next c a b)))]
+            [(op (c fpur) (a aty ...) (b bty ...))
+             #`(lambda (c a b)
+                 (if (and (coercible? a '(aty ...)) (coercible? b '(bty ...)))
+                     (coerce-opnd b '(bty ...)
+                       (lambda (b)
+                         (coerce-opnd a '(aty ...)
+                           (lambda (a)
+                             (if (fpur? c)
+                                 (rhs c a b)
+                                 (let ([u (make-tmp 'u 'fp)])
+                                   (seq
+                                     (rhs u a b)
+                                     (mref->mref c
+                                       (lambda (c)
+                                         (build-set! ,c ,u))))))))))
+                     (next c a b)))]
             ; four-operand case below can require four unspillables
             [(op (c ur) (a ur) (b ur) (d dty ...))
              (not (memq 'mem (datum (dty ...))))
@@ -359,9 +416,10 @@
                                  (rhs u u)
                                  (build-set! ,c ,u))))))
                      (next c a)))]
-            [(op (c mem) (a aty ...))
+            [(op (c xmem) (a aty ...))
+             (mem-type? #'xmem)
              #`(lambda (c a)
-                 (if (and (lmem? c) (coercible? a '(aty ...)))
+                 (if (and (mem-of-type? xmem c) (coercible? a '(aty ...)))
                      (coerce-opnd a '(aty ...)
                        (lambda (a)
                          (mem->mem c
@@ -382,6 +440,20 @@
                                      (rhs u a)
                                      (build-set! ,c ,u))))))))
                      (next c a)))]
+            [(op (c fpur) (a aty ...))
+             #`(lambda (c a)
+                 (if (coercible? a '(aty ...))
+                     (coerce-opnd a '(aty ...)
+                       (lambda (a)
+                         (if (fpur? c)
+                             (rhs c a)
+                             (mem->mem c
+                               (lambda (c)
+                                 (let ([u (make-tmp 'u 'fp)])
+                                   (seq
+                                     (rhs u a)
+                                     (build-set! ,c ,u))))))))
+                     (next c a)))]
             [(op (c ur))
              #`(lambda (c)
                  (if (ur? c)
@@ -392,9 +464,10 @@
                            (seq
                              (rhs u)
                              (build-set! ,c ,u)))))))]
-            [(op (c mem))
+            [(op (c xmem))
+             (mem-type? #'xmem)
              #`(lambda (c)
-                 (if (lmem? c)
+                 (if (mem-of-type? xmem c)
                      (mem->mem c
                        (lambda (c)
                          (rhs c)))
@@ -792,35 +865,57 @@
                  `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-lea2 0) ,y ,z))
                  `(asm ,info ,(asm-store (info-load-type info)) ,x ,u (immediate 0) ,w))))))])
 
-  (define-instruction effect (load-single->double load-double->single)
-    [(op (x ur) (y ur) (z imm32))
-     `(asm ,info ,(asm-fl-cvt op (info-loadfl-flreg info)) ,x ,y ,z)])
+  (define-instruction value (load-single->double)
+    [(op (x fpur) (y fpmem))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,y))])
+
+  (define-instruction value (single->double double->single)
+    [(op (x fpur) (y fpmem fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))])
 
-  (define-instruction effect (store-single->double)
-    [(op (x ur) (y ur) (z imm32))
-     `(asm ,info ,(asm-store-single->double (info-loadfl-flreg info)) ,x ,y ,z)])
+  (define-instruction effect (store-double->single)
+    [(op (x fpmem) (y fpmem fpur))
+     (let ([u (make-tmp 'u 'fp)])
+       (seq
+        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
+        `(asm ,info ,asm-store-single ,x ,u)))])
 
-  (define-instruction effect (store-single store-double)
-    [(op (x ur) (y ur) (z imm32))
-     `(asm ,info ,(asm-fl-store op (info-loadfl-flreg info)) ,x ,y ,z)])
+  (define-instruction effect (store-single)
+    [(op (x fpmem) (y fpur))
+     `(asm ,info ,asm-store-single ,x ,y)])
 
-  (define-instruction effect (load-double load-single)
-    [(op (x ur) (y ur) (z imm32))
-     `(asm ,info ,(asm-fl-load op (info-loadfl-flreg info)) ,x ,y ,z)])
+  (define-instruction value (load-single)
+    [(op (x fpur) (y fpmem))
+     `(set! ,(make-live-info) ,x (asm ,info ,asm-load-single ,y))])
 
   (define-instruction value (get-double)
-    [(op (z ur))
-     `(set! ,(make-live-info) ,z
-        (asm ,info ,(asm-get-double (info-loadfl-flreg info))))])
+    [(op (z ur) (y fpur))
+     `(set! ,(make-live-info) ,z (asm ,info ,asm-get-double ,y))])
+
+  (define-instruction value (fpt)
+    [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])
 
-  (define-instruction effect (flt)
-    [(op (x mem ur) (y ur)) `(asm ,info ,asm-flt ,x ,y)])
+  (define-instruction value (fpmove)
+    [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
+    [(op (x fpur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
+    [(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x ,y)])
 
-  (define-instruction effect (fl+ fl- fl/ fl*)
-    [(op (x ur) (y ur) (z ur)) `(asm ,info ,(asm-flop-2 op) ,x ,y ,z)])
+  (define-instruction value (fpcastto)
+    [(op (x mem) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
+    [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-move ,y))]
+    [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcast ,y))])
 
-  (define-instruction effect (flsqrt)
-    [(op (x ur) (y ur)) `(asm ,info ,asm-flsqrt ,x ,y)])
+  (define-instruction value (fpcastfrom)
+    [(op (x fpmem) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-move ,y))]
+    [(op (x fpur) (y mem)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove ,y))]
+    [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcast ,y))])
+
+  (define-instruction value (fp+ fp- fp* fp/)
+    [(op (x fpur) (y fpmem fpur) (z fpmem fpur))
+     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])
+
+  (define-instruction value (fpsqrt)
+    [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])
 
   (define-instruction effect inc-cc-counter
     [(op (x ur) (y imm32 ur) (z imm32 ur)) `(asm ,info ,asm-inc-cc-counter ,x ,y ,z)])
@@ -828,8 +923,8 @@
   (define-instruction effect inc-profile-counter 
     [(op (x ur mem) (y imm32 ur)) `(asm ,info ,asm-inc-profile-counter ,x ,y)])
 
-  (define-instruction value (trunc)
-    [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x))])
+  (define-instruction value (fptrunc)
+    [(op (z ur) (x fpmem fpur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-fptrunc ,x))])
 
   (define-instruction value get-tc
     [(op (z ur))
@@ -874,14 +969,17 @@
        (seq
          `(set! ,(make-live-info) ,urax (asm ,null-info ,asm-kill))
          `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info)) ,urax)))])
-
+  
   (define-instruction value pop
     [(op (z ur)) `(set! ,(make-live-info) ,z (asm ,info ,asm-pop))])
 
-  (define-instruction pred (fl= fl< fl<=)
-    [(op (x ur) (y ur))
+  (define-instruction pred (fp= fp< fp<=)
+    [(op (x fpmem) (y fpur))
      (let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
-       (values '() `(asm ,info ,(asm-fl-relop info) ,x ,y)))])
+       (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]
+    [(op (x fpur) (y fpur))
+     (let ([info (make-info-condition-code op #t #f)]) ; NB: reversed? flag is assumed to be #t
+       (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])
 
   (define-instruction pred (eq? u< < > <= >=)
     ; the idea (following from the intel x86/x86_64 documentation)
@@ -942,7 +1040,7 @@
                   `(set! ,(make-live-info) ,uts (immediate 1))
                   `(set! ,(make-live-info) ,uts
                      (asm ,info ,asm-exchange ,uts
-                       (mref ,x ,y ,imm)))))])
+                       (mref ,x ,y ,imm uptr)))))])
            `(asm ,info-cc-eq ,asm-eq ,uts (immediate 0))))]))
 
   (define-instruction effect (locked-incr!)
@@ -1018,13 +1116,14 @@
                      asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-jump
                      asm-mul asm-muli asm-addop asm-add asm-sub asm-negate asm-sub-negate
                      asm-pop asm-shiftop asm-sll asm-logand asm-lognot
-                     asm-logtest asm-fl-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
+                     asm-logtest asm-fp-relop asm-relop asm-push asm-indirect-jump asm-literal-jump
                      asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label
                      asm-rp-header asm-rp-compact-header
                      asm-lea1 asm-lea2 asm-indirect-call asm-condition-code
-                     asm-fl-cvt asm-fl-store asm-fl-load asm-flt asm-trunc asm-div asm-popcount
+                     asm-fl-cvt asm-store-single asm-load-single asm-fpt asm-fptrunc asm-div asm-popcount
                      asm-exchange asm-pause asm-locked-incr asm-locked-decr asm-locked-cmpxchg
-                     asm-flop-2 asm-flsqrt asm-c-simple-call
+                     asm-fpsqrt asm-fpop-2 asm-fpmove asm-fpcast
+                     asm-c-simple-call
                      asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                      asm-enter asm-foreign-call asm-foreign-callable
                      asm-inc-profile-counter
@@ -1040,6 +1139,9 @@
       [(x) (record-case x [(reg) r #t] [else #f])]
       [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])]))
 
+  (define ax-fp-register?
+    (lambda (x) (record-case x [(reg) r (eq? 'fp (reg-type r))] [else #f])))
+
   (define ax-ea-reg-code
     (lambda (ea)
       (record-case ea
@@ -1223,7 +1325,7 @@
   (define sse-op2
     (lambda (op prefix-code dstreg-op-code srcreg-op-code w source dest code*)
       (cond
-        [(ax-register? source)
+        [(ax-fp-register? source)
          (emit-code (op source dest code*)
            (build byte prefix-code)
            (ax-ea-rex w dest source #f)
@@ -1232,7 +1334,7 @@
            (ax-ea-modrm-reg dest source)
            (ax-ea-sib dest)
            (ax-ea-addr-disp dest))]
-        [(ax-register? dest)
+        [(ax-fp-register? dest)
          (emit-code (op source dest code*)
            (build byte prefix-code)
            (ax-ea-rex w source dest #f)
@@ -1642,9 +1744,9 @@
                (asm-helper-call code* target dest-rax)]
               [else
                ;; Used for the body of `popcount-slow`.
-               ;; This is the sequence generated by LLVM's __builtin_popcountl()
-               ;; __builtin_popcountl() intrinsic, but with pushes and pops
-               ;; to save used registers other than the result register %rax.
+               ;; This is the sequence generated by LLVM's __builtin_popcountl(),
+               ;; but with pushes and pops to save used registers other than the
+               ;; result register %rax.
                (emit-literal-code (op dest-rax src-rcx code*)
                  51              ; pushq   %rcx
                  57              ; pushq   %rdi
@@ -1908,12 +2010,12 @@
             [else (sorry! who "unexpected op ~s" op)])))))
 
   (define asm-fl-cvt
-    (lambda (op flreg)
-      (lambda (code* base index offset)
-        (let ([src (build-mem-opnd base index offset)])
+    (lambda (op)
+      (lambda (code* dest-reg src)
+        (Trivit (src)
           (case op
-            [(load-single->double) (emit sse.cvtss2sd src (cons 'reg flreg) code*)]
-            [(load-double->single) (emit sse.cvtsd2ss src (cons 'reg flreg) code*)])))))
+            [(single->double) (emit sse.cvtss2sd src (cons 'reg dest-reg) code*)]
+            [(double->single) (emit sse.cvtsd2ss src (cons 'reg dest-reg) code*)])))))
 
   (define asm-store-single->double
     (lambda (flreg)
@@ -1922,61 +2024,76 @@
           (emit sse.cvtss2sd flreg flreg
             (emit sse.movsd flreg dest code*))))))
 
-  (define asm-fl-store
-    (lambda (op flreg)
-      (lambda (code* base index offset)
-        (let ([dest (build-mem-opnd base index offset)])
-          (case op
-            [(store-single) (emit sse.movss (cons 'reg flreg) dest code*)]
-            [(store-double) (emit sse.movsd (cons 'reg flreg) dest code*)])))))
+  (define asm-store-single
+    (lambda (code* dest flreg)
+      (Trivit (dest)
+        (emit sse.movss (cons 'reg flreg) dest code*))))
 
-  (define asm-fl-load
-    (lambda (op flreg)
-      (lambda (code* base index offset)
-        (let ([src (build-mem-opnd base index offset)])
-          (case op
-            [(load-single) (emit sse.movss src (cons 'reg flreg) code*)]
-            [(load-double) (emit sse.movsd src (cons 'reg flreg) code*)])))))
+  (define asm-load-single
+    (lambda (code* flreg src)
+      (Trivit (src)
+        (emit sse.movss src (cons 'reg flreg) code*))))
 
   (define asm-get-double
-    (lambda (flreg)
-      (lambda (code* dst)
-        (emit sse.movd (cons 'reg flreg) (cons 'reg dst) code*))))
+    (lambda (code* dst flreg)
+      (emit sse.movd (cons 'reg flreg) (cons 'reg dst) code*)))
 
-  (define asm-flt
-    (lambda (code* src flonumreg)
-      (Trivit (src)
-        (let ([dest `(disp ,(constant flonum-data-disp) ,flonumreg)]
-              [flreg (cons 'reg %flreg1)])
-          (emit sse.cvtsi2sd src flreg
-            (emit sse.movsd flreg dest code*))))))
+  (define asm-fpt
+    (lambda (code* dest src)
+      (Trivit (dest src)
+         (emit sse.cvtsi2sd src dest code*))))
 
-  (define asm-flop-2
+  (define asm-fpop-2
     (lambda (op)
-      (lambda (code* src1 src2 dest)
-        (let ([src1 `(disp ,(constant flonum-data-disp) ,src1)]
-              [src2 `(disp ,(constant flonum-data-disp) ,src2)]
-              [dest `(disp ,(constant flonum-data-disp) ,dest)])
-          (let ([code* (emit sse.movsd (cons 'reg %flreg1) dest code*)])
-            (let ([code* (case op
-                           [(fl+) (emit sse.addsd src2 (cons 'reg %flreg1) code*)]
-                           [(fl-) (emit sse.subsd src2 (cons 'reg %flreg1) code*)]
-                           [(fl*) (emit sse.mulsd src2 (cons 'reg %flreg1) code*)]
-                           [(fl/) (emit sse.divsd src2 (cons 'reg %flreg1) code*)])])
-              (emit sse.movsd src1 (cons 'reg %flreg1) code*)))))))
-
-  (define asm-flsqrt
-    (lambda (code* src dest)
-      (let ([src `(disp ,(constant flonum-data-disp) ,src)]
-            [dest `(disp ,(constant flonum-data-disp) ,dest)])
-        (emit sse.sqrtsd src (cons 'reg %flreg1)
-          (emit sse.movsd (cons 'reg %flreg1) dest code*)))))
-
-  (define asm-trunc
-    (lambda (code* dest flonumreg)
-      (Trivit (dest)
-        (let ([src `(disp ,(constant flonum-data-disp) ,flonumreg)])
-          (emit sse.cvttsd2si src dest code*)))))
+      (lambda (code* dest-reg src1 src2)
+        (define (emit-it src dest code*)
+          (case op
+            [(fp+) (emit sse.addsd src dest code*)]
+            [(fp-) (emit sse.subsd src dest code*)]
+            [(fp*) (emit sse.mulsd src dest code*)]
+            [(fp/) (emit sse.divsd src dest code*)]))
+        (cond
+          [(eq? dest-reg src1)
+           (Trivit (dest-reg src2)
+             (emit-it src2 dest-reg code*))]
+          [(eq? dest-reg src2)
+           (if (memq op '(fp+ fp*))
+               (Trivit (dest-reg src1)
+                 (emit-it src1 dest-reg code*))
+               ;; Assuming that any subtraction or division will be
+               ;; done before we try to fill C arguments...
+               (Trivit (dest-reg src1 src2)
+                 (emit sse.movsd src2 (cons 'reg %Cfparg1)
+                   (emit sse.movsd src1 dest-reg
+                         (emit-it (cons 'reg %Cfparg1) dest-reg code*)))))]
+          [else
+           (Trivit (dest-reg src1 src2)
+             (if (equal? src1 src2)
+                 ;; avoid redundant load
+                 (emit sse.movsd src1 dest-reg
+                       (emit-it dest-reg dest-reg code*))
+                 (emit sse.movsd src1 dest-reg
+                       (emit-it src2 dest-reg code*))))]))))
+
+  (define asm-fpsqrt
+    (lambda (code* dest-reg src)
+      (Trivit (dest-reg src)
+        (emit sse.sqrtsd src dest-reg code*))))
+
+  (define asm-fpmove
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit sse.movsd src dest code*))))
+
+  (define asm-fpcast
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit sse.movd src dest code*))))
+
+  (define asm-fptrunc
+    (lambda (code* dest src)
+      (Trivit (dest src)
+        (emit sse.cvttsd2si src dest code*))))
 
   (define asm-load
     (lambda (type)
@@ -2305,14 +2422,12 @@
             (let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))])
               (asm-conditional-jump info l2 l1 offset)))))))
 
-  (define asm-fl-relop
+  (define asm-fp-relop
     (lambda (info)
       (lambda (l1 l2 offset x y)
         (values
-          (let ([x `(disp ,(constant flonum-data-disp) ,x)]
-                [y `(disp ,(constant flonum-data-disp) ,y)])
-            (emit sse.movsd y (cons 'reg %flreg1)
-              (emit sse.ucomisd x (cons 'reg %flreg1) '())))
+          (Trivit (x y)
+            (emit sse.ucomisd x y '()))
           (asm-conditional-jump info l1 l2 offset)))))
 
   (define asm-relop
@@ -2415,7 +2530,8 @@
 
   (define asm-direct-jump
     (lambda (l offset)
-      (asm-helper-jump '() (make-funcrel 'x86_64-jump l offset))))
+      (let ([offset (adjust-return-point-offset offset l)])
+        (asm-helper-jump '() (make-funcrel 'x86_64-jump l offset)))))
 
   (define asm-literal-jump
     (lambda (info)
@@ -2435,10 +2551,11 @@
         (or (cond
               [(local-label-offset l) =>
                (lambda (offset)
-                 (let ([disp (fx- next-addr (fx- offset incr-offset))])
-                   (and (signed-32? disp)
-                        (Trivit (dest)
-                          (emit lea `(riprel ,disp) dest '())))))]
+                 (let ([incr-offset (adjust-return-point-offset incr-offset l)])
+                   (let ([disp (fx- next-addr (fx- offset incr-offset))])
+                     (and (signed-32? disp)
+                          (Trivit (dest)
+                            (emit lea `(riprel ,disp) dest '()))))))]
                [else #f])
             (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))))))
 
@@ -2527,11 +2644,11 @@
               [(carry) (i? bcc bcs)]
               ; unordered: zf,pf,cf <- 111; gt: 000; lt: 001; eq: 100
               ; reversed & inverted: !(fl< y x) = !(fl> x y) iff zf = 1 & cf = 1
-              [(fl<) bls]
+              [(fp<) bls]
               ; reversed & inverted: !(fl<= y x) = !(fl>= x y) iff cf = 1
-              [(fl<=) bcs]
+              [(fp<=) bcs]
               ; inverted: !(fl= x y) iff zf = 0 or cf (or pf) = 1
-              [(fl=) (or bne bcs)]))))))
+              [(fp=) (or bne bcs)]))))))
 
   (define asm-data-label
     (lambda (code* l offset func code-size)
@@ -2709,17 +2826,15 @@
 
     (module (push-registers pop-registers push-registers-size)
       (define (move-registers regs load?)
-        (define vfp (make-vfp))
-        (define (fp-reg? reg)
-          (let loop ([i (fx- (vector-length vfp) 1)])
-            (or (eq? reg (vector-ref vfp i))
-                (and (fx> i 0) (loop (fx- i 1))))))
+        (define (fp-reg? reg) (eq? (reg-type reg) 'fp))
         (with-output-language (L13 Effect)
           (let loop ([regs regs] [offset 0])
             (let* ([reg (car regs)]
                    [e (cond
                        [(fp-reg? reg)
-                        `(inline ,(make-info-loadfl reg) ,(if load? %load-double %store-double) ,%sp ,%zero (immediate ,offset))]
+                        (if load?
+                            `(set! ,reg ,(%mref ,%sp ,%zero ,offset fp))
+                            `(set! ,(%mref ,%sp ,%zero ,offset fp) ,reg))]
                        [load? `(set! ,reg ,(%mref ,%sp ,offset))]
                        [else `(set! ,(%mref ,%sp ,offset) ,reg)])]
                    [regs (cdr regs)])
@@ -2752,34 +2867,31 @@
       (with-output-language (L13 Effect)
         (letrec ([load-double-stack
                   (lambda (offset)
-                    (lambda (x) ; requires var
-                      (%seq
-                        (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
-                        (inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
+                    (lambda (x) ; unboxed
+                      `(set! ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                  [load-single-stack
                   (lambda (offset)
-                    (lambda (x) ; requires var
-                      (%seq
-                        (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
-                        (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
+                    (lambda (x) ; unboxed
+                      (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                  [load-int-stack
                   (lambda (offset)
                     (lambda (rhs) ; requires rhs
                       `(set! ,(%mref ,%sp ,offset) ,rhs)))]
                  [load-double-reg
                   (lambda (fpreg)
-                    (lambda (x) ; requires var
-                      `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))))]
+                    (lambda (x) ; unboxed
+                      `(set! ,fpreg ,x)))]
                  [load-double-reg2
                   (lambda (fpreg ireg)
-                    (lambda (x) ; requires var
+                    (lambda (x) ; unboxed
                       (%seq
-                       (inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
-                       (set! ,ireg (inline ,(make-info-loadfl fpreg) ,%get-double)))))]
+                        (set! ,fpreg ,x)
+                        ;; To support the varargs convention, copy the value into a GP register
+                        (set! ,ireg ,(%inline get-double ,fpreg)))))]
                  [load-single-reg
                   (lambda (fpreg)
-                    (lambda (x) ; requires var
-                      `(inline ,(make-info-loadfl fpreg) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))))]
+                    (lambda (x) ; unboxed
+                      `(set! ,fpreg ,(%inline double->single ,x))))]
                  [load-int-reg
                   (lambda (type ireg)
                     (lambda (x)
@@ -2826,10 +2938,10 @@
                           (cond
                            [(fx= size 4)
                             ;; Must be the last element
-                            `(inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-single ,x ,%zero (immediate ,x-offset))]
+                            `(set! ,(vector-ref vfp ifp) ,(%inline load-single ,(%mref ,x ,%zero ,x-offset fp)))]
                            [else
                             `(seq
-                              (inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%load-double ,x ,%zero (immediate ,x-offset))
+                              (set! ,(vector-ref vfp ifp) ,(%mref ,x ,%zero ,x-offset fp))
                               ,(loop (fx- size 8) iint (fx+ ifp 1) (cdr classes) (fx+ x-offset 8)))])]
                          ;; Remaining cases are integers:
                          [(>= size 8)
@@ -3030,8 +3142,8 @@
                 `(seq
                   ,(loop (cdr classes) (fx+ offset 8) iregs (cdr fpregs) (fx- size 8))
                   ,(case size
-                     [(4) `(inline ,(make-info-loadfl (car fpregs)) ,%store-single ,%rcx ,%zero (immediate ,offset))]
-                     [else `(inline ,(make-info-loadfl (car fpregs)) ,%store-double ,%rcx ,%zero (immediate ,offset))]))]
+                     [(4) (%inline store-single ,(%mref ,%rcx ,%zero ,offset fp) ,(car fpregs))]
+                     [else `(set! ,(%mref ,%rcx ,%zero ,offset fp) ,(car fpregs))]))]
                [else
                 `(seq
                   ,(loop (cdr classes) (fx+ offset 8) (cdr iregs) fpregs (fx- size 8))
@@ -3107,40 +3219,43 @@
                    [result-classes (classify-type result-type)]
                    [result-size (classified-size result-type)]
                    [fill-result-here? (result-fits-in-registers? result-classes)]
+                   [result-reg* (get-result-regs fill-result-here? result-type result-classes)]
                    [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)])
               (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*) (make-vint) (make-vfp))
                 (lambda (frame-size nfp locs live* fp-live*)
                   (with-values (add-save-fill-target fill-result-here? frame-size locs)
                     (lambda (frame-size locs)
                       (returnem frame-size locs
-                        (lambda (t0)
+                        (lambda (t0 not-varargs?)
                           (let* ([t (if adjust-active? %deact t0)] ; need a register if `adjust-active?`
+                                 [kill* (add-caller-save-registers result-reg*)]                                 
                                  [c-call
                                   (add-deactivate adjust-active? t0 (append fp-live* live*)
-                                   (get-result-regs fill-result-here? result-type result-classes)
+                                   result-reg*
                                    (if-feature windows
                                      (%seq
                                        (set! ,%sp ,(%inline - ,%sp (immediate 32)))
-                                       (inline ,(make-info-kill*-live* (reg-list %rax %rdx) live*) ,%c-call ,t)
+                                       (inline ,(make-info-kill*-live* kill* (append fp-live* live*)) ,%c-call ,t)
                                        (set! ,%sp ,(%inline + ,%sp (immediate 32))))
                                      (%seq
-                                       ;; System V ABI varargs functions require count of fp regs used in %al register.
-                                       ;; since we don't know if the callee is a varargs function, we always set it.
-                                       (set! ,%rax (immediate ,nfp))
-                                       (inline ,(make-info-kill*-live* (reg-list %rax %rdx) (cons %rax live*)) ,%c-call ,t))))])
+                                      ,(if not-varargs?
+                                           `(nop)
+                                           ;; System V ABI varargs functions require count of fp regs used in %al register.
+                                           ;; since we don't know if the callee is a varargs function, we always set it.
+                                           `(set! ,%rax (immediate ,nfp)))
+                                      ,(let ([live* (append fp-live* live*)])
+                                         `(inline ,(make-info-kill*-live* kill* (if not-varargs? live* (cons %rax live*))) ,%c-call ,t)))))])
                             (cond
                              [fill-result-here?
                               (add-fill-result c-call (fx- frame-size (constant ptr-bytes)) result-classes result-size)]
                              [else c-call])))
                         (nanopass-case (Ltype Type) result-type
                           [(fp-double-float)
-                           (lambda (lvalue)
-                             `(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
-                                ,(%constant flonum-data-disp)))]
+                           (lambda (lvalue) ; unboxed
+                             `(set! ,lvalue ,%Cfpretval))]
                           [(fp-single-float)
-                           (lambda (lvalue)
-                             `(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero
-                                ,(%constant flonum-data-disp)))]
+                           (lambda (lvalue) ; unboxed
+                             `(set! ,lvalue ,(%inline single->double ,%Cfpretval)))]
                           [(fp-integer ,bits)
                            (case bits
                              [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%rax)))]
@@ -3213,16 +3328,14 @@
         (let ()
           (define load-double-stack
             (lambda (offset)
-              (lambda (x) ; requires var
-                (%seq
-                  (inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
-                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+              (lambda (x) ; boxed (always a var)
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%mref ,%sp ,%zero ,offset fp)))))
           (define load-single-stack
             (lambda (offset)
-              (lambda (x) ; requires var
-                (%seq
-                  (inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
-                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
+              (lambda (x) ; boxed (always a var)
+                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
+                       ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
           (define load-int-stack
             (lambda (type offset)
               (lambda (lvalue)
@@ -3262,15 +3375,13 @@
                         [(fp-double-float)
                          (if (< i 4)
                              (%seq
-                               (inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-double
-                                 ,%sp ,%zero (immediate ,isp))
+                               (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp i))
                                ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))
                              (f (cdr types) i isp))]
                         [(fp-single-float)
                          (if (< i 4)
                              (%seq
-                               (inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-single
-                                 ,%sp ,%zero (immediate ,isp))
+                               ,(%inline store-single ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp i))
                                ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))
                              (f (cdr types) i isp))]
                         [(fp-ftd& ,ftd)
@@ -3285,8 +3396,7 @@
                                     (eq? 'float (caar ($ftd->members ftd))))
                                ;; float or double
                                `(seq
-                                 (inline ,(make-info-loadfl (vector-ref vfp i)) ,%store-double
-                                         ,%sp ,%zero (immediate ,isp))
+                                 (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp i))
                                  ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))]
                               [else
                                ;; integer
@@ -3320,15 +3430,13 @@
                         [(fp-double-float)
                          (if (< ifp 8)
                              (%seq
-                               (inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-double
-                                 ,%sp ,%zero (immediate ,isp))
+                               (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp ifp))
                                ,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8)))
                              (f (cdr types) iint ifp isp))]
                         [(fp-single-float)
                          (if (< ifp 8)
                              (%seq
-                               (inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-single
-                                 ,%sp ,%zero (immediate ,isp))
+                               ,(%inline store-single ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp ifp))
                                ,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8)))
                              (f (cdr types) iint ifp isp))]
                         [(fp-ftd& ,ftd)
@@ -3347,8 +3455,7 @@
                                  (f (cdr types) iint ifp isp)]
                                 [(eq? (car classes) 'sse)
                                  `(seq
-                                   (inline ,(make-info-loadfl (vector-ref vfp ifp)) ,%store-double
-                                           ,%sp ,%zero (immediate ,isp))
+                                   (set! ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp ifp))
                                    ,(reg-loop (cdr classes) iint (fx+ ifp 1) (+ isp 8)))]
                                 [else
                                  `(seq
@@ -3468,7 +3575,7 @@
                            (fx+ offset 8)
                            int*
                            (cdr fp*)
-                           (cons `(inline ,(make-info-loadfl (car fp*)) ,%load-double ,%sp ,%zero (immediate ,offset))
+                           (cons `(set! ,(car fp*) ,(%mref ,%sp ,%zero ,offset fp))
                                  accum)
                            live*
                            (cons (car fp*) fp-live*))]))]
@@ -3480,14 +3587,14 @@
                          '())])]
               [(fp-double-float)
                (values
-                (lambda (x)
-                  `(inline ,(make-info-loadfl %Cfpretval) ,%load-double ,x ,%zero ,(%constant flonum-data-disp)))
+                (lambda (x) ; boxed (always a var)
+                  `(set! ,%Cfpretval ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)))
                 '()
                 (list %Cfpretval))]
               [(fp-single-float)
                (values
-                (lambda (x)
-                  `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp)))
+                (lambda (x) ; boxed (always a var)
+                  `(set! ,%Cfpretval ,(%inline double->single ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp))))
                 '()
                 (list %Cfpretval))]
               [(fp-void)
@@ -3602,5 +3709,5 @@
                              (set! ,%rbp ,(%inline pop))
                              (set! ,%rbx ,(%inline pop))
                              (set! ,%sp ,(%inline + ,%sp (immediate 136)))))
-                        (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ...))))))))))))))
+                        (asm-c-return ,null-info ,callee-save-regs ... ,result-regs ... ,result-fp-regs ...))))))))))))))
   )
diff --git a/src/ChezScheme/workarea b/src/ChezScheme/workarea
index 1672d4b2d1..a79cd2472c 100755
--- a/src/ChezScheme/workarea
+++ b/src/ChezScheme/workarea
@@ -56,6 +56,7 @@ case "$M" in
   ta6osx) ;;
   ta6s2) ;;
   tarm32le) ;;
+  tarm64le) ;;
   ti3fb) ;;
   ti3le) ;;
   ti3nb) ;;