From d64cc6aa017fcb7445727373541027d3849e23b0 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 13 Jan 2019 06:08:23 +0000
Subject: [PATCH] Draft aarch64 back end.

Nowhere near completion yet, long TODO list, not compile-tested, &c.
Not sure if I'll find any more copious spare time to work on this for
a while.
---
 src/compiler/machines/aarch64/.dir-locals.el |    1 +
 src/compiler/machines/aarch64/TODO           |   21 +
 src/compiler/machines/aarch64/compiler.cbf   |   38 +
 src/compiler/machines/aarch64/compiler.pkg   |  784 +++++++
 src/compiler/machines/aarch64/compiler.sf    |   89 +
 src/compiler/machines/aarch64/decls.scm      |  596 ++++++
 src/compiler/machines/aarch64/instr.scm      | 1905 ++++++++++++++++++
 src/compiler/machines/aarch64/lapgen.scm     |  383 ++++
 src/compiler/machines/aarch64/lapopt.scm     |   33 +
 src/compiler/machines/aarch64/machine.scm    |  518 +++++
 src/compiler/machines/aarch64/make.scm       |   33 +
 src/compiler/machines/aarch64/order-be.scm   |   32 +
 src/compiler/machines/aarch64/order-le.scm   |   32 +
 src/compiler/machines/aarch64/rgspcm.scm     |   67 +
 src/compiler/machines/aarch64/rules1.scm     |  316 +++
 src/compiler/machines/aarch64/rules2.scm     |  112 +
 src/compiler/machines/aarch64/rules3.scm     |  742 +++++++
 src/compiler/machines/aarch64/rules4.scm     |  111 +
 src/compiler/machines/aarch64/rulfix.scm     |  269 +++
 src/compiler/machines/aarch64/rulrew.scm     |  207 ++
 src/microcode/cmpintmd/aarch64.c             |  340 ++++
 src/microcode/cmpintmd/aarch64.h             |  243 +++
 22 files changed, 6872 insertions(+)
 create mode 100644 src/compiler/machines/aarch64/.dir-locals.el
 create mode 100644 src/compiler/machines/aarch64/TODO
 create mode 100644 src/compiler/machines/aarch64/compiler.cbf
 create mode 100644 src/compiler/machines/aarch64/compiler.pkg
 create mode 100644 src/compiler/machines/aarch64/compiler.sf
 create mode 100644 src/compiler/machines/aarch64/decls.scm
 create mode 100644 src/compiler/machines/aarch64/instr.scm
 create mode 100644 src/compiler/machines/aarch64/lapgen.scm
 create mode 100644 src/compiler/machines/aarch64/lapopt.scm
 create mode 100644 src/compiler/machines/aarch64/machine.scm
 create mode 100644 src/compiler/machines/aarch64/make.scm
 create mode 100644 src/compiler/machines/aarch64/order-be.scm
 create mode 100644 src/compiler/machines/aarch64/order-le.scm
 create mode 100644 src/compiler/machines/aarch64/rgspcm.scm
 create mode 100644 src/compiler/machines/aarch64/rules1.scm
 create mode 100644 src/compiler/machines/aarch64/rules2.scm
 create mode 100644 src/compiler/machines/aarch64/rules3.scm
 create mode 100644 src/compiler/machines/aarch64/rules4.scm
 create mode 100644 src/compiler/machines/aarch64/rulfix.scm
 create mode 100644 src/compiler/machines/aarch64/rulrew.scm
 create mode 100644 src/microcode/cmpintmd/aarch64.c
 create mode 100644 src/microcode/cmpintmd/aarch64.h

diff --git a/src/compiler/machines/aarch64/.dir-locals.el b/src/compiler/machines/aarch64/.dir-locals.el
new file mode 100644
index 000000000..8ce86e2c3
--- /dev/null
+++ b/src/compiler/machines/aarch64/.dir-locals.el
@@ -0,0 +1 @@
+((nil (indent-tabs-mode . nil)))
diff --git a/src/compiler/machines/aarch64/TODO b/src/compiler/machines/aarch64/TODO
new file mode 100644
index 000000000..08af65f71
--- /dev/null
+++ b/src/compiler/machines/aarch64/TODO
@@ -0,0 +1,21 @@
+- Make it work.
+  [ ] assmd
+  [ ] cmpauxmd
+  [ ] coerce
+  [ ] insmac
+  [ ] instr: branch tensioning, review it all, simd, float
+  [ ] insutl
+  [ ] logical immediate encoding
+- Confirm apply target/pc registers match in:
+  . rules3 (invocation:computed-jump)
+  . cmpauxmd
+  . uuo link code in aarch64.c (currently uses x0/x1, should use x16/x17)
+  . trampoline code, if necessary
+  . wherever else
+- Verify the branch condition codes.
+- Open-coded flonum arithmetic.
+- Better fixnum operations with constant operands.
+- Fast division by multiplication.
+- Fixnum multiply-add/sub/negate.
+- Consider NaN-tagging.
+- Write a disassembler.
diff --git a/src/compiler/machines/aarch64/compiler.cbf b/src/compiler/machines/aarch64/compiler.cbf
new file mode 100644
index 000000000..1eeb84eb1
--- /dev/null
+++ b/src/compiler/machines/aarch64/compiler.cbf
@@ -0,0 +1,38 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Script to incrementally compile the compiler (from .bins)
+
+(fluid-let ((compiler:coalescing-constant-warnings? #f))
+  (for-each compile-directory
+            '("back"
+              "base"
+              "fggen"
+              "fgopt"
+              "machines/aarch64"
+              "rtlbase"
+              "rtlgen"
+              "rtlopt")))
diff --git a/src/compiler/machines/aarch64/compiler.pkg b/src/compiler/machines/aarch64/compiler.pkg
new file mode 100644
index 000000000..52a7ad963
--- /dev/null
+++ b/src/compiler/machines/aarch64/compiler.pkg
@@ -0,0 +1,784 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler Packaging
+
+(global-definitions "../runtime/runtime")
+(global-definitions "../sf/sf")
+
+(define-package (compiler)
+  (files "base/switch"
+         "base/object"                  ;tagged object support
+         "base/enumer"                  ;enumerations
+         "base/sets"                    ;set abstraction
+         "base/mvalue"                  ;multiple-value support
+         "base/scode"                   ;SCode abstraction
+         "machines/aarch64/machine"     ;machine dependent stuff
+         "back/asutl"                   ;back-end odds and ends
+         "base/utils"                   ;odds and ends
+
+         "base/cfg1"                    ;control flow graph
+         "base/cfg2"
+         "base/cfg3"
+
+         "base/ctypes"                  ;CFG datatypes
+
+         "base/rvalue"                  ;Right hand values
+         "base/lvalue"                  ;Left hand values
+         "base/blocks"                  ;rvalue: blocks
+         "base/proced"                  ;rvalue: procedures
+         "base/contin"                  ;rvalue: continuations
+
+         "base/subprb"                  ;subproblem datatype
+
+         "rtlbase/rgraph"               ;program graph abstraction
+         "rtlbase/rtlty1"               ;RTL: type definitions
+         "rtlbase/rtlty2"               ;RTL: type definitions
+         "rtlbase/rtlexp"               ;RTL: expression operations
+         "rtlbase/rtlcon"               ;RTL: complex constructors
+         "rtlbase/rtlreg"               ;RTL: registers
+         "rtlbase/rtlcfg"               ;RTL: CFG types
+         "rtlbase/rtlobj"               ;RTL: CFG objects
+         "rtlbase/regset"               ;RTL: register sets
+         "rtlbase/valclass"             ;RTL: value classes
+
+         "back/insseq"                  ;LAP instruction sequences
+         )
+  (parent ())
+  (export ()
+          compiler:analyze-side-effects?
+          compiler:cache-free-variables?
+          compiler:coalescing-constant-warnings?
+          compiler:code-compression?
+          compiler:compile-by-procedures?
+          compiler:cross-compiling?
+          compiler:cse?
+          compiler:default-top-level-declarations
+          compiler:enable-integration-declarations?
+          compiler:generate-lap-files?
+          compiler:generate-range-checks?
+          compiler:generate-rtl-files?
+          compiler:generate-stack-checks?
+          compiler:generate-type-checks?
+          compiler:implicit-self-static?
+          compiler:intersperse-rtl-in-lap?
+          compiler:noisy?
+          compiler:open-code-floating-point-arithmetic?
+          compiler:open-code-flonum-checks?
+          compiler:open-code-primitives?
+          compiler:optimize-environments?
+          compiler:package-optimization-level
+          compiler:preserve-data-structures?
+          compiler:show-phases?
+          compiler:show-procedures?
+          compiler:show-subphases?
+          compiler:show-time-reports?
+          compiler:use-multiclosures?)
+  (import (runtime system-macros)
+          ucode-primitive
+          ucode-type)
+  (import ()
+          (scode/access-environment scode-access-environment)
+          (scode/access-name scode-access-name)
+          (scode/access? scode-access?)
+          (scode/assignment-name scode-assignment-name)
+          (scode/assignment-value scode-assignment-value)
+          (scode/assignment? scode-assignment?)
+          (scode/combination-operands scode-combination-operands)
+          (scode/combination-operator scode-combination-operator)
+          (scode/combination? scode-combination?)
+          (scode/comment-expression scode-comment-expression)
+          (scode/comment-text scode-comment-text)
+          (scode/comment? scode-comment?)
+          (scode/conditional-alternative scode-conditional-alternative)
+          (scode/conditional-consequent scode-conditional-consequent)
+          (scode/conditional-predicate scode-conditional-predicate)
+          (scode/conditional? scode-conditional?)
+          (scode/constant? scode-constant?)
+          (scode/declaration-expression scode-declaration-expression)
+          (scode/declaration-text scode-declaration-text)
+          (scode/declaration? scode-declaration?)
+          (scode/definition-name scode-definition-name)
+          (scode/definition-value scode-definition-value)
+          (scode/definition? scode-definition?)
+          (scode/delay-expression scode-delay-expression)
+          (scode/delay? scode-delay?)
+          (scode/disjunction-alternative scode-disjunction-alternative)
+          (scode/disjunction-predicate scode-disjunction-predicate)
+          (scode/disjunction? scode-disjunction?)
+          (scode/lambda-components scode-lambda-components)
+          (scode/lambda-body scode-lambda-body)
+          (scode/lambda-name scode-lambda-name)
+          (scode/lambda? scode-lambda?)
+          (scode/make-access make-scode-access)
+          (scode/make-assignment make-scode-assignment)
+          (scode/make-combination make-scode-combination)
+          (scode/make-comment make-scode-comment)
+          (scode/make-conditional make-scode-conditional)
+          (scode/make-declaration make-scode-declaration)
+          (scode/make-definition make-scode-definition)
+          (scode/make-delay make-scode-delay)
+          (scode/make-disjunction make-scode-disjunction)
+          (scode/make-lambda make-scode-lambda)
+          (scode/make-open-block make-scode-open-block)
+          (scode/make-quotation make-scode-quotation)
+          (scode/make-sequence make-scode-sequence)
+          (scode/make-the-environment make-scode-the-environment)
+          (scode/make-unassigned? make-scode-unassigned?)
+          (scode/make-variable make-scode-variable)
+          (scode/open-block-actions scode-open-block-actions)
+          (scode/open-block-declarations scode-open-block-declarations)
+          (scode/open-block-names scode-open-block-names)
+          (scode/open-block? scode-open-block?)
+          (scode/primitive-procedure? primitive-procedure?)
+          (scode/procedure? procedure?)
+          (scode/quotation-expression scode-quotation-expression)
+          (scode/quotation? scode-quotation?)
+          (scode/sequence-actions scode-sequence-actions)
+          (scode/sequence? scode-sequence?)
+          (scode/set-lambda-body! set-scode-lambda-body!)
+          (scode/symbol? symbol?)
+          (scode/the-environment? scode-the-environment?)
+          (scode/unassigned?-name scode-unassigned?-name)
+          (scode/unassigned?? scode-unassigned??)
+          (scode/variable-name scode-variable-name)
+          (scode/variable? scode-variable?)))
+
+(define-package (compiler reference-contexts)
+  (files "base/refctx")
+  (parent (compiler))
+  (export (compiler)
+          add-reference-context/adjacent-parents!
+          initialize-reference-contexts!
+          make-reference-context
+          modify-reference-contexts!
+          reference-context/adjacent-parent?
+          reference-context/block
+          reference-context/offset
+          reference-context/procedure
+          reference-context?
+          set-reference-context/offset!))
+
+(define-package (compiler macros)
+  (files "base/macros")
+  (parent (compiler))
+  (export (compiler)
+          cfg-node-case
+          define-enumeration
+          define-export
+          define-lvalue
+          define-pnode
+          define-root-type
+          define-rtl-expression
+          define-rtl-predicate
+          define-rtl-statement
+          define-rule
+          define-rvalue
+          define-snode
+          define-vector-slots
+          descriptor-list
+          enumeration-case
+          inst-ea
+          lap
+          last-reference
+          make-lvalue
+          make-pnode
+          make-rvalue
+          make-snode
+          package
+          rule-matcher))
+
+(define-package (compiler declarations)
+  (files "machines/aarch64/decls")
+  (parent (compiler))
+  (export (compiler)
+          sc
+          syntax-files!)
+  (import (scode-optimizer top-level)
+          sf/internal)
+  (initialization (initialize-package!)))
+
+(define-package (compiler top-level)
+  (files "base/toplev"
+         "base/crstop"
+         "base/asstop")
+  (parent (compiler))
+  (export ()
+          cbf
+          cf
+          compile-directory
+          compile-bin-file
+          compile-file
+          compile-file:force?
+          compile-file:override-usual-integrations
+          compile-file:sf-only?
+          compile-file:show-dependencies?
+          compile-procedure
+          compile-scode
+          compiler:compiled-code-pathname-type
+          compiler:reset!
+          lap->code)
+  (export (compiler)
+          canonicalize-label-name)
+  (export (compiler fg-generator)
+          *tl-metadata*
+          compile-recursively)
+  (export (compiler rtl-generator)
+          *ic-procedure-headers*
+          *rtl-continuations*
+          *rtl-expression*
+          *rtl-graphs*
+          *rtl-procedures*)
+  (export (compiler lap-syntaxer)
+          *block-label*
+          *external-labels*
+          label->object)
+  (export (compiler debug)
+          *root-expression*
+          *rtl-procedures*
+          *rtl-graphs*)
+  (import (runtime)
+          map-r7rs-scode-file
+          map-scode-library
+          r7rs-scode-file?
+          scode-library-name)
+  (import (scode-optimizer build-utilities)
+          directory-processor))
+
+(define-package (compiler debug)
+  (files "base/debug")
+  (parent (compiler))
+  (export ()
+          debug/find-continuation
+          debug/find-entry-node
+          debug/find-procedure
+          debug/where
+          dump-rtl
+          po
+          show-bblock-rtl
+          show-fg
+          show-fg-node
+          show-rtl
+          write-rtl-instructions))
+
+(define-package (compiler pattern-matcher/lookup)
+  (files "base/pmlook")
+  (parent (compiler))
+  (export (compiler)
+          generate-pattern-matcher
+          make-pattern-variable
+          pattern-contains-duplicates?
+          pattern-lookup
+          pattern-lookup-1
+          pattern-lookup-2
+          pattern-variable-name
+          pattern-variable?
+          pattern-variables))
+
+(define-package (compiler pattern-matcher/parser)
+  (files "base/pmpars")
+  (parent (compiler))
+  (export (compiler)
+          make-rule-matcher
+          parse-rule
+          rule->matcher
+          rule-result-expression)
+  (export (compiler macros)
+          make-rule-matcher
+          parse-rule
+          rule->matcher
+          rule-result-expression))
+
+(define-package (compiler pattern-matcher/early)
+  (files  "base/pmerly")
+  (parent (compiler))
+  (export (compiler)
+          early-parse-rule
+          early-pattern-lookup
+          early-make-rule
+          make-database-transformer
+          make-symbol-transformer
+          make-bit-mask-transformer))
+
+(define-package (compiler debugging-information)
+  (files "base/infnew")
+  (parent (compiler))
+  (export (compiler top-level)
+          info-generation-phase-1
+          info-generation-phase-2
+          info-generation-phase-3)
+  (export (compiler rtl-generator)
+          generated-dbg-continuation)
+  (import (runtime compiler-info)
+          make-dbg-info
+
+          make-dbg-expression
+          dbg-expression/block
+          dbg-expression/label
+          set-dbg-expression/label!
+
+          make-dbg-procedure
+          dbg-procedure/block
+          dbg-procedure/label
+          set-dbg-procedure/label!
+          dbg-procedure/name
+          dbg-procedure/required
+          dbg-procedure/optional
+          dbg-procedure/rest
+          dbg-procedure/auxiliary
+          dbg-procedure/external-label
+          set-dbg-procedure/external-label!
+          dbg-procedure<?
+
+          make-dbg-continuation
+          dbg-continuation/block
+          dbg-continuation/label
+          set-dbg-continuation/label!
+          dbg-continuation<?
+
+          make-dbg-block
+          dbg-block/parent
+          dbg-block/layout
+          dbg-block/stack-link
+          set-dbg-block/procedure!
+
+          make-dbg-variable
+          dbg-variable/value
+          set-dbg-variable/value!
+
+          dbg-block-name/dynamic-link
+          dbg-block-name/ic-parent
+          dbg-block-name/normal-closure
+          dbg-block-name/return-address
+          dbg-block-name/static-link
+
+          make-dbg-label-2
+          dbg-label/offset
+          set-dbg-label/external?!))
+
+(define-package (compiler portable-fasdump)
+  (files "base/fasdump")
+  (parent ())                           ;** This code should be portable.
+  (export ()
+          fasl-format:aarch64be
+          fasl-format:aarch64le
+          fasl-format:alpha
+          fasl-format:amd64
+          fasl-format:arm32be
+          fasl-format:arm32le
+          fasl-format:i386
+          fasl-format:mips32be
+          fasl-format:mips32le
+          fasl-format:ppc32
+          fasl-format:sparc32
+          fasl-format:svm1-32be
+          fasl-format:svm1-32le
+          fasl-format:svm1-64be
+          fasl-format:svm1-64le
+          portable-fasdump))
+
+(define-package (compiler constraints)
+   (files "base/constr")
+   (parent (compiler))
+   (export (compiler)
+           make-constraint
+           constraint/element
+           constraint/graph-head
+           constraint/afters
+           constraint/closed?
+           constraint-add!
+           add-constraint-element!
+           add-constraint-set!
+           make-constraint-graph
+           constraint-graph/entry-nodes
+           constraint-graph/closed?
+           close-constraint-graph!
+           close-constraint-node!
+           order-per-constraints
+           order-per-constraints/extracted
+           legal-ordering-per-constraints?
+           with-new-constraint-marks
+           constraint-marked?
+           constraint-mark!
+           transitively-close-dag!
+           reverse-postorder))
+
+(define-package (compiler fg-generator)
+  (files "fggen/canon"                  ;SCode canonicalizer
+         "fggen/fggen"                  ;SCode->flow-graph converter
+         "fggen/declar"                 ;Declaration handling
+         )
+  (parent (compiler))
+  (export (compiler top-level)
+          canonicalize/top-level
+          construct-graph)
+  (import (runtime scode-data)
+          &pair-car
+          &pair-cdr
+          &triple-first
+          &triple-second
+          &triple-third))
+
+(define-package (compiler fg-optimizer)
+  (files "fgopt/outer"                  ;outer analysis
+         "fgopt/sideff"                 ;side effect analysis
+         )
+  (parent (compiler))
+  (export (compiler top-level)
+          clear-call-graph!
+          compute-call-graph!
+          outer-analysis
+          side-effect-analysis))
+
+(define-package (compiler fg-optimizer fold-constants)
+  (files "fgopt/folcon")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) fold-constants))
+
+(define-package (compiler fg-optimizer operator-analysis)
+  (files "fgopt/operan")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) operator-analysis))
+
+(define-package (compiler fg-optimizer variable-indirection)
+  (files "fgopt/varind")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) initialize-variable-indirections!))
+
+(define-package (compiler fg-optimizer environment-optimization)
+  (files "fgopt/envopt")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) optimize-environments!))
+
+(define-package (compiler fg-optimizer closure-analysis)
+  (files "fgopt/closan")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) identify-closure-limits!))
+
+(define-package (compiler fg-optimizer continuation-analysis)
+  (files "fgopt/contan")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level)
+          continuation-analysis
+          setup-block-static-links!))
+
+(define-package (compiler fg-optimizer compute-node-offsets)
+  (files "fgopt/offset")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) compute-node-offsets))
+
+(define-package (compiler fg-optimizer connectivity-analysis)
+  (files "fgopt/conect")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) connectivity-analysis))
+
+(define-package (compiler fg-optimizer delete-integrated-parameters)
+  (files "fgopt/delint")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) delete-integrated-parameters))
+
+(define-package (compiler fg-optimizer design-environment-frames)
+  (files "fgopt/desenv")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) design-environment-frames!))
+
+(define-package (compiler fg-optimizer setup-block-types)
+  (files "fgopt/blktyp")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level)
+          setup-block-types!
+          setup-closure-contexts!)
+  (export (compiler)
+          indirection-block-procedure))
+
+(define-package (compiler fg-optimizer simplicity-analysis)
+  (files "fgopt/simple")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) simplicity-analysis)
+  (export (compiler fg-optimizer subproblem-ordering)
+          new-subproblem/compute-simplicity!))
+
+(define-package (compiler fg-optimizer simulate-application)
+  (files "fgopt/simapp")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) simulate-application))
+
+(define-package (compiler fg-optimizer subproblem-free-variables)
+  (files "fgopt/subfre")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) compute-subproblem-free-variables)
+  (export (compiler fg-optimizer) map-union)
+  (export (compiler fg-optimizer subproblem-ordering)
+          new-subproblem/compute-free-variables!))
+
+(define-package (compiler fg-optimizer subproblem-ordering)
+  (files "fgopt/order")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) subproblem-ordering))
+
+(define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
+  (files "fgopt/reord" "fgopt/reuse")
+  (parent (compiler fg-optimizer subproblem-ordering))
+  (export (compiler top-level) setup-frame-adjustments)
+  (export (compiler fg-optimizer subproblem-ordering)
+          order-subproblems/maybe-overwrite-block))
+
+(define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
+   (files "fgopt/param")
+   (parent (compiler fg-optimizer subproblem-ordering))
+   (export (compiler fg-optimizer subproblem-ordering)
+           parameter-analysis))
+
+(define-package (compiler fg-optimizer return-equivalencing)
+  (files "fgopt/reteqv")
+  (parent (compiler fg-optimizer))
+  (export (compiler top-level) find-equivalent-returns!))
+
+(define-package (compiler rtl-generator)
+  (files "rtlgen/rtlgen"                ;RTL generator
+         "rtlgen/rgstmt"                ;statements
+         "rtlgen/fndvar"                ;find variables
+         "machines/aarch64/rgspcm"      ;special close-coded primitives
+         "rtlbase/rtline"               ;linearizer
+         )
+  (parent (compiler))
+  (export (compiler)
+          make-linearizer)
+  (export (compiler top-level)
+          generate/top-level
+          linearize-rtl
+          setup-bblock-continuations!)
+  (export (compiler debug)
+          linearize-rtl)
+  (import (compiler top-level)
+          label->object))
+
+(define-package (compiler rtl-generator generate/procedure-header)
+  (files "rtlgen/rgproc")
+  (parent (compiler rtl-generator))
+  (export (compiler rtl-generator) generate/procedure-header))
+
+(define-package (compiler rtl-generator combination/inline)
+  (files "rtlgen/opncod")
+  (parent (compiler rtl-generator))
+  (export (compiler rtl-generator) combination/inline)
+  (export (compiler top-level) open-coding-analysis))
+
+(define-package (compiler rtl-generator find-block)
+  (files "rtlgen/fndblk")
+  (parent (compiler rtl-generator))
+  (export (compiler rtl-generator) find-block))
+
+(define-package (compiler rtl-generator generate/rvalue)
+  (files "rtlgen/rgrval")
+  (parent (compiler rtl-generator))
+  (export (compiler rtl-generator)
+          generate/rvalue
+          load-closure-environment
+          make-cons-closure-indirection
+          make-cons-closure-redirection
+          make-closure-redirection
+          make-ic-cons
+          make-non-trivial-closure-cons
+          make-trivial-closure-cons
+          redirect-closure))
+
+(define-package (compiler rtl-generator generate/combination)
+  (files "rtlgen/rgcomb")
+  (parent (compiler rtl-generator))
+  (export (compiler rtl-generator)
+          generate/combination
+          rtl:bump-closure)
+  (export (compiler rtl-generator combination/inline)
+          generate/invocation-prefix))
+
+(define-package (compiler rtl-generator generate/return)
+  (files "rtlgen/rgretn")
+  (parent (compiler rtl-generator))
+  (export (compiler rtl-generator)
+          make-return-operand
+          generate/return
+          generate/return*
+          generate/trivial-return))
+
+(define-package (compiler rtl-cse)
+  (files "rtlopt/rcse1"                 ;RTL common subexpression eliminator
+         "rtlopt/rcse2"
+         "rtlopt/rcseep"                ;CSE expression predicates
+         "rtlopt/rcseht"                ;CSE hash table
+         "rtlopt/rcserq"                ;CSE register/quantity abstractions
+         "rtlopt/rcsesr"                ;CSE stack references
+         )
+  (parent (compiler))
+  (export (compiler top-level) common-subexpression-elimination))
+
+(define-package (compiler rtl-optimizer)
+  (files "rtlopt/rdebug")
+  (parent (compiler)))
+
+(define-package (compiler rtl-optimizer invertible-expression-elimination)
+  (files "rtlopt/rinvex")
+  (parent (compiler rtl-optimizer))
+  (export (compiler top-level) invertible-expression-elimination))
+
+(define-package (compiler rtl-optimizer common-suffix-merging)
+  (files "rtlopt/rtlcsm")
+  (parent (compiler rtl-optimizer))
+  (export (compiler top-level) merge-common-suffixes!))
+
+(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
+  (files "rtlopt/rdflow")
+  (parent (compiler rtl-optimizer))
+  (export (compiler top-level) rtl-dataflow-analysis))
+
+(define-package (compiler rtl-optimizer rtl-rewriting)
+  (files "rtlopt/rerite")
+  (parent (compiler rtl-optimizer))
+  (export (compiler top-level)
+          rtl-rewriting:post-cse
+          rtl-rewriting:pre-cse)
+  (export (compiler lap-syntaxer)
+          add-rewriting-rule!
+          add-pre-cse-rewriting-rule!))
+
+(define-package (compiler rtl-optimizer lifetime-analysis)
+  (files "rtlopt/rlife")
+  (parent (compiler rtl-optimizer))
+  (export (compiler top-level) lifetime-analysis)
+  (export (compiler rtl-optimizer code-compression) mark-set-registers!))
+
+(define-package (compiler rtl-optimizer code-compression)
+  (files "rtlopt/rcompr")
+  (parent (compiler rtl-optimizer))
+  (export (compiler top-level) code-compression))
+
+(define-package (compiler rtl-optimizer register-allocation)
+  (files "rtlopt/ralloc")
+  (parent (compiler rtl-optimizer))
+  (export (compiler top-level) register-allocation))
+
+(define-package (compiler lap-syntaxer)
+  (files "back/lapgn1"                  ;LAP generator
+         "back/lapgn2"                  ; "      "
+         "back/lapgn3"                  ; "      "
+         "back/regmap"                  ;Hardware register allocator
+         "back/checks"                  ;Interrupt checks
+         "machines/aarch64/lapgen"      ;code generation rules
+         "machines/aarch64/rules1"      ;  "      "        "
+         "machines/aarch64/rules2"      ;  "      "        "
+         "machines/aarch64/rules3"      ;  "      "        "
+         "machines/aarch64/rules4"      ;  "      "        "
+         "machines/aarch64/rulfix"      ;  "      "        "
+         "machines/aarch64/rulflo"      ;  "      "        "
+         "machines/aarch64/rulrew"      ;code rewriting rules
+         "back/syntax"                  ;Generic syntax phase
+         "back/syerly"                  ;Early binding version
+         "machines/aarch64/coerce"      ;Coercions: integer -> bit string
+         "back/asmmac"                  ;Macros for hairy syntax
+         "machines/aarch64/insmac"      ;Macros for hairy syntax
+         "machines/aarch64/insutl"      ;aarch64 instruction utilities
+         "machines/aarch64/instr1"      ;aarch64 instructions
+         "machines/aarch64/instr2"      ;  "        "
+         "machines/aarch64/instrf"      ;  "        " fp instructions
+         )
+  (parent (compiler))
+  (export (compiler)
+          available-machine-registers
+          lap-generator/match-rtl-instruction
+          lap:make-entry-point
+          lap:make-label-statement
+          lap:make-unconditional-branch
+          lap:syntax-instruction)
+  (export (compiler top-level)
+          *block-associations*
+          *interned-assignments*
+          *interned-constants*
+          *interned-global-links*
+          *interned-uuo-links*
+          *interned-static-variables*
+          *interned-variables*
+          *next-constant*
+          generate-lap)
+  (import (scode-optimizer expansion)
+          scode->scode-expander))
+
+(define-package (compiler lap-syntaxer map-merger)
+  (files "back/mermap")
+  (parent (compiler lap-syntaxer))
+  (export (compiler lap-syntaxer)
+          merge-register-maps))
+
+(define-package (compiler lap-syntaxer linearizer)
+  (files "back/linear")
+  (parent (compiler lap-syntaxer))
+  (export (compiler lap-syntaxer)
+          add-end-of-block-code!
+          add-extra-code!
+          bblock-linearize-lap
+          extra-code-block/xtra
+          declare-extra-code-block!
+          find-extra-code-block
+          linearize-lap
+          set-current-branches!
+          set-extra-code-block/xtra!)
+  (export (compiler top-level)
+          *end-of-block-code*
+          linearize-lap))
+
+(define-package (compiler lap-optimizer)
+  (files "machines/aarch64/lapopt")
+  (parent (compiler))
+  (export (compiler top-level)
+          optimize-linear-lap))
+
+(define-package (compiler assembler)
+  (files "machines/aarch64/assmd"       ;Machine dependent
+         "back/symtab"                  ;Symbol tables
+         "back/bitutl"                  ;Assembly blocks
+         "back/bittop"                  ;Assembler top level
+         )
+  (parent (compiler))
+  (export (compiler)
+          instruction-append)
+  (export (compiler top-level)
+          assemble))
+
+(define-package (compiler disassembler)
+  (files "machines/aarch64/dassm1"
+         "machines/aarch64/dassm2"
+         "machines/aarch64/dassm3")
+  (parent (compiler))
+  (export ()
+          compiler:write-lap-file
+          compiler:disassemble)
+  (import (runtime compiler-info)
+          compiled-code-block/dbg-info
+          dbg-info-vector/blocks-vector
+          dbg-info-vector?
+          dbg-info/labels
+          dbg-label/external?
+          dbg-label/name
+          dbg-labels/find-offset))
diff --git a/src/compiler/machines/aarch64/compiler.sf b/src/compiler/machines/aarch64/compiler.sf
new file mode 100644
index 000000000..74b77c285
--- /dev/null
+++ b/src/compiler/machines/aarch64/compiler.sf
@@ -0,0 +1,89 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Script to incrementally syntax the compiler
+
+(load-option 'cref)
+(load-option 'sf)
+
+;; Guarantee that the compiler's package structure exists.
+(if (not (name->package '(compiler)))
+    (let ((package-set
+	   (merge-pathnames
+	    (enough-pathname
+	     (merge-pathnames (package-set-pathname "compiler"))
+	     cref/source-root)
+	    cref/object-root)))
+      (if (not (file-exists? package-set))
+	  (cref/generate-trivial-constructor "compiler"))
+      (construct-packages-from-file (fasload package-set))))
+
+;; Guarantee that the necessary syntactic transforms and optimizers
+;; are loaded.
+(if (lexical-unreferenceable? (->environment '(compiler)) 'syntax-files!)
+    (let ((sf-and-load
+	   (lambda (files package)
+	     (fluid-let ((sf/default-syntax-table (->environment package)))
+	       (sf-conditionally files))
+	     (for-each (lambda (file)
+			 (receive (scm bin spec)
+				  (sf/pathname-defaulting file #f #f)
+			   scm spec
+			   (load bin package)))
+		       files))))
+      (load-option 'hash-table)
+      (fresh-line)
+      (newline)
+      (write-string "---- Loading compile-time files ----")
+      (newline)
+      (sf-and-load '("base/switch") '(compiler))
+      (sf-and-load '("base/macros") '(compiler macros))
+      (sf-and-load '("machines/aarch64/decls") '(compiler declarations))
+      (let ((environment (->environment '(compiler declarations))))
+	(set! (access source-file-expression environment) "*.scm")
+	((access initialize-package! environment)))
+      (sf-and-load '("base/pmlook") '(compiler pattern-matcher/lookup))
+      (sf-and-load '("base/pmpars") '(compiler pattern-matcher/parser))
+      (sf-and-load '("machines/aarch64/machine") '(compiler))
+      (fluid-let ((sf/default-declarations
+		   '((integrate-external "insseq")
+		     (integrate-external "machine")
+		     (usual-definition (set expt)))))
+	(sf-and-load '("machines/aarch64/assmd") '(compiler assembler)))
+      (sf-and-load '("back/syntax") '(compiler lap-syntaxer))
+      (sf-and-load '("machines/aarch64/coerce"
+		     "back/asmmac"
+		     "machines/aarch64/insmac")
+		   '(compiler lap-syntaxer))
+      (sf-and-load '("base/scode") '(compiler))
+      (sf-and-load '("base/pmerly") '(compiler pattern-matcher/early))
+      (sf-and-load '("back/syerly") '(compiler lap-syntaxer))))
+
+;; Resyntax any files that need it.
+((access syntax-files! (->environment '(compiler))))
+
+;; Rebuild the package constructors and cref.
+(cref/generate-constructors "compiler")
\ No newline at end of file
diff --git a/src/compiler/machines/aarch64/decls.scm b/src/compiler/machines/aarch64/decls.scm
new file mode 100644
index 000000000..66ace9402
--- /dev/null
+++ b/src/compiler/machines/aarch64/decls.scm
@@ -0,0 +1,596 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler File Dependencies
+;;; package: (compiler declarations)
+
+(declare (usual-integrations))
+
+(define (initialize-package!)
+  (add-event-receiver! event:after-restore reset-source-nodes!)
+  (reset-source-nodes!))
+
+(define (reset-source-nodes!)
+  (set! source-filenames '())
+  (set! source-hash)
+  (set! source-nodes)
+  (set! source-nodes/by-rank)
+  unspecific)
+
+(define (maybe-setup-source-nodes!)
+  (if (null? source-filenames)
+      (setup-source-nodes!)))
+
+(define (setup-source-nodes!)
+  (let ((filenames
+         (append-map!
+          (lambda (subdirectory)
+            (map (lambda (pathname)
+                   (string-append subdirectory
+                                  "/"
+                                  (pathname-name pathname)))
+                 (directory-read
+                  (string-append subdirectory
+                                 "/"
+                                 source-file-expression))))
+          '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt"
+                   "machines/aarch64"))))
+    (if (null? filenames)
+        (error "Can't find source files of compiler"))
+    (set! source-filenames filenames))
+  (set! source-hash (make-string-hash-table))
+  (set! source-nodes
+        (map (lambda (filename)
+               (let ((node (make/source-node filename)))
+                 (hash-table-set! source-hash filename node)
+                 node))
+             source-filenames))
+  (initialize/syntax-dependencies!)
+  (initialize/integration-dependencies!)
+  (source-nodes/rank!))
+
+(define source-file-expression "*.scm")
+(define source-filenames)
+(define source-hash)
+(define source-nodes)
+(define source-nodes/by-rank)
+
+(define (filename/append directory . names)
+  (map (lambda (name) (string-append directory "/" name)) names))
+
+(define-structure (source-node
+                   (conc-name source-node/)
+                   (constructor %make/source-node (filename pathname)))
+  (filename #f read-only #t)
+  (pathname #f read-only #t)
+  (forward-links '())
+  (backward-links '())
+  (forward-closure '())
+  (backward-closure '())
+  (dependencies '())
+  (dependents '())
+  (rank #f)
+  (syntax-table #f)
+  (declarations '())
+  (modification-time #f))
+
+(define (make/source-node filename)
+  (%make/source-node filename (->pathname filename)))
+
+(define (filename->source-node filename)
+  (let ((node (hash-table-ref/default source-hash filename #f)))
+    (if (not node)
+        (error "Unknown source file:" filename))
+    node))
+
+(define (source-node/circular? node)
+  (memq node (source-node/backward-closure node)))
+
+(define (source-node/link! node dependency)
+  (if (not (memq dependency (source-node/backward-links node)))
+      (begin
+        (set-source-node/backward-links!
+         node
+         (cons dependency (source-node/backward-links node)))
+        (set-source-node/forward-links!
+         dependency
+         (cons node (source-node/forward-links dependency)))
+        (source-node/close! node dependency))))
+
+(define (source-node/close! node dependency)
+  (if (not (memq dependency (source-node/backward-closure node)))
+      (begin
+        (set-source-node/backward-closure!
+         node
+         (cons dependency (source-node/backward-closure node)))
+        (set-source-node/forward-closure!
+         dependency
+         (cons node (source-node/forward-closure dependency)))
+        (for-each (lambda (dependency)
+                    (source-node/close! node dependency))
+                  (source-node/backward-closure dependency))
+        (for-each (lambda (node)
+                    (source-node/close! node dependency))
+                  (source-node/forward-closure node)))))
+
+;;;; Rank
+
+(define (source-nodes/rank!)
+  (compute-dependencies! source-nodes)
+  (compute-ranks! source-nodes)
+  (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
+  unspecific)
+
+(define (compute-dependencies! nodes)
+  (for-each (lambda (node)
+              (set-source-node/dependencies!
+               node
+               (remove (lambda (node*)
+                         (memq node (source-node/backward-closure node*)))
+                       (source-node/backward-closure node)))
+              (set-source-node/dependents!
+               node
+               (remove (lambda (node*)
+                         (memq node (source-node/forward-closure node*)))
+                       (source-node/forward-closure node))))
+            nodes))
+
+(define (compute-ranks! nodes)
+  (let loop ((nodes nodes) (unranked-nodes '()))
+    (if (null? nodes)
+        (if (not (null? unranked-nodes))
+            (loop unranked-nodes '()))
+        (loop (cdr nodes)
+              (let ((node (car nodes)))
+                (let ((rank (source-node/rank* node)))
+                  (if rank
+                      (begin
+                        (set-source-node/rank! node rank)
+                        unranked-nodes)
+                      (cons node unranked-nodes))))))))
+
+(define (source-node/rank* node)
+  (let loop ((nodes (source-node/dependencies node)) (rank -1))
+    (if (null? nodes)
+        (1+ rank)
+        (let ((rank* (source-node/rank (car nodes))))
+          (and rank*
+               (loop (cdr nodes) (max rank rank*)))))))
+
+(define (source-nodes/sort-by-rank nodes)
+  (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
+
+;;;; File Syntaxer
+
+(define (syntax-files!)
+  (maybe-setup-source-nodes!)
+  (for-each
+   (lambda (node)
+     (let ((modification-time
+            (receive (scm bin spec)
+                     (sf/pathname-defaulting (source-node/pathname node) #f #f)
+              spec
+              (let ((source (file-modification-time scm))
+                    (binary (file-modification-time bin)))
+                (if (not source)
+                    (error "Missing source file" (source-node/filename node)))
+                (and binary (< source binary) binary)))))
+     (set-source-node/modification-time! node modification-time)
+     (if (not modification-time)
+         (write-notification-line
+          (lambda (port)
+            (write-string "Source file newer than binary: " port)
+            (write (source-node/filename node) port))))))
+   source-nodes)
+  (if compiler:enable-integration-declarations?
+      (begin
+        (for-each
+         (lambda (node)
+           (let ((time (source-node/modification-time node)))
+             (if (and time
+                      (any (lambda (node*)
+                             (let ((newer?
+                                    (let ((time*
+                                           (source-node/modification-time
+                                            node*)))
+                                      (or (not time*)
+                                          (> time* time)))))
+                               (if newer?
+                                   (write-notification-line
+                                    (lambda (port)
+                                      (write-string "Binary file " port)
+                                      (write (source-node/filename node) port)
+                                      (write-string " newer than dependency "
+                                                    port)
+                                      (write (source-node/filename node*)
+                                             port))))
+                               newer?))
+                           (source-node/dependencies node)))
+                 (set-source-node/modification-time! node #f))))
+         source-nodes)
+        (for-each
+         (lambda (node)
+           (if (not (source-node/modification-time node))
+               (for-each (lambda (node*)
+                           (if (source-node/modification-time node*)
+                               (write-notification-line
+                                (lambda (port)
+                                  (write-string "Binary file " port)
+                                  (write (source-node/filename node*) port)
+                                  (write-string " depends on " port)
+                                  (write (source-node/filename node) port))))
+                           (set-source-node/modification-time! node* #f))
+                         (source-node/forward-closure node))))
+         source-nodes)))
+  (for-each (lambda (node)
+              (if (not (source-node/modification-time node))
+                  (pathname-delete!
+                   (pathname-new-type (source-node/pathname node) "ext"))))
+            source-nodes/by-rank)
+  (write-notification-line
+   (lambda (port)
+     (write-string "Begin pass 1:" port)))
+  (bind-condition-handler (list condition-type:simple-warning)
+      (lambda (condition)
+        (if (string=? (access-condition condition 'MESSAGE)
+                      "Missing externs file:")
+            (muffle-warning)))
+    (lambda ()
+      (for-each (lambda (node)
+                  (if (not (source-node/modification-time node))
+                      (source-node/syntax! node)))
+                source-nodes/by-rank)))
+  (if (any (lambda (node)
+             (and (not (source-node/modification-time node))
+                  (source-node/circular? node)))
+           source-nodes/by-rank)
+      (begin
+        (write-notification-line
+         (lambda (port)
+           (write-string "Begin pass 2:" port)))
+        (for-each (lambda (node)
+                    (if (not (source-node/modification-time node))
+                        (if (source-node/circular? node)
+                            (source-node/syntax! node)
+                            (source-node/touch! node))))
+                  source-nodes/by-rank))))
+
+(define (source-node/touch! node)
+  (receive (input-pathname bin-pathname spec-pathname)
+      (sf/pathname-defaulting (source-node/pathname node) "" #f)
+    input-pathname
+    (pathname-touch! bin-pathname)
+    (pathname-touch! (pathname-new-type bin-pathname "ext"))
+    (if spec-pathname (pathname-touch! spec-pathname))))
+
+(define (pathname-touch! pathname)
+  (if (file-exists? pathname)
+      (begin
+        (write-notification-line
+         (lambda (port)
+           (write-string "Touch file: " port)
+           (write (enough-namestring pathname) port)))
+        (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+  (if (file-exists? pathname)
+      (begin
+        (write-notification-line
+         (lambda (port)
+           (write-string "Delete file: " port)
+           (write (enough-namestring pathname) port)))
+        (delete-file pathname))))
+
+(define (sc filename)
+  (maybe-setup-source-nodes!)
+  (source-node/syntax! (filename->source-node filename)))
+
+(define (source-node/syntax! node)
+  (receive (input-pathname bin-pathname spec-pathname)
+      (sf/pathname-defaulting (source-node/pathname node) "" #f)
+    (sf/internal
+     input-pathname bin-pathname spec-pathname
+     (source-node/syntax-table node)
+     ((if compiler:enable-integration-declarations?
+          identity-procedure
+          (lambda (declarations)
+            (remove integration-declaration? declarations)))
+      (source-node/declarations node)))))
+
+;;;; Syntax dependencies
+
+(define (initialize/syntax-dependencies!)
+  (let ((file-dependency/syntax/join
+         (lambda (filenames syntax-table)
+           (for-each (lambda (filename)
+                       (set-source-node/syntax-table!
+                        (filename->source-node filename)
+                        syntax-table))
+                     filenames))))
+    (file-dependency/syntax/join
+     (append (filename/append "base"
+                              "toplev" "asstop" "crstop"
+                              "blocks" "cfg1" "cfg2" "cfg3" "constr"
+                              "contin" "ctypes" "debug" "enumer"
+                              "infnew" "lvalue" "object" "pmerly" "proced"
+                              "refctx" "rvalue" "scode" "sets" "subprb"
+                              "switch" "utils")
+             (filename/append "back"
+                              "asmmac" "bittop" "bitutl" "checks" "insseq"
+                              "lapgn1" "lapgn2" "lapgn3" "linear" "regmap"
+                              "symtab" "syntax")
+             (filename/append "machines/aarch64"
+                              "dassm1" "insmac" "lapopt" "machine" "rgspcm"
+                              "rulrew")
+             (filename/append "fggen"
+                              "declar" "fggen" "canon")
+             (filename/append "fgopt"
+                              "blktyp" "closan" "conect" "contan" "delint"
+                              "desenv" "envopt" "folcon" "offset" "operan"
+                              "order" "outer" "param" "reord" "reteqv" "reuse"
+                              "sideff" "simapp" "simple" "subfre" "varind")
+             (filename/append "rtlbase"
+                              "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
+                              "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
+                              "valclass")
+             (filename/append "rtlgen"
+                              "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
+                              "rgretn" "rgrval" "rgstmt" "rtlgen")
+             (filename/append "rtlopt"
+                              "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
+                              "rcseht" "rcserq" "rcsesr" "rdebug" "rdflow"
+                              "rerite" "rinvex" "rlife" "rtlcsm"))
+     (->environment '(COMPILER)))
+    (file-dependency/syntax/join
+     (filename/append "machines/aarch64"
+                      "lapgen"
+                      "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo"
+                      "insutl" "instr1" "instr2" "instrf")
+     (->environment '(COMPILER LAP-SYNTAXER)))))
+
+;;;; Integration Dependencies
+
+(define (initialize/integration-dependencies!)
+
+  (define (add-declaration! declaration filenames)
+    (for-each (lambda (filenames)
+                (let ((node (filename->source-node filenames)))
+                  (set-source-node/declarations!
+                   node
+                   (cons declaration
+                         (source-node/declarations node)))))
+              filenames))
+
+  (let* ((front-end-base
+          (filename/append "base"
+                           "blocks" "cfg1" "cfg2" "cfg3"
+                           "contin" "ctypes" "enumer" "lvalue"
+                           "object" "proced" "rvalue"
+                           "scode" "subprb" "utils"))
+         (aarch64-base
+          (append (filename/append "machines/aarch64" "machine")
+                  (filename/append "back" "asutl")))
+         (rtl-base
+          (filename/append "rtlbase"
+                           "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+                           "rtlty2"))
+         (cse-base
+          (filename/append "rtlopt"
+                           "rcse1" "rcseht" "rcserq" "rcsesr"))
+         (cse-all
+          (append (filename/append "rtlopt"
+                                   "rcse2" "rcseep")
+                  cse-base))
+         (instruction-base
+          (filename/append "machines/aarch64" "assmd" "machine"))
+         (lapgen-base
+          (append (filename/append "back" "linear" "regmap")
+                  (filename/append "machines/aarch64" "lapgen")))
+         (assembler-base
+          (append (filename/append "back" "symtab")
+                  (filename/append "machines/aarch64" "insutl")))
+         (lapgen-body
+          (append
+           (filename/append "back" "checks" "lapgn1" "lapgn2" "syntax")
+           (filename/append "machines/aarch64"
+                            "rules1" "rules2" "rules3" "rules4"
+                            "rulfix" "rulflo")))
+         (assembler-body
+          (append
+           (filename/append "back" "bittop")
+           (filename/append "machines/aarch64"
+                            "instr1" "instr2" "instrf"))))
+
+    (define (file-dependency/integration/join filenames dependencies)
+      (for-each (lambda (filename)
+                  (file-dependency/integration/make filename dependencies))
+                filenames))
+
+    (define (file-dependency/integration/make filename dependencies)
+      (let ((node (filename->source-node filename)))
+        (for-each (lambda (dependency)
+                    (let ((node* (filename->source-node dependency)))
+                      (if (not (eq? node node*))
+                          (source-node/link! node node*))))
+                  dependencies)))
+
+    (define (define-integration-dependencies directory name directory* . names)
+      (file-dependency/integration/make
+       (string-append directory "/" name)
+       (apply filename/append directory* names)))
+
+    (define-integration-dependencies "machines/aarch64"
+      "machine" "back" "asutl")
+    (define-integration-dependencies "base" "object" "base" "enumer")
+    (define-integration-dependencies "base" "enumer" "base" "object")
+    (define-integration-dependencies "base" "cfg1" "base" "object")
+    (define-integration-dependencies "base" "cfg2" "base"
+      "cfg1" "cfg3" "object")
+    (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
+    (define-integration-dependencies "base" "ctypes" "base"
+      "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
+    (define-integration-dependencies "base" "rvalue" "base"
+      "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
+    (define-integration-dependencies "base" "lvalue" "base"
+      "blocks" "object" "proced" "rvalue" "utils")
+    (define-integration-dependencies "base" "blocks" "base"
+      "enumer" "lvalue" "object" "proced" "rvalue")
+    (define-integration-dependencies "base" "proced" "base"
+      "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
+      "rvalue" "utils")
+    (define-integration-dependencies "base" "contin" "base"
+      "blocks" "cfg3" "ctypes")
+    (define-integration-dependencies "base" "subprb" "base"
+      "cfg3" "contin" "enumer" "object" "proced")
+
+    (define-integration-dependencies "machines/aarch64" "machine" "rtlbase"
+      "rtlreg" "rtlty1" "rtlty2")
+
+    (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+    (define-integration-dependencies "rtlbase" "rgraph" "machines/aarch64"
+      "machine")
+    (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+      "cfg1" "cfg2" "cfg3")
+    (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+    (define-integration-dependencies "rtlbase" "rtlcon" "machines/aarch64"
+      "machine")
+    (file-dependency/integration/join (filename/append "rtlbase" "rtlcon")
+                                      rtl-base)
+    (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
+      "rtlreg" "rtlty1")
+    (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
+    (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
+      "rtlcfg" "rtlty2")
+    (define-integration-dependencies "rtlbase" "rtlobj" "base"
+      "cfg1" "object" "utils")
+    (define-integration-dependencies "rtlbase" "rtlreg" "machines/aarch64"
+      "machine")
+    (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
+      "rgraph" "rtlty1")
+    (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
+    (define-integration-dependencies "rtlbase" "rtlty2" "machines/aarch64"
+      "machine")
+    (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
+
+    (file-dependency/integration/join
+     (append
+      (filename/append "base" "refctx")
+      (filename/append "fggen"
+                       "declar" "fggen") ; "canon" needs no integrations
+      (filename/append "fgopt"
+                       "blktyp" "closan" "conect" "contan" "delint" "desenv"
+                       "envopt" "folcon" "offset" "operan" "order" "param"
+                       "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
+                       "subfre" "varind"))
+     (append aarch64-base front-end-base))
+
+    (define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
+
+    (file-dependency/integration/join
+     (filename/append "rtlgen"
+                      "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
+                      "rgrval" "rgstmt" "rtlgen")
+     (append aarch64-base front-end-base rtl-base))
+
+    (file-dependency/integration/join
+     (append cse-all
+             (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
+                              "rerite" "rinvex" "rlife" "rtlcsm")
+             (filename/append "machines/aarch64" "rulrew"))
+     (append aarch64-base rtl-base))
+
+    (file-dependency/integration/join cse-all cse-base)
+
+    (file-dependency/integration/join
+     (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+     (filename/append "rtlbase" "regset"))
+
+    (file-dependency/integration/join
+     (filename/append "rtlopt" "rcseht" "rcserq")
+     (filename/append "base" "object"))
+
+    (define-integration-dependencies "rtlopt" "rlife"  "base" "cfg2")
+
+    (let ((dependents
+           (append instruction-base
+                   lapgen-base
+                   lapgen-body
+                   assembler-base
+                   assembler-body
+                   (filename/append "back" "linear" "syerly"))))
+      (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
+      (file-dependency/integration/join dependents instruction-base))
+
+    (file-dependency/integration/join (append lapgen-base lapgen-body)
+                                      lapgen-base)
+
+    (file-dependency/integration/join (append assembler-base assembler-body)
+                                      assembler-base)
+
+    (define-integration-dependencies "back" "checks" "base" "cfg1" "cfg2")
+    (define-integration-dependencies "back" "checks" "rtlbase"
+      "rtlcfg" "rtlobj" "rtlty1")
+    (define-integration-dependencies "back" "lapgn1" "base"
+      "cfg1" "cfg2" "utils")
+    (define-integration-dependencies "back" "lapgn1" "rtlbase"
+      "rgraph" "rtlcfg")
+    (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
+    (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
+    (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
+    (define-integration-dependencies "back" "mermap" "back" "regmap")
+    (define-integration-dependencies "back" "regmap" "base" "utils")
+    (define-integration-dependencies "back" "symtab" "base" "utils"))
+
+  (for-each (lambda (node)
+              (let ((links (source-node/backward-links node)))
+                (if (not (null? links))
+                    (set-source-node/declarations!
+                     node
+                     (cons (make-integration-declaration
+                            (source-node/pathname node)
+                            (map source-node/pathname links))
+                           (source-node/declarations node))))))
+            source-nodes))
+
+(define (make-integration-declaration pathname integration-dependencies)
+  `(INTEGRATE-EXTERNAL
+    ,@(map (let ((default
+                  (make-pathname
+                   #f
+                   #f
+                   (cons 'RELATIVE
+                         (make-list
+                          (length (cdr (pathname-directory pathname)))
+                          'UP))
+                   #f
+                   #f
+                   #f)))
+             (lambda (pathname)
+               (merge-pathnames pathname default)))
+           integration-dependencies)))
+
+(define (integration-declaration? declaration)
+  (eq? (car declaration) 'INTEGRATE-EXTERNAL))
diff --git a/src/compiler/machines/aarch64/instr.scm b/src/compiler/machines/aarch64/instr.scm
new file mode 100644
index 000000000..d4b328495
--- /dev/null
+++ b/src/compiler/machines/aarch64/instr.scm
@@ -0,0 +1,1905 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; AArch Instruction Set
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+;;; Idea for branch tensioning: in every @PCR, allow an optional
+;;; temporary register, like (@PCR <label> (T <temp>)); then assemble
+;;; into a two-instruction sequence that uses the temporary register.
+;;;
+;;; Not really necessary: x16 and x17 are for that purpose.
+;;;
+;;; Syntax notes:
+;;;
+;;; - Should shifted immediates be (* 8 (&U ...)), (&U (* 8 ...)), (LSL
+;;;   (&U ...) 3), or (&U (LSL ... 3))?
+
+;;;; Helpers, for insutl.scm
+
+(define (sf-size size)
+  (case size
+    ((W) 0)
+    ((X) 1)
+    (else #f)))
+
+(define (vregister v)
+  (and (<= 0 v 31)
+       v))
+
+(define (register<31 r)
+  (and (<= 0 r 30)
+       r))
+
+(define (register-31=z r)
+  (cond ((eq? r 'Z) 31)
+        ((<= 0 r 30) r)
+        (else #f)))
+
+(define (register-31=sp r)
+  (cond ((<= 0 r 31) r)
+        (else #f)))
+
+(define (msr-pstatefield x)
+  (case x
+    ((SPSel) #b000101)
+    ((DAIFSet) #b011110)
+    ((DAIFClr) #b011111)
+    ((UAO) #b000011)
+    ((PAN) #b000100)
+    ((DIT) #b011010)
+    (else #f)))
+
+(define (load/store-pre/post-index op)
+  (case op
+    ((POST+) #b01)
+    ((PRE+) #b11)
+    (else #f)))
+
+(define (load/store-size sz)
+  (case sz
+    ((B) #b00)
+    ((H) #b01)
+    ((W) #b10)
+    ((X) #b11)
+    (else #f)))
+
+(define (load/store-simd/fp-size sz)
+  ;; Returns size(2) || opchi(1).  opclo(1), omitted, is 1 for a load
+  ;; and 0 for a store.
+  (case sz
+    ((B) #b000)
+    ((H) #b010)
+    ((S) #b100)
+    ((D) #b110)
+    ((Q) #b001)
+    (else #f)))
+
+(define (ldr-simd/fp-size sz)
+  (case sz
+    ((S) #b00)
+    ((D) #b01)
+    ((Q) #b10)
+    (else #f)))
+
+(define (str-simd/fp-size sz)
+  (case sz
+    (())))
+
+(define (ldr-literal-size sz)
+  (case sz
+    ;; No byte or halfword, only word and extended word.
+    ((W) #b00)
+    ((X) #b01)
+    (else #f)))
+
+(define (load/store-extend-type t)
+  (case t
+    ((UTXW) #b010)
+    ((LSL) #b011)
+    ((SXTW) #b110)
+    ((SXTX) #b111)
+    (else #f)))
+
+(define (load/store8-extend-amount amount)
+  (case amount
+    ((#f) 0)
+    ((0) 1)
+    (else #f)))
+
+(define (load/store16-extend-amount amount)
+  (case amount
+    ((0) 0)
+    ((1) 1)
+    (else #f)))
+
+(define (load/store32-extend-amount amount)
+  (case amount
+    ((0) 0)
+    ((2) 1)
+    (else #f)))
+
+(define (load/store64-extend-amount amount)
+  (case amount
+    ((0) 0)
+    ((3) 1)
+    (else #f)))
+
+(define (load/store128-extend-amount amount)
+  (case amount
+    ((0) 0)
+    ((4) 1)
+    (else #f)))
+
+;;;; Instructions, ordered by sections in ARMv8-A ARM, C3
+
+;;; C3.1.1 Conditional branch
+
+(let-syntax
+    ((define-conditional-branch-instruction
+      (lambda (form environment)
+        environment
+        (let ((mnemonic (list-ref form 1))
+              (o0 (list-ref form 2))
+              (o1 (list-ref form 3))
+              (condition (list-ref form 4)))
+          `(define-instruction ,mnemonic
+             (((@PCR (? target)))
+              (BITS (7 #b0101010)
+                    (1 ,o1)
+                    (19 `(- ,target *PC*) SIGNED)
+                    (1 ,o0)
+                    (4 ,condition))))))))
+  ;; PSTATE condition bits:
+  ;; .n = negative
+  ;; .z = zero
+  ;; .c = carry
+  ;; .v = overflow
+  ;; Branch if...
+  (define-conditional-branch-instruction B.EQ 0 0 #b0000) ;equal
+  (define-conditional-branch-instruction B.NE 0 0 #b0001) ;not equal
+  (define-conditional-branch-instruction B.CS 0 0 #b0010) ;carry set
+  (define-conditional-branch-instruction B.CC 0 0 #b0011) ;carry clear
+  (define-conditional-branch-instruction B.MI 0 0 #b0100) ;negative `minus'
+  (define-conditional-branch-instruction B.PL 0 0 #b0101) ;nonnegative `plus'
+  (define-conditional-branch-instruction B.VS 0 0 #b0110) ;overflow set
+  (define-conditional-branch-instruction B.VC 0 0 #b0111) ;overflow clear
+  (define-conditional-branch-instruction B.HI 0 0 #b1000) ;carry and nonzero
+  (define-conditional-branch-instruction B.LS 0 0 #b1001) ;!carry or zero
+  (define-conditional-branch-instruction B.GE 0 0 #b1010) ;greater or equal
+                                        ;n = v
+  (define-conditional-branch-instruction B.LT 0 0 #b1011) ;less
+                                        ;n != v
+  (define-conditional-branch-instruction B.GT 0 0 #b1100) ;greater
+                                        ;n = v and !z
+  (define-conditional-branch-instruction B.LE 0 0 #b1101) ;less or equal
+                                        ;n != v or z
+  (define-conditional-branch-instruction B.AL 0 0 #b1110) ;always
+  #;  ;never?
+  (define-conditional-branch-instruction B.<never> 0 0 #b1111))
+
+(let-syntax
+    ((define-compare&branch-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic op) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              (((? sf sf-size) (? Rt register-31=z) (@PCR (? label)))
+               (BITS (1 sf)
+                     (6 #b011010)
+                     (1 ,op)
+                     (19 `(QUOTIENT (- ,label *PC*) 4) SIGNED)
+                     (5 Rt)))))))))
+  ;; Compare and branch on zero
+  (define-compare&branch-instruction CBZ 0)
+  ;; Compare and branch on nonzero
+  (define-compare&branch-instruction CBNZ 1))
+
+(let-syntax
+    ((define-test&branch-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic op) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ((W (? Rt register-31=z)
+                  (&U (? bit unsigned-5))
+                  (@PCR (? label)))
+               (BITS (1 0)              ;b5, fifth bit of bit index
+                     (6 #b011011)
+                     (1 ,op)
+                     (5 bit)
+                     (14 `(- ,label *PC*))
+                     (5 Rt)))
+              ((X (? Rt register-31=z)
+                  (&U (? bit unsigned-6))
+                  (@PCR (? label)))
+               (BITS (1 bit B5)
+                     (6 #b011011)
+                     (5 bit B40)
+                     (14 `(- ,label *PC*))
+                     (5 Rt)))))))))
+  ;; Test and branch if zero
+  (define-test&branch-instruction TBZ 0)
+  ;; Test and branch if nonzero
+  (define-test&branch-instruction TBNZ 1))
+
+;;; C3.1.2 Unconditional branch (immediate)
+
+;; Branch unconditional to PC-relative.  Probably no need for
+;; variable-width encoding here for a while since there's 26 bits to
+;; work with.
+
+(define-instruction B
+  (((@PCR (? label)))
+   (BITS (1 0)                          ;no link
+         (5 #b00101)
+         (26 `(- ,label *PC*) SIGNED))))
+
+;; Branch and link unconditional to PC-relative
+
+(define-instruction BL
+  (((@PCR (? label)))
+   (BITS (1 1)                          ;link
+         (5 #b00101)
+         (26 `(- ,label *PC*) SIGNED))))
+
+;;; C.3.1.3 Unconditional branch (register)
+
+;; Unconditional branch to register
+
+(let-syntax
+    ((define-branch-to-register-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic op) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              (((? Rn register-31=z))
+               (BITS (7 #b1101011)
+                     (1 0)              ;Z
+                     (1 0)
+                     (2 ,op)
+                     (5 #b11111)
+                     (4 #b0000)
+                     (1 0)              ;A
+                     (1 0)              ;M
+                     (5 Rn)
+                     (5 0)))))))))
+  (define-branch-to-register-instruction BR #b00)
+  (define-branch-to-register-instruction BLR #b01))
+
+;; Return (same as BR but with prediction hint and default R31, LR)
+
+(define-instruction RET
+  (()
+   (BITS (7 #b1101011)
+         (1 0)                          ;Z
+         (1 0)
+         (2 #b10)                       ;op
+         (5 #b11111)
+         (4 #b0000)
+         (1 0)                          ;A
+         (1 0)                          ;M
+         (5 30)                         ;Rn=30, link register
+         (5 0)))
+  (((? Rn register-31=z))
+   (BITS (7 #b1101011)
+         (1 0)                          ;Z
+         (1 0)
+         (2 #b10)                       ;op
+         (5 #b11111)
+         (4 #b0000)
+         (1 0)                          ;A
+         (1 0)                          ;M
+         (5 Rn)
+         (5 0))))
+
+;;; C3.1.4 Exception generation and return
+
+(let-syntax
+    ((define-exception-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (let ((mnemonic (list-ref form 1))
+               (opc (list-ref form 2))
+               (op2 (list-ref form 3))
+               (LL (list-ref form 4)))
+           `(define-instruction ,mnemonic
+              (((&U (? imm unsigned-16)))
+               (BITS (8 #b11010100)
+                     (3 ,opc)
+                     (16 imm)
+                     (3 ,op2)
+                     (2 ,LL)))))))))
+  ;; Supervisor Call (-> EL1)
+  (define-exception-instruction SVC #b000 #b000 #b01)
+  ;; Hypervisor Call (non-secure EL1 -> EL2)
+  (define-exception-instruction HVC #b000 #b000 #b10)
+  ;; Secure Monitor Call (EL>=1 -> EL3)
+  (define-exception-instruction SMC #b000 #b000 #b11)
+  ;; Breakpoint
+  (define-exception-instruction BRK #b001 #b000 #b00)
+  ;; Halt
+  (define-exception-instruction HLT #b010 #b000 #b00))
+
+;; Exception return
+
+(define-instruction ERET
+  (()
+   (BITS (7 #b1101011)
+         (1 0)
+         (3 #b100)
+         (5 #b11111)
+         (4 #b0000)
+         (1 0)                          ;A
+         (1 0)                          ;M
+         (5 31)                         ;Rn
+         (5 0))))                       ;op4
+
+;;; C3.1.5 System register instructions
+
+;; Move to special register
+
+(define-instruction MSR
+  ;; Immediate
+  (((? psf msr-pstatefield) (&U (? CRm unsigned-4)))
+   (BITS (8 #b11010101)
+         (5 #b00000)
+         (3 psf PSTATEFIELD-OP1)
+         (4 #b0100)
+         (4 CRm)
+         (3 psf PSTATEFIELD-OP2)
+         (5 31)))
+  ;; Register
+  ;; ... XXX
+  )
+
+;; XXX MRS
+
+;;; C3.1.6 System instructions
+
+;; XXX SYS, SYSL, IC, DC, AT, TLBI
+
+;;; C3.1.7 Hint instructions, C3.1.8 Barriers and CLREX instructions
+
+;; Generic HINT format.
+
+(define-instruction HINT
+  (((&U (? imm unsigned-7)))
+   (BITS (8 #b11010101)
+         (2 #b00)
+         (1 0)
+         (2 #b00)
+         (3 #b011)
+         (4 #b0010)
+         (7 imm)
+         (5 #b11111))))
+
+;; Common hint and barrier format.
+
+(let-syntax
+    ((define-hint/barrier-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (let ((mnemonic (list-ref form 1))
+               (CRm (list-ref form 2))
+               (op2 (list-ref form 3)))
+           `(define-instruction ,mnemonic
+              (()
+               (BITS (8 #b11010101)
+                     (2 #b00)
+                     (1 0)
+                     (2 #b00)
+                     (3 #b011)
+                     (4 #b0010)
+                     (4 ,CRm)
+                     (3 ,op2)
+                     (5 #b11111)))))))))
+  ;; Hints: CRm=#b0000
+  ;;
+  ;; No-op
+  (define-hint/barrier-instruction NOP #b0000 #b000)
+  ;; Yield bus while spinning on spin lock
+  (define-hint/barrier-instruction YIELD #b0000 #b001)
+  ;; Wait for event, signalled by SEV on any CPU (`PE') or SEVL on this one
+  (define-hint/barrier-instruction WFE #b0000 #b010)
+  ;; Wait for interrupt
+  (define-hint/barrier-instruction WFI #b0000 #b011)
+  ;; Send event, waking WFE in all CPUs (`PE') in multiprocessor system
+  (define-hint/barrier-instruction SEV #b0000 #b100)
+  ;; Send event local, waking WFE on this CPU
+  (define-hint/barrier-instruction SEVL #b0000 #b101)
+  ;; Barriers: CRm=#b0010
+  ;;
+  ;; Error synchronization barrier
+  (define-hint/barrier-instruction ESB #b0010 #b000)
+  ;; Profiling synchronization barrier
+  (define-hint/barrier-instruction PSB-CSYNC #b0010 #b001)
+  ;; Trace synchronization barrier
+  (define-hint/barrier-instruction TSB-CSYNC #b0010 #b010)
+  ;; Consumption of speculative data barrier
+  (define-hint/barrier-instruction CSDB #b0010 #b100))
+
+;; Clear exclusive: clear local monitor of the executing PE.
+
+(define-instruction CLREX
+  (((&U (? CRm unsigned-4)))
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 CRm)
+         (3 #b010)                      ;op2
+         (5 31))))
+
+;; Data memory barrier
+
+(define (dmb-option o)
+  (case o
+    ((SY) #b1111)
+    ((ST) #b1110)
+    ((LD) #b1101)
+    ((ISH) #b1011)
+    ((ISHST) #b1010)
+    ((ISHLD) #b1001)
+    ((NSH) #b0111)
+    ((NSHST) #b0110)
+    ((NSHLD) #b0101)
+    ((OSH) #b0011)
+    ((OSHST) #b0010)
+    ((OSHLD) #b0001)
+    (else #f)))
+
+(define-instruction DMB
+  (((? CRm dmb-option))
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 CRm)
+         (3 #b010)                      ;op2
+         (5 31)))
+  (((&U (? CRm unsigned-4)))
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 CRm)
+         (3 #b010)                      ;op2
+         (5 31))))
+
+;; Speculative store bypass barrier (physical address), encoded like DMB.
+
+(define-instruction PSSBB
+  (()
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 #b0100)
+         (3 #b010)                      ;op2
+         (5 31))))
+
+(define (isb-option o)
+  (case o
+    ((SY) #b1111)
+    (else #f)))
+
+(define-instruction ISB
+  (()
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 #b1111)                     ;CRm, full system barrier
+         (3 #b110)                      ;op2
+         (5 31)))
+  (((? CRm isb-option))
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 CRm)
+         (3 #b110)                      ;op2
+         (5 31)))
+  (((&U (? CRm unsigned-4)))
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 CRm)
+         (3 #b110)                      ;op2
+         (5 31))))
+
+;; Data synchronization barrier
+
+(define (dsb-option o)
+  (case o
+    ((SY) #b1111)
+    ((ST) #b1110)
+    ((LD) #b1101)
+    ((ISH) #b1011)
+    ((ISHST) #b1010)
+    ((ISHLD) #b1001)
+    ((NSH) #b0111)
+    ((NSHST) #b0110)
+    ((NSHLD) #b0101)
+    ((OSH) #b0011)
+    ((OSHST) #b0010)
+    ((OSHLD) #b0001)
+    (else #f)))
+
+(define-instruction DSB
+  (((? CRm dsb-option))
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 CRm)
+         (3 #b100)                      ;op2
+         (5 31)))
+  (((&U (? CRm unsigned-4)))
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 CRm)
+         (3 #b100)                      ;op2
+         (5 31))))
+
+;; Speculative store bypass barrier (virtual address)
+
+(define-instruction SSBB
+  (()
+   (BITS (8 #b11010101)
+         (8 #b00000011)
+         (4 #b0011)
+         (4 #b0000)
+         (3 #b100)                      ;op2
+         (5 31))))
+
+;;; C3.1.9 Pointer authentication instructions
+
+;; XXX pointer authentication instructions
+
+;;; C3.2 Loads and stores
+
+;;; C3.2.1 Load/Store register
+
+(let-syntax
+    ((define-load/store-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic load/store . extra) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ;; LDRB/LDRH/LDR immediate, pre/post-index with signed
+              ;; byte offset (C6.2.123, C6.2.125, C6.2.119)
+              ;; STRB/STRH/STR immediate, pre/post-index with signed
+              ;; byte offset (C6.2.259, C6.2.261, C6.2.257)
+              (((? size load/store-size)
+                (? Rt register-31=z)
+                ((? pre/post load/store-pre/post-index)
+                 (? Rn register-31=sp)
+                 (& (? offset signed-9))))
+               (BITS (2 size)
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 0)
+                     (9 offset SIGNED)
+                     (2 pre/post)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDRB/LDRH/LDR immediate, zero offset
+              ;; (C6.2.123, C6.2.125, C6.2.119)
+              ;; STRB/STRH/STR immediate, zero offset
+              ;; (C6.2.259, C6.2.261, C6.2.257)
+              (((? size load/store-size)
+                (? Rt register-31=z)
+                (? Rn register-31=sp))
+               (BITS (2 size)
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 0)             ;offset=0
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDRB immediate, unsigned byte offset (C6.2.123)
+              ;; STRB immediate, unsigned byte offset (C6.2.259)
+              ((B (? Rt register-31=z)
+                  (+ (? Rn register-31=sp) (&U (? offset unsigned-12))))
+               (BITS (2 #b00)           ;size=B, 8-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDRB immediate, unsigned byte offset (C6.2.123)
+              ;; STRB immediate, unsigned byte offset (C6.2.259)
+              ;; [same as above]
+              ((B (? Rt register-31=z)
+                  (+ (? Rn register-31=sp) (&U (* 1 (? offset unsigned-12)))))
+               (BITS (2 #b00)           ;size=B, 8-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDRH immediate, unsigned 2-byte offset (C6.2.125)
+              ;; STRH immediate, unsigned 2-byte offset (C6.2.259)
+              ((H (? Rt register-31=z)
+                  (+ (? Rn register-31=sp) (&U (* 2 (? offset unsigned-12)))))
+               (BITS (2 #b01)           ;size=H, 16-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDR (W) immediate, unsigned 4-byte offset (C6.2.119)
+              ;; STR (W) immediate, unsigned 4-byte offset (C6.2.257)
+              ((W (? Rt register-31=z)
+                  (+ (? Rn register-31=sp) (&U (* 4 (? offset unsigned-12)))))
+               (BITS (2 #b10)           ;size=W, 32-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDR (X) immediate, unsigned 8-byte offset (C6.2.119)
+              ;; STR (X) immediate, unsigned 8-byte offset (C6.2.257)
+              ((X (? Rt register-31=z)
+                  (+ (? Rn register-31=sp) (&U (* 8 (? offset unsigned-12)))))
+               (BITS (2 #b11)           ;size=X, 64-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDRB/LDRH/LDR register, no extend
+              ;; (C6.2.124, C6.2.126, C6.2.121)
+              ;; STRB/STRH/STR register, no extend
+              ;; (C6.2.260, C6.2.262, C6.2.258)
+              (((? size load/store-size)
+                (? Rt register-31=z)
+                (+ (? Rn register-31=sp)
+                   (? Rm register-31=z)))
+               (BITS (2 size)
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 #b011)          ;option=LSL
+                     (1 0)              ;shift=0
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDRB extended register, 8-bit operand size (C6.2.124)
+              ;; STRB extended register, 8-bit operand size (C6.2.260)
+              ((B (? Rt register-31=z)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store8-extend-amount))))
+               (BITS (2 #b00)           ;size=B, 8-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDRH extended register, 16-bit operand size (C6.2.126)
+              ;; STRH extended register, 16-bit operand size (C6.2.262)
+              ((H (? Rt register-31=z)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store16-extend-amount))))
+               (BITS (2 #b01)           ;size=H, 16-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDR (W) extended register, 32-bit operand size (C6.2.121)
+              ;; STR (W) extended register, 32-bit operand size (C6.2.258)
+              ((W (? Rt register-31=z)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store32-extend-amount))))
+               (BITS (2 #b10)           ;size=W, 32-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; LDR (X) extended register, 64-bit operand size (C6.2.121)
+              ;; STR (X) extended register, 64-bit operand size (C6.2.258)
+              ((X (? Rt register-31=z)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store64-extend-amount))))
+               (BITS (2 #b11)           ;size=X, 64-bit
+                     (3 #b111)
+                     (1 0)              ;general
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Rt)))
+              ,@extra))))))
+  (define-load/store-instruction STR 0)
+  (define-load/store-instruction LDR 1
+    ;; LDR PC-relative literal (C6.2.120).
+    (((? opc ldr-literal-size) (? Rt register-31=z) (@PCR (? label)))
+     (BITS (2 opc)
+           (3 #b011)
+           (1 0)                        ;general
+           (2 #b00)
+           (19 `(QUOTIENT (- ,label *PC*) 4))
+           (5 Rt)))))
+
+;;; C3.2.9 Load/Store scalar SIMD and floating-point
+
+(let-syntax
+    ((define-simd/fp-load/store-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic load/store . extra) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ;; LDR immediate, SIMD&FP, pre/post-index with signed
+              ;; byte offset (C7.2.176)
+              ;; STR immediate, SIMD&FP, pre/post-index with signed
+              ;; byte offset (C7.2.315)
+              (((? sz load/store-simd/fp-size)
+                (? Vt vregister)
+                ((? pre/post load/store-pre/post-index)
+                 (? Rn register-31=sp)
+                 (& (? offset signed-9))))
+               (BITS (2 sz LOAD/STORE-SIMD/FP-SIZE)
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b00)
+                     (1 sz LOAD/STORE-SIMD/FP-OPCHI)
+                     (1 ,load/store)    ;opc[0]
+                     (1 0)
+                     (9 offset SIGNED)
+                     (2 pre/post)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR immediate, SIMD&FP, zero offset (C7.2.176)
+              ;; STR immediate, SIMD&FP, zero offset (C7.2.315)
+              (((? sz load/store-simd/fp-size)
+                (? Vt vregister)
+                (? Rn register-31=sp))
+               (BITS (2 sz LOAD/STORE-SIMD/FP-SIZE)
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b01)
+                     (1 sz LOAD/STORE-SIMD/FP-OPCHI)
+                     (1 ,load/store)    ;opc[0]
+                     (12 0)             ;offset=0
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR immediate, SIMD&FP (B), unsigned byte offset (C7.2.176)
+              ;; STR immediate, SIMD&FP (B), unsigned byte offset (C7.2.315)
+              ((B (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     (&U (? offset unsigned-12))))
+               (BITS (2 #b00)           ;size=B, 8-bit
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR immediate, SIMD&FP (B), unsigned byte offset (C7.2.176)
+              ;; STR immediate, SIMD&FP (B), unsigned byte offset (C7.2.315)
+              ;; [same as above]
+              ((B (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     (&U (* 1 (? offset unsigned-12)))))
+               (BITS (2 #b00)           ;size=B, 8-bit
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR immediate, SIMD&FP (H), unsigned 2-byte offset (C7.2.176)
+              ;; STR immediate, SIMD&FP (H), unsigned 2-byte offset (C7.2.315)
+              ((H (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     (&U (* 2 (? offset unsigned-12)))))
+               (BITS (2 #b01)           ;size=H, 16-bit
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR immediate, SIMD&FP (S), unsigned 4-byte offset (C7.2.176)
+              ;; STR immediate, SIMD&FP (S), unsigned 4-byte offset (C7.2.315)
+              ((S (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     (&U (* 4 (? offset unsigned-12)))))
+               (BITS (2 #b10)           ;size=S, 32-bit
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR immediate, SIMD&FP (D), unsigned 8-byte offset (C7.2.176)
+              ;; STR immediate, SIMD&FP (D), unsigned 8-byte offset (C7.2.315)
+              ((D (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     (&U (* 8 (? offset unsigned-12)))))
+               (BITS (2 #b11)           ;size=D, 64-bit
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR immediate, SIMD&FP (Q), unsigned 16-byte offset (C7.2.176)
+              ;; STR immediate, SIMD&FP (Q), unsigned 16-byte offset (C7.2.315)
+              ((Q (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     (&U (* 16 (? offset unsigned-12)))))
+               (BITS (2 #b00)           ;`size'
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b01)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (12 offset)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR register, SIMD&FP, no extend (C7.2.178)
+              ;; STR register, SIMD&FP, no extend (C7.3.316)
+              (((? sz load/store-simd/fp-size)
+                (? Vt vregister)
+                (+ (? Rn register-31=sp)
+                   (? Rm register-31=z)))
+               (BITS (2 sz LOAD/STORE-SIMD/FP-SIZE)
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b00)
+                     (1 sz LOAD/STORE-SIMD/FP-OPCHI)
+                     (1 ,load/store)    ;opc[0]
+                     (5 Rm)
+                     (3 #b011)          ;option=LSL
+                     (1 0)              ;shift=0
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR register, SIMD&FP (B), (C7.2.178)
+              ;; STR register, SIMD&FP (B), (C7.2.316)
+              ((B (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store8-extend-amount))))
+               (BITS (2 #b00)           ;size=B
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR register, SIMD&FP (H), (C7.2.178)
+              ;; STR register, SIMD&FP (H), (C7.2.316)
+              ((H (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store16-extend-amount))))
+               (BITS (2 #b01)           ;size=H
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR register, SIMD&FP (S), (C7.2.178)
+              ;; STR register, SIMD&FP (S), (C7.2.316)
+              ((S (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store32-extend-amount))))
+               (BITS (2 #b10)           ;size=H
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR register, SIMD&FP (D), (C7.2.178)
+              ;; STR register, SIMD&FP (D), (C7.2.316)
+              ((D (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store64-extend-amount))))
+               (BITS (2 #b11)           ;size=D
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b00)
+                     (1 0)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Vt)))
+              ;; LDR register, SIMD&FP (Q), (C7.2.178)
+              ;; STR register, SIMD&FP (Q), (C7.2.316)
+              ((Q (? Vt vregister)
+                  (+ (? Rn register-31=sp)
+                     ((? option load/store-extend-type)
+                      (? Rm register-31=z)
+                      (? S load/store128-extend-amount))))
+               (BITS (2 #b00)           ;size=Q
+                     (3 #b111)
+                     (1 1)              ;SIMD/FP
+                     (2 #b00)
+                     (1 1)              ;opc[1]
+                     (1 ,load/store)    ;opc[0]
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (1 S)
+                     (2 #b10)
+                     (5 Rn)
+                     (5 Vt)))
+              ,@extra))))))
+  ;; The ARM assembler has `LDRB w13,...' for byte-sized load into
+  ;; general register 13, and `LDR b13,...' for byte-sized load into
+  ;; vector register 13.  We use a separate mnemonic for general
+  ;; registers and vector registers.
+  (define-simd/fp-load/store-instruction STR.V 0)
+  (define-simd/fp-load/store-instruction LDR.V 1
+    ;; LDR PC-relative literal, SIMD&FP (C7.2.177)
+    (((? opc ldr-literal-simd/fp-size) (? Vt vregister) (@PCR (? label)))
+     (BITS (2 opc)
+           (3 #b011)
+           (1 1)                        ;SIMD/FP
+           (2 #b00)
+           (19 `(QUOTIENT (- ,label *PC*) 4))
+           (5 Vt)))))
+
+;; Load register signed
+
+(define-instruction LDRS
+  ;; Immediate, zero unsigned offset
+  (((? Rt register-31=z) (? Rn register-31=sp))
+   (BITS (2 #b10)                       ;size
+         (3 #b111)
+         (1 0)
+         (2 #b01)
+         (2 #b10)                       ;opc
+         (12 0)                         ;imm12
+         (5 Rn)
+         (5 Rt)))
+  ;; Immediate, unsigned offset
+  (((? Rt register-31=z)
+    (+ (? Rn register-31=sp) (&U (? offset unsigned-12))))
+   (BITS (2 #b10)                       ;size
+         (3 #b111)
+         (1 0)
+         (2 #b01)
+         (2 #b10)                       ;opc
+         (12 offset)                    ;imm12
+         (5 Rn)
+         (5 Rt)))
+  ;; Post-indexed signed offset
+  (((? Rt register-31=z)
+    (POST+ (? Rn register-31=sp) (& (? offset signed-9))))
+   (BITS (2 #b10)                       ;size
+         (3 #b111)
+         (1 0)
+         (2 #b00)
+         (2 #b10)                       ;opc
+         (1 0)
+         (9 offset SIGNED)
+         (2 #b01)                       ;post-index
+         (5 Rn)
+         (5 Rt)))
+  ;; Pre-indexed signed offset
+  (((? Rt register-31=z)
+    (POST+ (? Rn register-31=sp) (& (? offset signed-9))))
+   (BITS (2 #b10)                       ;size
+         (3 #b111)
+         (1 0)
+         (2 #b00)
+         (2 #b10)                       ;opc
+         (1 0)
+         (9 offset SIGNED)
+         (2 #b11)                       ;pre-index
+         (5 Rn)
+         (5 Rt)))
+  ;; Literal
+  (((? Rt register-31=z) (@PCR (? label)))
+   (BITS (2 #b10)                       ;opc
+         (3 #b011)
+         (1 0)                          ;general
+         (2 #b00)
+         (19 `(QUOTIENT (- ,label *PC*) 4))
+         (5 Rt)))
+  ;; Register, no extend
+  (((? Rt register-31=z) (? Rn register-31=sp) (? Rm register-31=z))
+   (BITS (2 #b10)                       ;size
+         (3 #b111)
+         (1 0)
+         (2 #b00)
+         (2 #b10)                       ;opc
+         (1 1)
+         (5 Rm)
+         (3 #b011)                      ;option=LSL
+         (1 0)                          ;shift=0
+         (5 Rn)
+         (5 Rt)))
+  ;; Extended register
+  (((? Rt register-31=z)
+    (? Rn register-31=sp)
+    (? Rm register-31=z)
+    (? option ldrsw-extend-type)
+    (? S ldrsw-extend-amount))
+   (BITS (2 #b10)                       ;size
+         (3 #b111)
+         (1 0)
+         (2 #b00)
+         (2 #b10)                       ;opc
+         (1 1)
+         (5 Rm)
+         (3 option)
+         (1 S)
+         (2 #b10)
+         (5 Rn)
+         (5 Rt))))
+
+;;; XXX not yet converted to section ordering, need to review syntax
+
+(let-syntax
+    ((define-adr-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic op divisor) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ((X (? Rd register-31=z) (@PCR ,label))
+               (BITS (1 ,op)
+                     (2 `(QUOTIENT (- ,label *PC*) ,',divisor) IMMLO)
+                     (1 1)
+                     (4 #b0000)
+                     (19 `(QUOTIENT (- ,label *PC*) ,',divisor) IMMHI)
+                     (5 Rd)))))))))
+  ;; PC-relative byte address
+  (define-adr-instruction ADR 0 1)
+  ;; PC-relative page address
+  (define-adr-instruction ADRP 1 4096))
+
+(define (extend-type t)
+  (case t
+    ((UXTB) #b000)
+    ((UXTH) #b001)
+    ((UXTW) #b010)
+    ((UXTX) #b011)
+    ((SXTB) #b100)
+    ((SXTH) #b101)
+    ((SXTW) #b110)
+    ((SXTX) #b111)
+    (else #f)))
+
+(define (shift-type t)
+  (case t
+    ((LSL) #b00)
+    ((LSR) #b01)
+    ((ASR) #b10)
+    (else #f)))
+
+(let-syntax
+    ((define-addsub-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic op S register-31=dst Rd) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ;; Extended register
+              (((? sf sf-size)
+                ,@(if Rd '() `((? Rd ,register-31=dst)))
+                (? Rn register-31=sp)
+                (? Rm register-31=z)
+                (? option extend-type)
+                (&U (? amount unsigned-2)))
+               (BITS (1 sf)
+                     (1 ,op)
+                     (1 ,S)
+                     (1 0)
+                     (4 #b1011)
+                     (2 #b00)
+                     (1 1)
+                     (5 Rm)
+                     (3 option)
+                     (3 amount)
+                     (5 Rn)
+                     (5 ,(or Rd 'Rd))))
+              ;; Immediate, shift=0
+              (((? sf sf-size)
+                ,@(if Rd '() '((? Rd register-31=sp)))
+                (? Rn register-31=sp)
+                (&U (? imm unsigned-12)))
+               (BITS (1 sf)
+                     (1 ,op)
+                     (1 ,S)
+                     (1 1)
+                     (4 #b0001)
+                     (2 #b00)
+                     (12 imm)
+                     (5 Rn)
+                     (5 ,(or Rd 'Rd))))
+              ;; Immediate, shift=12
+              (((? sf sf-size)
+                ,@(if Rd '() '((? Rd register-31=sp)))
+                (? Rn register-31=sp)
+                (LSL (&U (? imm unsigned-12)) 12))
+               (BITS (1 sf)
+                     (1 ,op)
+                     (1 ,S)
+                     (1 1)
+                     (4 #b0001)
+                     (2 #b01)
+                     (12 imm)
+                     (5 Rn)
+                     (5 ,(or Rd 'Rd))))
+              ;; Shifted register, no shift amount.  Could also be
+              ;; encoded by extended register as long as Rm is not the
+              ;; zero register.
+              (((? sf sf-size)
+                ,@(if Rd '() '((? Rd register-31=z)))
+                (? Rn register-31=z)
+                (? Rm register-31=z))
+               (BITS (1 sf)
+                     (1 ,op)
+                     (1 ,S)
+                     (1 0)
+                     (4 #b1011)
+                     (2 #b00)           ;shift type=LSL
+                     (1 0)
+                     (5 Rm)
+                     (6 0)              ;shift amount=0
+                     (5 Rn)
+                     (5 ,(or Rd 'Rd))))
+              ;; Shifted register, 32-bit
+              ((W ,@(if Rd '() '((? Rd register-31=z)))
+                  (? Rn register-31=z)
+                  (? Rm register-31=z)
+                  (? type shift-type)
+                  (? amount unsigned-5))
+               (BITS (1 0)              ;sf=0, 32-bit operand size
+                     (1 ,op)
+                     (1 ,S)
+                     (1 0)
+                     (4 #b1011)
+                     (2 type)
+                     (1 0)
+                     (5 Rm)
+                     (6 amount)
+                     (5 Rn)
+                     (5 ,(or Rd 'Rd))))
+              ;; Shifted register, 64-bit
+              ((X ,@(if Rd '() '((? Rd register-31=z)))
+                  (? Rn register-31=z)
+                  (? Rm register-31=z)
+                  (? type shift-type)
+                  (? amount unsigned-6))
+               (BITS (1 1)              ;sf=1, 64-bit operand size
+                     (1 ,op)
+                     (1 ,S)
+                     (1 0)
+                     (4 #b1011)
+                     (2 type)
+                     (1 0)
+                     (5 Rm)
+                     (6 amount)
+                     (5 Rn)
+                     (5 ,(or Rd 'Rd))))))))))
+  ;; Add
+  (define-addsub-instruction ADD 0 0 register-31=sp #f)
+  ;; Add and set flags
+  (define-addsub-instruction ADDS 0 1 register-31=z #f)
+  ;; Compare negation: ADDS(Rd=z)
+  (define-addsub-instruction CMN 0 1 #f 31)
+  ;; Subtract
+  (define-addsub-instruction SUB 1 0 register-31=sp #f)
+  ;; Subtract and set flags
+  (define-addsub-instruction SUBS 1 1 register-31=z #f)
+  ;; Compare: SUBS(Rd=z)
+  (define-addsub-instruction CMP 1 1 #f 31))
+
+;;; XXX wacky logical bit pattern encoding for immediates
+
+(define (shiftror-type t)
+  (case t
+    ((LSL) #b00)
+    ((LSR) #b01)
+    ((ASR) #b10)
+    ((ROR) #b11)
+    (else #f)))
+
+(let-syntax
+    ((define-logical-instruction
+       (sc-macro-transformer
+        (lambda (form environment)
+          environment
+          (receive (mnemonic opc register-31=dst Rd) (apply values (cdr form))
+            `(define-instruction ,mnemonic
+               ;; Immediate, 32-bit operand size
+               ((W ,@(if Rd '() `((? Rd ,register-31=dst)))
+                   (? Rn register-31=z)
+                   (&U (? imm logical-imm-32)))
+                (BITS (1 0)           ;sf=0, 32-bit operand size
+                      (2 ,opc)
+                      (1 1)
+                      (4 #b0010)
+                      (1 0)
+                      (1 0)           ;N=0
+                      (6 imm BITMASK32-IMMR)
+                      (6 imm BITMASK32-IMMS)
+                      (5 Rn)
+                      (5 ,(or Rd 'Rd))))
+               ;; Immediate, 64-bit operand size
+               ((X ,@(if Rd '() '((? Rd register-31=sp)))
+                   (? Rn register-31=z)
+                   (&U (? imm logical-imm-64)))
+                (BITS (1 1)           ;sf=1, 64-bit operand size
+                      (2 ,opc)
+                      (1 1)
+                      (4 #b0010)
+                      (1 0)
+                      (1 imm BITMASK64-N)
+                      (6 imm BITMASK64-IMMR)
+                      (6 imm BITMASK64-IMMS)
+                      (5 Rn)
+                      (5 ,(or Rd 'Rd))))
+               ;; Shifted register, no shift amount.
+               (((? sf sf-size)
+                 ,@(if Rd '() '((? Rd register-31=z)))
+                 (? Rn register-31=z)
+                 (? Rm register-31=z))
+                (BITS (1 sf)
+                      (2 ,opc)
+                      (1 0)
+                      (4 #b1010)
+                      (2 #b00)        ;shift type=LSL
+                      (1 0)           ;N=0
+                      (5 Rm)
+                      (6 0)           ;shift amount=0
+                      (5 Rn)
+                      (5 ,(or Rd 'Rd))))
+               ;; Shifted register, 32-bit operand size.
+               ((W ,@(if Rd '() '((? Rd register-31=z)))
+                   (? Rn register-31=z)
+                   (? Rm register-31=z)
+                   (? type shiftror-type)
+                   (? amount unsigned-5))
+                (BITS (1 sf)
+                      (2 ,opc)
+                      (1 0)
+                      (4 #b1010)
+                      (2 type)
+                      (1 0)           ;N=0
+                      (5 Rm)
+                      (6 amount)
+                      (5 Rn)
+                      (5 ,(or Rd 'Rd))))
+               ;; Shifted register, 64-bit operand size.
+               ((X ,@(if Rd '() '((? Rd register-31=z)))
+                   (? Rn register-31=z)
+                   (? Rm register-31=z)
+                   (? type shiftror-type)
+                   (? amount unsigned-6))
+                (BITS (1 sf)
+                      (2 ,opc)
+                      (1 0)
+                      (4 #b1010)
+                      (2 type)
+                      (1 0)           ;N=0
+                      (5 Rm)
+                      (6 amount)
+                      (5 Rn)
+                      (5 ,(or Rd 'Rd))))))))))
+  ;; Logical AND
+  (define-logical-instruction AND #b00 register-31=sp #f)
+  ;; Logical inclusive OR
+  (define-logical-instruction ORR #b01 register-31=sp #f)
+  ;; Logical exclusive OR
+  (define-logical-instruction EOR #b10 register-31=sp #f)
+  ;; Logical AND and set flags
+  (define-logical-instruction ANDS #b11 register-31=z #f)
+  ;; Test: ANDS(Rd=z)
+  (define-logical-instruction TST #b11 register-31=z 31))
+
+(define (hw-shift32 shift)
+  (and (exact-nonnegative-integer? shift)
+       (let ((q (quotient shift 16))
+             (r (remainder shift 16)))
+         (and (zero? r)
+              (< q 2)
+              q))))
+
+(define (hw-shift64 shift)
+  (and (exact-nonnegative-integer? shift)
+       (let ((q (quotient shift 16))
+             (r (remainder shift 16)))
+         (and (zero? r)
+              (< q 4)
+              q))))
+
+(let-syntax
+    ((define-move-wide-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic opc) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              (((? sf sf-size)
+                (? Rd register-31=z)
+                (&U (? imm unsigned-16)))
+               (BITS (1 sf)
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0010)
+                     (1 1)
+                     (2 0)              ;hw shift=0
+                     (16 imm)
+                     (5 Rd)))
+              ((W (? Rd register-31=z)
+                  (LSL (&U (? imm unsigned-16)) (? hw hw-shift32)))
+               (BITS (1 0)              ;sf=0, 32-bit operand size
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0010)
+                     (1 1)
+                     (2 hw)
+                     (16 imm)
+                     (5 Rd)))
+              ((X (? Rd register-31=z)
+                  (LSL (&U (? imm unsigned-16)) (? hw hw-shift64)))
+               (BITS (1 1)              ;sf=1, 64-bit operand size
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0010)
+                     (1 1)
+                     (2 hw)
+                     (16 imm)
+                     (5 Rd)))))))))
+  ;; Move wide with NOT
+  (define-move-wide-instruction MOVN #b00)
+  ;; Move wide with zero
+  (define-move-wide-instruction MOVZ #b10)
+  ;; Move wide with keep
+  (define-move-wide-instruction MOVK #b11))
+
+(let-syntax
+    ((define-bitfield-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic opc) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ((W (? Rd register-31=z)
+                  (? Rn register-31=z)
+                  (&U (? r unsigned-5))
+                  (&U (? s unsigned-5)))
+               (BITS (1 0)              ;sf=0, 32-bit operand size
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0011)
+                     (1 0)
+                     (1 0)              ;N, must match sf
+                     (1 0)              ;high bit of r
+                     (6 r)
+                     (1 0)              ;high bit of s
+                     (5 s)
+                     (5 Rn)
+                     (5 Rd)))
+              ((X (? Rd register-31=z)
+                  (? Rn register-31=z)
+                  (&U (? r unsigned-6))
+                  (&U (? s unsigned-6)))
+               (BITS (1 0)              ;sf=1, 64-bit operand size
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0011)
+                     (1 0)
+                     (1 1)              ;N, must match sf
+                     (6 r)
+                     (6 s)
+                     (5 Rn)
+                     (5 Rd)))))))))
+  ;; Signed bitfield move
+  (define-bitfield-instruction SBFM #b00)
+  ;; Bitfield move
+  (define-bitfield-instruction BFM #b01)
+  ;; Unsigned bitfield move
+  (define-bitfield-instruction UBFM #b10))
+
+(let-syntax
+    ((define-shift-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic opc op2) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              (((? sf sf-size)
+                (? Rd register-31=z)
+                (? Rn register-31=z)
+                (? Rm register-31=z))
+               (BITS (1 sf)
+                     (1 0)
+                     (1 0)
+                     (1 1)
+                     (4 #b1010)
+                     (3 #b110)
+                     (5 Rm)
+                     (4 #b0010)
+                     (2 ,op2)
+                     (5 Rn)
+                     (5 Rd)))
+              ;; Alias for SBFM/UBFM, 32-bit operand size.
+              ((W (? Rd register-31=z)
+                  (? Rn register-31=z)
+                  (&U (? shift unsigned-5)))
+               (BITS (1 0)              ;sf=0, 32-bit operand size
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0011)
+                     (1 0)
+                     (1 0)              ;N, must match sf
+                     (1 0)              ;high bit of r
+                     (5 `(REMAINDER (- ,shift) 32))
+                     (1 0)              ;high bit of s
+                     (5 `(- 31 ,shift))
+                     (5 Rn)
+                     (5 Rd)))
+              ;; Alias for SBFM/UBFM, 64-bit operand size.
+              ((X (? Rd register-31=z)
+                  (? Rn register-31=z)
+                  (&U (? shift unsigned-6)))
+               (BITS (1 1)              ;sf=1, 64-bit operand size
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0011)
+                     (1 0)
+                     (1 1)              ;N, must match sf
+                     (6 `(REMAINDER (- ,shift) 64))
+                     (6 `(- 63 ,shift))
+                     (5 Rn)
+                     (5 Rd)))))))))
+  ;; Arithmetic shift right (replicate sign bit), alias for SBFM
+  (define-shift-instruction ASR #b00 #b10)
+  ;; Logical shift left, alias for UBFM
+  (define-shift-instruction LSL #b10 #b00)
+  ;; Logical shift right (fill with zeros), alias for UBFM
+  (define-shift-instruction LSR #b10 #b01))
+
+(let-syntax
+    ((define-signed-extend-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic opc r s) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ;; Alias for SBFM with fixed r and s.
+              (((? sf sf-size)
+                (? Rd register-31=z)
+                (? Rn register-31=z))
+               (BITS (1 sf)
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0011)
+                     (1 0)
+                     (1 sf)             ;N, must match sf
+                     (6 ,r)
+                     (6 ,s)
+                     (5 Rn)
+                     (5 Rd)))))))))
+  ;; Sign-extend byte (8-bit), alias for SBFM
+  (define-signed-extend-instruction SXTB #b00 0 7)
+  ;; Sign-extend halfword (16-bit), alias for SBFM
+  (define-signed-extend-instruction SXTH #b00 0 15)
+  ;; Sign-extend word (32-bit), alias for SBFM
+  (define-signed-extend-instruction SXTW #b00 0 31))
+
+(let-syntax
+    ((define-unsigned-extend-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic opc r s) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ;; Alias for UBFM with fixed r and s.
+              ;;
+              ;; Limited to 32-bit because the top 32 bits are always
+              ;; zero'd anyway.  Not that it would be a problem to
+              ;; support this, since the instruction encoding is there,
+              ;; but the official assembler syntax doesn't support it
+              ;; and maybe it's a mistake if you try to use it.
+              ((W (? Rd register-31=z)
+                  (? Rn register-31=z))
+               (BITS (1 0)              ;sf=0, 32-bit operand size
+                     (2 ,opc)
+                     (1 1)
+                     (4 #b0011)
+                     (1 0)
+                     (1 0)              ;N, must match sf
+                     (6 ,r)
+                     (6 ,s)
+                     (5 Rn)
+                     (5 Rd)))))))))
+  ;; Unsigned zero-extend byte (8-bit), alias for UBFM
+  (define-unsigned-extend-instruction UXTB #b00 0 7)
+  ;; Unsigned zero-extend halfword (16-bit), alias for UBFM
+  (define-unsigned-extend-instruction UXTH #b00 0 15)
+  ;; Unsigned zero-extend word (32-bit), nonexistent because any
+  ;; word-sized write to a destination register will zero the high 32
+  ;; bits.
+  #;
+  (define-unsigned-extend-instruction UXTW #b00 0 31))
+
+(let-syntax
+    ((define-bitfield-insert/extract-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic opc r32 r64 s #!optional register-31=src Rn)
+                  (apply values (cdr form))
+           (define (default def x) (if (default-object? x) def x))
+           (let ((register-31=src (default register-31=z register-31=src))
+                 (Rn (default #f Rn)))
+             `(define-instruction ,mnemonic
+                ((W (R (? Rd register-31=z))
+                    ,@(if Rn '() `((? Rn ,register-31=src)))
+                    (&U (? lsb unsigned-5))
+                    (&U (? width unsigned-5+1)))
+                 (BITS (1 0)            ;sf=0, 32-bit operand size
+                       (2 ,opc)
+                       (1 1)
+                       (4 #b0011)
+                       (1 0)
+                       (1 0)            ;N, must match sf
+                       (6 ,r32)
+                       (6 ,s)
+                       (5 ,(or Rn 'Rn))
+                       (5 Rd)))
+                ((X (? Rd register-31=z)
+                    ,@(if Rn '() `((? Rn ,register-31=src)))
+                    (&U (? lsb unsigned-5))
+                    (&U (? width unsigned-5+1)))
+                 (BITS (1 1)            ;sf=1, 32-bit operand size
+                       (2 ,opc)
+                       (1 1)
+                       (4 #b0011)
+                       (1 0)
+                       (1 1)            ;N, must match sf
+                       (6 ,r64)
+                       (6 ,s)
+                       (5 ,(or Rn 'Rn))
+                       (5 Rd))))))))))
+  ;; Signed bitfield extract, alias for SBFM
+  (define-bitfield-insert/extract-instruction SBFX #b00
+    lsb                                 ;r32
+    lsb                                 ;r64
+    `(- (+ ,lsb ,width) 1))             ;s
+  ;; Unsigned bitfield extract, alias for UBFM
+  (define-bitfield-insert/extract-instruction UBFX #b10
+    lsb                                 ;r32
+    lsb                                 ;r64
+    `(- (+ ,lsb ,width) 1))             ;s
+  ;; Signed bitfield insert in zeros, alias for SBFM
+  (define-bitfield-insert/extract-instruction SFBIZ #b00
+    `(REMAINDER (- ,lsb) 32)            ;r32
+    `(REMAINDER (- ,lsb) 64)            ;r64
+    `(- ,width 1))                      ;s
+  ;; Bitfield extract and insert low copies
+  (define-bitfield-insert/extract-instruction BFXIL #b01
+    `(REMAINDER (- ,lsb) 32)            ;r32
+    `(REMAINDER (- ,lsb) 64)            ;r64
+    (- width 1))                        ;s
+  ;; Bitfield insert: copy <width> bits at <lsb> from source
+  (define-bitfield-insert/extract-instruction BFI #b01
+    `(REMAINDER (- ,lsb) 32)            ;r32
+    `(REMAINDER (- ,lsb) 64)            ;r64
+    `(- ,width 1)                       ;s
+    register<31)                        ;Rn must not be 31
+  ;; Bitfield clear: clear <width> bit positions at <lsb>
+  (define-bitfield-insert/extract-instruction BFC #b01
+    `(REMAINDER (- ,lsb) 32)            ;r32
+    `(REMAINDER (- ,lsb) 64)            ;r64
+    `(- ,width 1)                       ;s
+    #f 31)                              ;Rn is 31
+  (define-bitfield-insert/extract-instruction UFBIZ #b10
+    `(REMAINDER (- ,lsb) 32)            ;r32
+    `(REMAINDER (- ,lsb) 64)            ;r64
+    `(- ,width 1)))                     ;s
+
+(let-syntax
+    ((define-extract-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (let ((mnemonic (cadr form))
+               (op21 (caddr form))
+               (o0 (cadddr form))
+               (m=n? (and (pair? (cddddr form)) (car (cddddr form)))))
+           `(define-instruction ,mnemonic
+              ((W (? Rd)
+                  (? Rn)
+                  ,@(if m=n? '() '((? Rm)))
+                  (&U (? s unsigned-5)))
+               (BITS (1 0)              ;sf=0
+                     (2 ,op21)
+                     (1 1)
+                     (4 #b0011)
+                     (1 1)
+                     (1 sf)             ;N, must match sf
+                     (1 ,o0)
+                     (5 ,(if m=n? 'Rn 'Rm))
+                     (1 0)              ;high bit of lsb index, 0 for 32-bit
+                     (5 s)
+                     (5 Rn)
+                     (5 Rd)))
+              ((X (? Rd)
+                  (? Rn)
+                  ,@(if m=n? '() '((? Rm)))
+                  (&U (? s unsigned-6)))
+               (BITS (1 0)              ;sf=0
+                     (2 ,op21)
+                     (1 1)
+                     (4 #b0011)
+                     (1 1)
+                     (1 sf)             ;N, must match sf
+                     (1 ,o0)
+                     (5 ,(if m=n? 'Rn 'Rm))
+                     (6 s)
+                     (5 Rn)
+                     (5 Rd)))))))))
+  ;; Extract register from pair of registers at bit offset
+  (define-extract-instruction EXTR #b00 0)
+  ;; Rotate right
+  (define-extract-instruction ROR #b00 0 #t))
+
+;; Carry flag invert
+
+(define-instruction CFINV
+  (()
+   (BITS (8 #b11010101)
+         (8 #b00000000)
+         (8 #b01000000)
+         (8 #b00011111))))
+
+;; XXX advanced SIMD load/store multiple
+
+(define (signed-7*4 x)
+  (and (<= -256 x 252)
+       (zero? (remainder x 4))
+       (quotient x 4)))
+
+(let-syntax
+    ((define-load/store-pair-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic L) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              ;; No write-back, no increment.
+              (((? sf sf-size)
+                (? Rt1 register-31=z)
+                (? Rt2 register-31=z)
+                (? Rn register-31=sp))
+               (BITS (1 sf)
+                     (1 0)              ;opc[1]
+                     (3 #b101)
+                     (1 0)
+                     (3 #b010)
+                     (1 ,L)
+                     (7 0)
+                     (5 Rt2)
+                     (5 Rn)
+                     (5 Rt1)))
+              ;; No write back, signed increment.
+              (((? sf sf-size)
+                (? Rt1 register-31=z)
+                (? Rt2 register-31=z)
+                (+ (? Rn register-31=sp)) (& (? imm signed-7*4)))
+               (BITS (1 sf)
+                     (1 0)              ;opc[1]
+                     (3 #b101)
+                     (1 0)
+                     (3 #b010)
+                     (1 ,L)
+                     (7 imm SIGNED)
+                     (5 Rt2)
+                     (5 Rn)
+                     (5 Rt1)))
+              ;; Pre-index signed offset.
+              (((? sf sf-size)
+                (? Rt1 register-31=z)
+                (? Rt2 register-31=z)
+                (PRE+ (? Rn register-31=sp) (& (? imm signed-7*4))))
+               (BITS (1 sf)
+                     (1 0)              ;opc[1]
+                     (3 #b101)
+                     (1 0)
+                     (3 #b011)
+                     (1 ,L)
+                     (7 imm SIGNED)
+                     (5 Rt2)
+                     (5 Rn)
+                     (5 Rt)))
+              ;; Post-index signed offset.
+              (((? sf sf-size)
+                (? Rt1 register-31=z)
+                (? Rt2 register-31=z)
+                (POST+ (? Rn register-31=sp) (& (? imm signed-7*4))))
+               (BITS (1 sf)
+                     (1 0)              ;opc[1]
+                     (3 #b101)
+                     (1 0)
+                     (3 #b001)
+                     (1 ,L)
+                     (7 imm SIGNED)
+                     (5 Rt2)
+                     (5 Rn)
+                     (5 Rt)))))))))
+  (define-load/store-pair-instruction LDP 1)
+  (define-load/store-pair-instruction STP 1))
+
+(define (load/store-size sz)
+  (case sz
+    ((B) #b00)
+    ((H) #b01)
+    ((W) #b10)
+    ((X) #b11)
+    (else #f)))
+
+(let-syntax
+    ((define-load/store-exclusive-instruction
+      (sc-macro-transformer
+       (lambda (form environment)
+         environment
+         (receive (mnemonic L o2 o1 o0) (apply values (cdr form))
+           `(define-instruction ,mnemonic
+              (((? sz load/store-size)
+                (? Rs register-31=z)
+                (? Rt register-31=z)
+                (? Rn register-31=sp))
+               (BITS (2 size)
+                     (2 #b00)
+                     (4 #b1000)
+                     (1 ,o2)
+                     (1 ,L)
+                     (1 ,o1)
+                     (5 Rs)
+                     (1 ,o0)
+                     (5 31)
+                     (5 Rn)
+                     (5 Rt)))))))))
+  ;; Store exclusive register
+  (define-load/store-exclusive-instruction STXR 0 0 0 0)
+  ;; Store-release exclusive register
+  (define-load/store-exclusive-instruction STLXR 0 0 0 1)
+  ;; Load exclusive register
+  (define-load/store-exclusive-instruction LDXR 1 0 0 0)
+  ;; Load-acquire exclusive register
+  (define-load/store-exclusive-instruction LDLXR 1 0 0 1)
+  ;; Store LORelease register
+  (define-load/store-exclusive-instruction STLLR 0 1 0 0)
+  ;; Store-release register
+  (define-load/store-exclusive-instruction STLR 0 1 0 1)
+  ;; Load LOAcquire register
+  (define-load/store-exclusive-instruction LDLAR 1 1 0 0)
+  ;; Load-acquire register
+  (define-load/store-exclusive-instruction LDAR 1 1 0 1))
diff --git a/src/compiler/machines/aarch64/lapgen.scm b/src/compiler/machines/aarch64/lapgen.scm
new file mode 100644
index 000000000..bd2f59a71
--- /dev/null
+++ b/src/compiler/machines/aarch64/lapgen.scm
@@ -0,0 +1,383 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation for AArch64
+;;; package: (compiler)
+
+(declare (usual-integrations))
+
+;;;; Register-Allocator Interface
+
+(define available-machine-registers
+  (list
+   r0
+   r1
+   r2
+   r3
+   r4
+   r5
+   r6
+   r7
+   r8
+   r9
+   r10
+   r11
+   r12
+   r13
+   r14
+   r15
+   ;r16 - PLT scratch; we'll use for branch tensioning
+   ;r17 - PLT scratch; we'll use for branch tensioning
+   ;r18 - platform ABI register
+   ;r19 - interpreter register block
+   ;r20 - free pointer
+   ;r21 - dynamic link
+   ;r22 - memtop
+   r23
+   r24
+   r25
+   r26
+   r27
+   r28
+   ;r29 - C frame pointer, callee-saved and left alone by Scheme
+   ;r30 - link register (could maybe allocate)
+   ;r31 - stack pointer or zero register, depending on instruction
+   ;; Vector registers, always available.
+   v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15
+   v16 v17 v18 v19 v20 v21 v22 v23 v24 v25 v26 v27 v28 v29 v30 v31))
+
+(define (sort-machine-registers registers)
+  registers)
+
+(define (register-type register)
+  (cond ((machine-register? register)
+         (if (< register 32) 'GENERAL 'FLOAT))
+        ((register-value-class=word? register) 'GENERAL)
+        ((register-value-class=float? register) 'FLOAT)
+        (else (error "Unknown register type:" register))))
+
+(define register-reference
+  (let ((references (make-vector number-of-machine-registers)))
+    (do ((register 0 (+ register 1)))
+        ((>= register 32))
+      (vector-set! references register (INST-EA (R ,register))))
+    (do ((register 32 (+ register 1)))
+        ((>= register 64))
+      (vector-set! references register (INST-EA (V ,(- register 32)))))
+    (named-lambda (register-reference register)
+      (vector-ref references register))))
+
+(define (register=? a b)
+  (= a b))
+
+(define (register->register-transfer source target)
+  (guarantee-registers-compatible source target)
+  (if (register=? source target)
+      (LAP)
+      (case (register-type source)
+        ((GENERAL)
+         (if (or (= source rsp) (= target rsp))
+             (let ((target (register-or-sp target))
+                   (source (register-or-sp source)))
+               (LAP (ADD X ,target ,source (&U 0))))
+             (LAP (ORR X ,target ,source (&U 0)))))
+        ((FLOAT)
+         (LAP (FMOV D ,target ,source)))
+        (else
+         (error "Unknown register type:" source target)))))
+
+(define (pseudo-register-home register)
+  (INST-EA (OFFSET ,regnum:regs-pointer ,(register-renumber register))))
+
+(define (home->register-transfer source target)
+  (memory->register-transfer regnum:regs-pointer
+                             (pseudo-register-byte-offset source)
+                             target))
+
+(define (register->home-transfer source target)
+  (register->memory-transfer source
+                             regnum:regs-pointer
+                             (pseudo-register-byte-offset target)))
+
+(define (reference->register-transfer source target)
+  (case (ea/mode source)
+    ((R) (register->register-transfer (register-ea/register source) target))
+    ((V) (register->register-transfer (vector-ea/register source) target))
+    ((OFFSET)
+     (memory->register-transfer (offset-ea/offset source)
+                                (offset-ea/register source)
+                                target))
+    (else
+     (error "Unknown effective address mode:" source target))))
+
+(define (memory->register-transfer offset base target)
+  (case (register-type target)
+    ((GENERAL)
+     (LAP (LDR X ,target (OFFSET ,base ,offset))))
+    ((FLOAT)
+     (LAP (LDR D ,target (OFFSET ,base ,offset))))
+    (else
+     (error "Unknown register type:" target))))
+
+(define (register->memory-transfer source offset base)
+  (case (register-type target)
+    ((GENERAL)
+     (LAP (STR X ,target (OFFSET ,base ,offset))))
+    ((FLOAT)
+     (LAP (STR D ,target (OFFSET ,base ,offset))))
+    (else
+     (error "Unknown register type:" target))))
+
+;;; Utilities
+
+(define (standard-source! register)
+  (if (eq? register 'Z)
+      register
+      (load-alias-register! register (register-type register))))
+
+(define (standard-target! register)
+  (assert (not (eq? register 'Z)))
+  (delete-dead-registers!)
+  (allocate-alias-register! register (register-type register)))
+
+(define (standard-move-to-temporary! source)
+  (if (eq? source 'Z)
+      (let ((temp (standard-temporary!)))
+        (prefix-instructions! (LAP (MOVZ X ,temp (&U 0))))
+        temp)
+      (move-to-temporary-register! source (register-type source))))
+
+(define (register-expression expression)
+  (case (rtl:expression-type expression)
+    ((REGISTER)
+     (rtl:register-number expression))
+    ((CONSTANT)
+     (let ((object (rtl:constant-value expression)))
+       (and (zero? (back-end:object-type object))
+            (zero? (back-end:object-datum object))
+            'Z)))
+    ((MACHINE-CONSTANT)
+     (and (zero? (rtl:machine-constant-value expression))
+          'Z))
+    ((CONS-POINTER)
+     (let ((type (rtl:cons-pointer-type expression))
+           (datum (rtl:cons-pointer-datum expression)))
+       (cond ((rtl:machine-constant? type)
+              (and (zero? (rtl:machine-constant-value type))
+                   (register-expression datum)))
+             ((rtl:machine-constant? datum)
+              (and (zero? (rtl:machine-constant-value datum))
+                   (register-expression type)))
+             (else #f))))
+    (else #f)))
+
+(define (standard-unary target source operate)
+  (let* ((source (standard-source! source))
+         (target (standard-target! target)))
+    (operate target source)))
+
+(define (standard-binary target source1 source2 operate)
+  (let* ((source1 (standard-source! source1))
+         (source2 (standard-source! source2))
+         (target (standard-target! target)))
+    (operate target source1 source2)))
+
+(define (standard-binary-effect source1 source2 operate)
+  (let* ((source1 (standard-source! source1))
+         (source2 (standard-source! source2)))
+    (operate source1 source2)))
+
+(define (standard-ternary-effect source1 source2 source3 operate)
+  (let* ((source1 (standard-source! source1))
+         (source2 (standard-source! source2))
+         (source3 (standard-source! source3)))
+    (operate source1 source2 source3)))
+
+(define (pop register)
+  (LAP (LDR X ,register
+            (POST+ ,regnum:stack-pointer ,addressing-units-per-object))))
+
+(define (push register)
+  (LAP (STR X ,register
+            (PRE- ,regnum:stack-pointer ,addressing-units-per-object))))
+
+(define (pop2 reg1 reg2)
+  ;; (LAP ,@(pop reg1) ,@(pop reg2))
+  (LAP (LDRP X ,reg1 ,reg2
+             (POST+ ,regnum:stack-pointer
+                    ,(* 2 addressing-units-per-object)))))
+
+(define (push2 reg1 reg2)
+  ;; (LAP ,@(push reg2) ,@(push reg1))
+  (LAP (STRP X ,reg2 ,reg1
+             (PRE- ,regnum:stack-pointer ,(* 2 addressing-units-per-object)))))
+
+(define (scale->shift scale)
+  (case scale
+    ((1) 0)
+    ((2) 1)
+    ((4) 2)
+    ((8) 4)
+    (else (error "Invalid scale:" scale))))
+
+(define (load-displaced-address target base offset scale)
+  (standard-unary target base
+    (lambda (target base)
+      (add-immediate target base (* offset scale)))))
+
+(define (load-indexed-address target base offset scale)
+  (standard-binary target base offset
+    (lambda (target base offset)
+      (LAP (ADD X ,target ,base (LSL ,offset ,(scale->shift scale)))))))
+
+(define (load-signed-immediate target imm)
+  (load-unsigned-immediate target (bitwise-and imm #xffffffffffffffff)))
+
+(define (load-unsigned-immediate target imm)
+  (define (try-shift shift)
+    (and (zero? (bitwise-and imm (bit-mask shift 0)))
+         (fits-in-unsigned-16? (shift-right imm shift))
+         shift))
+  (define (find-shift imm)
+    (or (try-shift imm 0)
+        (try-shift imm 16)
+        (try-shift imm 32)
+        (try-shift imm 48)))
+  (cond ((find-shift imm)
+         => (lambda (shift)
+              (LAP (MOVZ X ,target (LSL (&U ,imm) ,shift)))))
+        ((find-shift (bitwise-not imm))
+         => (lambda (shift)
+              (LAP (MOVN X ,target (LSL (&U ,(bitwise-not imm)) ,shift)))))
+        ((logical-immediate? imm)
+         (LAP (ORR X ,target Z (&U ,imm))))
+        ;; XXX try splitting in halves, quarters
+        ((let ((lo (extract-bit-field 32 0 imm))
+               (hi (extract-bit-field 32 32 imm)))
+           (let ((lo-shift (find-shift lo))
+                 (hi-shift (find-shift hi)))
+             (and lo-shift hi-shift (cons lo-shift hi-shift))))
+         => (lambda))
+        ((fits-in-unsigned-16? (bitwise-not imm))
+         (LAP (MOVN X ,target (&U ,(bitwise-not imm)))))
+        ...))
+
+(define (load-pc-relative-address target label)
+  ;; XXX What happens if label is >1 MB away?
+  (LAP (ADR X ,target (@PCR ,label))))
+
+(define (load-pc-relative target label)
+  (LAP ,@(load-pc-relative-address target label)
+       (LDR X ,target ,target)))
+
+(define (load-tagged-immediate target type datum)
+  (load-unsigned-immediate (make-non-pointer-literal type datum)))
+
+(define (load-constant target object)
+  (if (non-pointer-object? object)
+      (load-unsigned-immediate target (non-pointer->literal object))
+      (load-pc-relative target (constant->label object))))
+
+(define (add-immediate target source imm)
+  (define (add addend) (LAP (ADD X ,target ,source ,addend)))
+  (define (sub addend) (LAP (SUB X ,target ,source ,addend)))
+  (immediate-addition imm add sub))
+
+(define (add-immediate-with-flags target source imm)
+  (define (adds addend) (LAP (ADDS X ,target ,source ,addend)))
+  (define (subs addend) (LAP (SUBS X ,target ,source ,addend)))
+  (immediate-addition imm adds subs))
+
+(define (cmp-immediate source imm)
+  ;; Same as above but with zero destination.
+  (define (cmp operand) (LAP (CMP X ,source ,operand)))
+  (define (cmn operand) (LAP (CMN X ,source ,operand)))
+  (immediate-addition imm cmp cmn))
+
+(define (immediate-addition imm add sub)
+  ;; XXX Use INST-EA instead of quasiquote?  Dunno...
+  (cond ((fits-in-unsigned-12? imm)
+         (add `(&U ,imm)))
+        ((and (zero? (bitwise-and imm (bit-mask 12 0)))
+              (fits-in-unsigned-12? (shift-right immediate 12)))
+         (add `(&U ,imm LSL 12)))
+        ((fits-in-unsigned-12? (- immediate))
+         (sub `(&U ,(- immediate))))
+        ((and (zero? (bitwise-and imm (bit-mask 12 0)))
+              (fits-in-unsigned-12? (shift-right (- immediate) 12)))
+         (sub `(&U ,(- immediate) LSL 12)))
+        (else
+         (let ((temp (standard-temporary!)))
+           (LAP ,@(load-unsigned-immediate temp immediate)
+                ,@(add temp))))))
+
+(define (affix-type target type datum)
+  ;; Note: This must NOT use regnum:scratch-0 or regnum:scratch-1!
+  ;; This is used by closure headers to tag the incoming entry.
+  (assert (<= scheme-type-width 16))
+  (assert (<= 48 scheme-datum-width))
+  (cond ((zero? type)
+         (assign-register->register target datum))
+        ((logical-immediate? (make-non-pointer-literal type 0))
+         ;; Works for tags with only contiguous one bits, including
+         ;; tags with only one bit set.
+         (LAP (ORR ,target ,datum (&U ,(make-non-pointer-literal type 0)))))
+        ((fits-in-unsigned-12?
+          (shift-left type (- scheme-datum-width 48)))
+         ;; Works for 2-bit tags.
+         (let ((imm (shift-left type (- scheme-datum-width 48)))
+               (shift 48))
+           (LAP (ADD ,target ,datum (LSL (&U ,imm) ,shift)))))
+        (else
+         ;; Works for all tags up to 16 bits, but costs two
+         ;; instructions.
+         ;;
+         ;; XXX If we know the top few bits of the datum are zero, we
+         ;; could use a single MOVK instruction.
+         (let ((imm (shift-left type (- 16 scheme-type-width)))
+               (shift 48))
+           (LAP (MOVZ ,target (LSL (&U ,imm) ,shift))
+                (ORR ,target ,target ,datum))))))
+
+(define (object->type target source)
+  (let ((lsb scheme-datum-width)
+        (width scheme-type-width))
+    (LAP (UBFX X ,target ,source (&U ,lsb) (&U ,width)))))
+
+(define (object->datum target source)
+  (let ((lsb 0)
+        (width scheme-datum-width))
+    ;; Alternatively, use BFC to clear the top scheme-type-width bits.
+    (LAP (UBFX X ,target ,source (&U ,lsb) (&U ,width)))))
+
+(define (object->address target source)
+  (object->datum target source))
+
+(define (lap:make-label-statement label)
+  (LAP (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+  (LAP (B (@PCR ,label))))
diff --git a/src/compiler/machines/aarch64/lapopt.scm b/src/compiler/machines/aarch64/lapopt.scm
new file mode 100644
index 000000000..fddda73ac
--- /dev/null
+++ b/src/compiler/machines/aarch64/lapopt.scm
@@ -0,0 +1,33 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Optimizer for AArch64
+;;; package: (compiler lap-optimizer)
+
+(declare (usual-integrations))
+
+(define (optimize-linear-lap instructions)
+  instructions)
diff --git a/src/compiler/machines/aarch64/machine.scm b/src/compiler/machines/aarch64/machine.scm
new file mode 100644
index 000000000..4dfe339d2
--- /dev/null
+++ b/src/compiler/machines/aarch64/machine.scm
@@ -0,0 +1,518 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Machine Model for AArch64
+;;; package: (compiler)
+
+(declare (usual-integrations))
+
+;;;; Architecture Parameters
+
+(define (target-fasl-format)
+  (case endianness
+    ((BIG) fasl-format:aarch64be)
+    ((LITTLE) fasl-format:aarch64le)
+    (else (error "Unknown endianness:" endianness))))
+
+(define use-pre/post-increment? #t)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 64)
+(define-integrable scheme-type-width 6) ;or 8
+
+;; NOTE: expt is not being constant-folded now.
+;; For the time being, some of the parameters below are
+;; pre-computed and marked with ***
+;; There are similar parameters in lapgen.scm
+;; Change them if any of the parameters above change.
+
+(define-integrable scheme-datum-width
+  (- scheme-object-width scheme-type-width))
+
+(define-integrable float-width 64)
+(define-integrable float-alignment 64)
+
+(define-integrable address-units-per-float
+  (quotient float-width addressing-granularity))
+
+;;; It is currently required that both packed characters and objects
+;;; be integrable numbers of address units.  Furthermore, the number
+;;; of address units per object must be an integral multiple of the
+;;; number of address units per character.  This will cause problems
+;;; on a machine that is word addressed: we will have to rethink the
+;;; character addressing strategy.
+
+(define-integrable address-units-per-object
+  (quotient scheme-object-width addressing-granularity))
+
+(define-integrable address-units-per-packed-char 1)
+
+(define-integrable signed-fixnum/upper-limit
+  ;; (expt 2 (-1+ scheme-datum-width)) ***
+  #x0200000000000000)
+
+(define-integrable signed-fixnum/lower-limit
+  (- signed-fixnum/upper-limit))
+
+(define-integrable unsigned-fixnum/upper-limit
+  (* 2 signed-fixnum/upper-limit))
+
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
+
+;;;; Closure format
+
+;;; See microcode/cmpintmd/aarch64.h for a description of the layout.
+
+(define-integrable closure-entry-size 2) ;units of objects
+
+(define-integrable address-units-per-closure-manifest address-units-per-object)
+(define-integrable address-units-per-entry-format-code 4)
+(define-integrable address-units-per-closure-entry-count 4)
+(define-integrable address-units-per-closure-padding -4)
+
+(define-integrable address-units-per-closure-pc-offset 8)
+(define-integrable address-units-per-closure-entry-padding 4)
+
+(define-integrable address-units-per-closure-entry
+  (+ address-units-per-entry-format-code
+     address-units-per-closure-pc-offset
+     address-units-per-closure-entry-padding))
+
+;;; Note:
+;;;
+;;; (= address-units-per-closure-entry #| 16 |#
+;;;    (* closure-entry-size #| 2 |# address-units-per-object #| 8 |#))
+
+;;; Given the number of entries in a closure, and the index of an
+;;; entry, return the number of words from that entry's closure
+;;; pointer to the location of the storage for the closure's first
+;;; free variable.  In this case, the closure pointer is the same as
+;;; the compiled entry pointer into the entry instructions.  This is
+;;; different from the i386, where the entry instructions are not all
+;;; object-aligned, and thus the closure pointer is adjusted to point
+;;; to the first entry in the closure block, which is always aligned.
+;;;
+;;; When there are zero entries, the `closure' is just a vector, and
+;;; represented by a tagged pointer to a manifest, following which are
+;;; the free variables.  In this case, the first offset is one object
+;;; past the manifest's address.
+
+(define (closure-first-offset nentries entry)
+  (if (zero? nentries)
+      1
+      (* (- nentries entry 1) closure-entry-size)))
+
+;;; Given the number of entry points in a closure, return the distance
+;;; in objects from the address of the manifest closure to the address
+;;; of the first free variable.
+
+(define (closure-object-first-offset nentries)
+  (if (zero? nentries)
+      1                                 ;One vector manifest.
+      ;; One object for the closure manifest, half an object for the
+      ;; leading entry count, and minus half an object for the trailing
+      ;; non-padding.
+      (+ 1 (* nentries closure-entry-size))))
+
+;;; Given the number of entries in a closure, and the indices of two
+;;; entries, return the number of bytes separating the two entries.
+
+(define (closure-entry-distance nentries entry entry*)
+  nentries                              ;ignore
+  (* (- entry* entry) address-units-per-closure-entry))
+
+;;; Given the number of entries in a closure, and the index of an
+;;; entry, return the number of bytes to add to a possibly misaligned
+;;; closure pointer to obtain a `canonical' entry point, which is
+;;; aligned on an object boundary.  Since all closure entry points are
+;;; aligned thus on this machine, we need adjust nothing.
+
+(define (closure-environment-adjustment nentries entry)
+  nentries entry                        ;ignore
+  0)
+
+;;;; Machine registers
+
+;;; 64-bit general purpose registers, variously named Wn or Xn in the
+;;; ARM assembler depending on the operand size, 32-bit or 64-bit.
+;;; We'll name the operand size separately.
+;;;
+;;; XXX To allocate: regnum:apply-pc, regnum:apply-target
+
+;; register             Scheme purpose          C purpose
+(define-integrable r0 0) ;result, temporary     first argument, result
+(define-integrable r1 1) ;temporary, utilarg0   second argument
+(define-integrable r2 2) ;temporary, utilarg1   third argument
+(define-integrable r3 3) ;temporary, utilarg2   fourth argument
+(define-integrable r4 4) ;temporary, utilarg3   fifth argument
+(define-integrable r5 5) ;temporary, utilarg4   sixth argument
+(define-integrable r6 6) ;temporary, utilarg6   seventh argument
+(define-integrable r7 7) ;temporary, utilarg6   eighth argument
+(define-integrable r8 8) ;temporary             indirect result location
+(define-integrable r9 9) ;temporary             temporary
+(define-integrable r10 10) ;temporary           temporary
+(define-integrable r11 11) ;temporary           temporary
+(define-integrable r12 12) ;temporary           temporary
+(define-integrable r13 13) ;temporary           temporary
+(define-integrable r14 14) ;temporary           temporary
+(define-integrable r15 15) ;temporary           temporary
+(define-integrable r16 16) ;temporary,          first PLT scratch register
+                           ;  indirect jump callee,
+                           ;  scheme-to-interface code
+(define-integrable r17 17) ;temporary,          second PLT scratch register
+                           ;  indirect jump pc
+(define-integrable r18 18) ;reserved            platform ABI register
+(define-integrable r19 19) ;interpreter regs    callee-saved
+(define-integrable r20 20) ;free pointer        callee-saved
+(define-integrable r21 21) ;dynamic link        callee-saved
+(define-integrable r22 22) ;memtop (XXX why?)   callee-saved
+(define-integrable r23 23) ;temporary           callee-saved
+(define-integrable r24 24) ;temporary           callee-saved
+(define-integrable r25 25) ;temporary           callee-saved
+(define-integrable r26 26) ;temporary           callee-saved
+(define-integrable r27 27) ;temporary           callee-saved
+(define-integrable r28 28) ;temporary           callee-saved
+(define-integrable r29 29) ;C frame pointer     frame pointer
+(define-integrable rlr 30) ;link register       link register
+(define-integrable rsp 31) ;stack pointer       stack pointer
+
+;; Note: Register 31 is alternately the stack pointer or the zero
+;; register, depending on instruction.
+
+;;; 128-bit vector registers for SIMD or floating-point instructions,
+;;; variously called Bn, Hn, Sn, Dn, Qn, Vn.8B, Vn.16B, Vn.4H, Vn.8H,
+;;; Vn.2S in the ARM assembler depending on how they are being used.
+;;; No special purpose.
+
+(define-integrable v0 32)
+(define-integrable v1 33)
+(define-integrable v2 34)
+(define-integrable v3 35)
+(define-integrable v4 36)
+(define-integrable v5 37)
+(define-integrable v6 38)
+(define-integrable v7 39)
+(define-integrable v8 40)
+(define-integrable v9 41)
+(define-integrable v10 42)
+(define-integrable v11 43)
+(define-integrable v12 44)
+(define-integrable v13 45)
+(define-integrable v14 46)
+(define-integrable v15 47)
+(define-integrable v16 48)
+(define-integrable v17 49)
+(define-integrable v18 50)
+(define-integrable v19 51)
+(define-integrable v20 52)
+(define-integrable v21 53)
+(define-integrable v22 54)
+(define-integrable v23 55)
+(define-integrable v24 56)
+(define-integrable v25 57)
+(define-integrable v26 58)
+(define-integrable v27 59)
+(define-integrable v28 60)
+(define-integrable v29 61)
+(define-integrable v30 62)
+(define-integrable v31 63)
+
+(define-integrable number-of-machine-registers 64)
+(define-integrable number-of-temporary-registers 256)
+
+;; Draw various fixed-function registers from the callee-saved section,
+;; so we don't have to worry about saving and restoring them ourselves
+;; in the transition to and from C.
+
+(define-integrable regnum:value-register r0)
+(define-integrable regnum:utility-arg0 r1)
+(define-integrable regnum:utility-arg1 r2)
+(define-integrable regnum:utility-arg2 r3)
+(define-integrable regnum:utility-arg3 r4)
+(define-integrable regnum:utility-arg4 r5)
+(define-integrable regnum:utility-arg5 r6)
+(define-integrable regnum:utility-arg6 r7)
+(define-integrable regnum:scratch-0 r16)
+(define-integrable regnum:scratch-1 r17)
+(define-integrable regnum:regs-pointer r19)
+(define-integrable regnum:free-pointer r20)
+(define-integrable regnum:dynamic-link r21) ;Pointer to parent stack frame.
+(define-integrable regnum:memtop r22)
+(define-integrable regnum:c-frame-pointer r29)
+(define-integrable regnum:link-register rlr) ;Return address.
+(define-integrable regnum:stack-pointer rsp)
+
+;; XXX Maybe we're playing a dangerous game to use the scratch registers for
+;; these.
+(define-integrable regnum:apply-target regnum:scratch-0)
+(define-integrable regnum:apply-pc regnum:scratch-1)
+
+(define-integrable (machine-register-known-value register)
+  register                              ;ignore
+  #f)
+
+(define machine-register-value-class
+  (let ((classes (make-vector 64)))
+    ;; Fill in defaults.
+    (do ((i 0 (+ i 1)))
+        ((>= i 32))
+      (vector-set! classes i value-class=object))
+    (do ((i 32 (+ i 1)))
+        ((>= i 64))
+      (vector-set! classes i value-class=float))
+    (vector-set! classes regnum:scratch-0 value-class=unboxed)
+    (vector-set! classes regnum:scratch-1 value-class=unboxed)
+    (vector-set! classes regnum:regs-pointer value-class=address)
+    (vector-set! classes regnum:free-pointer value-class=address)
+    (vector-set! classes regnum:dynamic-link value-class=address)
+    (vector-set! classes regnum:memtop value-class=address)
+    (vector-set! classes regnum:c-frame-pointer value-class=address)
+    (vector-set! classes regnum:stack-pointer value-class=address)
+    (named-lambda (machine-register-value-class register)
+      (assert (<= 0 register))
+      (assert (< register number-of-machine-registers))
+      (vector-ref classes register))))
+
+(define-integrable register-block/memtop-offset 0)
+(define-integrable register-block/int-mask-offset 1)
+(define-integrable register-block/value-offset 2)
+(define-integrable register-block/environment-offset 3)
+(define-integrable register-block/dynamic-link-offset 4) ; compiler temp
+(define-integrable register-block/lexpr-primitive-arity-offset 7)
+(define-integrable register-block/stack-guard-offset 11)
+(define-integrable register-block/int-code-offset 12)
+(define-integrable register-block/reflect-to-interface-offset 13)
+
+(define-integrable (interpreter-value-register)
+  (rtl:make-machine-register regnum:value-register))
+
+(define (interpreter-value-register? expression)
+  (and (rtl:register? expression)
+       (= (rtl:register-number expression) regnum:value-register)))
+
+(define-integrable (interpreter-regs-pointer)
+  (rtl:make-machine-register regnum:regs-pointer))
+
+(define (interpreter-regs-pointer? expression)
+  (and (rtl:register? expression)
+       (= (rtl:register-number expression) regnum:regs-pointer)))
+
+(define-integrable (interpreter-free-pointer)
+  (rtl:make-machine-register regnum:free-pointer))
+
+(define (interpreter-free-pointer? expression)
+  (and (rtl:register? expression)
+       (= (rtl:register-number expression) regnum:free-pointer)))
+
+(define-integrable (interpreter-dynamic-link)
+  (rtl:make-machine-register regnum:dynamic-link))
+
+(define (interpreter-dynamic-link? expression)
+  (and (rtl:register? expression)
+       (= (rtl:register-number expression) regnum:dynamic-link)))
+
+(define-integrable (interpreter-stack-pointer)
+  (rtl:make-machine-register regnum:stack-pointer))
+
+(define (interpreter-stack-pointer? expression)
+  (and (rtl:register? expression)
+       (= (rtl:register-number expression) regnum:stack-pointer)))
+
+(define (interpreter-register:access)
+  (rtl:make-machine-register r0))
+
+(define (interpreter-register:cache-reference)
+  (rtl:make-machine-register r0))
+
+(define (interpreter-register:cache-unassigned?)
+  (rtl:make-machine-register r0))
+
+(define (interpreter-register:lookup)
+  (rtl:make-machine-register r0))
+
+(define (interpreter-register:unassigned?)
+  (rtl:make-machine-register r0))
+
+(define (interpreter-register:unbound?)
+  (rtl:make-machine-register r0))
+
+(define (rtl:machine-register? register-name)
+  (case register-name
+    ((DYNAMIC-LINK) (interpreter-dynamic-link))
+    ((FREE) (interpreter-free-pointer))
+    ((MEMORY-TOP) (rtl:make-machine-register regnum:memtop))
+    ((STACK-POINTER) (interpreter-stack-pointer))
+    ((VALUE) (interpreter-value-register))
+    ((INTERPRETER-CALL-RESULT:ACCESS)
+     (interpreter-register:access))
+    ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+     (interpreter-register:cache-reference))
+    ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+     (interpreter-register:cache-unassigned?))
+    ((INTERPRETER-CALL-RESULT:LOOKUP)
+     (interpreter-register:lookup))
+    ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
+     (interpreter-register:unassigned?))
+    ((INTERPRETER-CALL-RESULT:UNBOUND?)
+     (interpreter-register:unbound?))
+    (else #f)))
+
+(define (rtl:interpreter-register? rtl-register)
+  (case rtl-register
+    ((INT-MASK) register-block/int-mask-offset)
+    ((ENVIRONMENT) register-block/environment-offset)
+    ((DYNAMIC-LINK) register-block/dynamic-link-offset)
+    (else #f)))
+
+(define (rtl:interpreter-register->offset locative)
+  (or (rtl:interpreter-register? locative)
+      (error "Unknown interpreter register:" locative)))
+
+(define (rtl:constant-cost expression)
+  ;; XXX Justify this by reference to cycle counts, &c.  This really
+  ;; depends on which instruction we're talking about -- sometimes
+  ;; immediates are cheaper.
+  (let ((cost:zero 0)
+        (cost:imm16 1)                  ;MOVZ/MOVN
+        (cost:imm32 2)                  ;MOVZ/MOVN + 1*MOVK
+        (cost:imm48 3)                  ;MOVZ/MOVN + 2*MOVK
+        (cost:imm64 4)                  ;MOVZ/MOVN + 3*MOVK
+        (cost:adr 1)
+        (cost:ldr 10)
+        (cost:bl 2))
+    (define (immediate-cost immediate)
+      (cond ((zero? immediate)
+             cost:zero)
+            ((or (fits-in-unsigned-16? immediate)
+                 (fits-in-unsigned-16? (- immediate)))
+             cost:imm16)
+            ((or (fits-in-unsigned-32? immediate)
+                 (fits-in-unsigned-32? (- immediate)))
+             cost:imm32)
+            ((or (fits-in-unsigned-48? immediate)
+                 (fits-in-unsigned-48? (- immediate)))
+             cost:imm48)
+            (else
+             cost:imm64)))
+    (define (tagged-immediate-cost tag datum)
+      (immediate-cost (make-non-pointer-literal tag datum)))
+    (define (load-pc-relative-address-cost)
+      cost:adr)
+    (define (load-pc-relative-cost)
+      (+ (load-pc-relative-address-cost) cost:ldr))
+    (define (branch-and-link-cost)
+      cost:bl)
+    (define (offset-cost base offset scale)
+      scale
+      (let ((base-cost (rtl:expression-cost base)))
+        (and base-cost
+             (+ base-cost
+                (if (rtl:machine-constant? offset)
+                    (let ((offset
+                           (abs
+                            (* scale (rtl:machine-constant-value offset)))))
+                      (cond ((or (fits-in-unsigned-12? (abs offset))
+                                 (and (zero?
+                                       (remainder (abs offset) (expt 2 12)))
+                                      (fits-in-unsigned-12?
+                                       (quotient (abs offset) (expt 2 12)))))
+                             cost:add)
+                            (else
+                             (+ (immediate-cost offset)
+                                cost:add))))
+                    cost:add)))))
+    (case (rtl:expression-type expression)
+      ((MACHINE-CONSTANT)
+       (immediate-cost (rtl:machine-constant-value expression)))
+      ((CONSTANT)
+       (let ((value (rtl:constant-value expression)))
+         (if (non-pointer-object? value)
+             (immediate-cost (non-pointer->literal value))
+             (load-pc-relative-cost))))
+      ((ENTRY:PROCEDURE)
+       (load-pc-relative-address-cost))
+      ((ENTRY:CONTINUATION)
+       (branch-and-link-cost))
+      ((VARIABLE-CACHE ASSIGNMENT-CACHE)
+       (load-pc-relative-cost))
+      ((OFFSET-ADDRESS)
+       (offset-cost (rtl:offset-address-base expression)
+                    (rtl:offset-address-offset expression)
+                    address-units-per-object))
+      ((BYTE-OFFSET-ADDRESS)
+       (offset-cost (rtl:byte-offset-address-base expression)
+                    (rtl:byte-offset-address-offset expression)
+                    1))
+      ((FLOAT-OFFSET-ADDRESS)
+       (offset-cost (rtl:float-offset-address-base expression)
+                    (rtl:float-offset-address-offset expression)
+                    address-units-per-float))
+      ((CONS-POINTER)
+       (let ((type (rtl:cons-pointer-type expression))
+             (datum (rtl:cons-pointer-datum expression)))
+         (and (rtl:machine-constant? type)
+              (rtl:machine-constant? datum)
+              (let ((type (rtl:machine-constant-value type))
+                    (datum (rtl:machine-constant-value datum)))
+                (tagged-immediate-cost type datum)))))
+      (else #f))))
+
+(define compiler:open-code-floating-point-arithmetic?
+  ;; XXX not yet
+  #f)
+
+(define compiler:primitives-with-no-open-coding
+  ;; XXX Should really make this a whitelist, not a blacklist.
+  '(
+    &/                  ;nobody open-codes this
+    DIVIDE-FIXNUM       ;nobody open-codes this
+    FIXNUM-LSH          ;open-coding not useful without constant operands
+    FLOATING-VECTOR-CONS;nobody open-codes this
+    FLONUM-ABS          ;no flonum arithmetic yet
+    FLONUM-ACOS         ;not useful to open-code hairy math
+    FLONUM-ADD          ;no flonum arithmetic yet
+    FLONUM-ASIN         ;not useful to open-code hairy math
+    FLONUM-ATAN         ;not useful to open-code hairy math
+    FLONUM-ATAN2        ;not useful to open-code hairy math
+    FLONUM-CEILING      ;no flonum arithmetic yet
+    FLONUM-COS          ;not useful to open-code hairy math
+    FLONUM-DIVIDE       ;no flonum arithmetic yet
+    FLONUM-EXP          ;not useful to open-code hairy math
+    FLONUM-EXPM1        ;not useful to open-code hairy math
+    FLONUM-FLOOR        ;no flonum arithmetic yet
+    FLONUM-LOG          ;not useful to open-code hairy math
+    FLONUM-LOG1P        ;not useful to open-code hairy math
+    FLONUM-MULTIPLY     ;no flonum arithmetic yet
+    FLONUM-NEGATE       ;no flonum arithmetic yet
+    FLONUM-ROUND        ;no flonum arithmetic yet
+    FLONUM-SIN          ;not useful to open-code hairy math
+    FLONUM-SQRT         ;no flonum arithmetic yet
+    FLONUM-SUBTRACT     ;no flonum arithmetic yet
+    FLONUM-TAN          ;not useful to open-code hairy math
+    FLONUM-TRUNCATE     ;no flonum arithmetic yet
+    GCD-FIXNUM          ;nobody open-codes this
+    VECTOR-CONS         ;nobody open-codes this
+    ))
diff --git a/src/compiler/machines/aarch64/make.scm b/src/compiler/machines/aarch64/make.scm
new file mode 100644
index 000000000..02ec587c7
--- /dev/null
+++ b/src/compiler/machines/aarch64/make.scm
@@ -0,0 +1,33 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Compiler: System Construction
+
+(declare (usual-integrations))
+
+(let ((value ((load "base/make") "AArch64")))
+  (set! (access compiler:compress-top-level? (->environment '(compiler))) #t)
+  value)
diff --git a/src/compiler/machines/aarch64/order-be.scm b/src/compiler/machines/aarch64/order-be.scm
new file mode 100644
index 000000000..82ff722cf
--- /dev/null
+++ b/src/compiler/machines/aarch64/order-be.scm
@@ -0,0 +1,32 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Machine Model for AArch64: Byte Order
+;;; package: (compiler)
+
+(declare (usual-integrations))
+
+(define-integrable endianness 'BIG)
diff --git a/src/compiler/machines/aarch64/order-le.scm b/src/compiler/machines/aarch64/order-le.scm
new file mode 100644
index 000000000..3699f56ab
--- /dev/null
+++ b/src/compiler/machines/aarch64/order-le.scm
@@ -0,0 +1,32 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Machine Model for AArch64: Byte Order
+;;; package: (compiler)
+
+(declare (usual-integrations))
+
+(define-integrable endianness 'LITTLE)
diff --git a/src/compiler/machines/aarch64/rgspcm.scm b/src/compiler/machines/aarch64/rgspcm.scm
new file mode 100644
index 000000000..c148e0d3b
--- /dev/null
+++ b/src/compiler/machines/aarch64/rgspcm.scm
@@ -0,0 +1,67 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; RTL Generation: Special primitive combinations.  AArch64 version.
+;;; package: (compiler rtl-generator)
+
+(declare (usual-integrations))
+
+(define (define-special-primitive-handler name handler)
+  (let ((primitive (make-primitive-procedure name true)))
+    (let ((entry (assq primitive special-primitive-handlers)))
+      (if entry
+          (set-cdr! entry handler)
+          (set! special-primitive-handlers
+                (cons (cons primitive handler)
+                      special-primitive-handlers)))))
+  name)
+
+(define (special-primitive-handler primitive)
+  (let ((entry (assq primitive special-primitive-handlers)))
+    (and entry
+         (cdr entry))))
+
+(define special-primitive-handlers
+  '())
+
+(define (define-special-primitive/standard primitive)
+  (define-special-primitive-handler primitive
+    rtl:make-invocation:special-primitive))
+
+(define-special-primitive/standard '&+)
+(define-special-primitive/standard '&-)
+(define-special-primitive/standard '&*)
+(define-special-primitive/standard '&/)
+(define-special-primitive/standard '&=)
+(define-special-primitive/standard '&<)
+(define-special-primitive/standard '&>)
+(define-special-primitive/standard '1+)
+(define-special-primitive/standard '-1+)
+(define-special-primitive/standard 'zero?)
+(define-special-primitive/standard 'positive?)
+(define-special-primitive/standard 'negative?)
+(define-special-primitive/standard 'quotient)
+(define-special-primitive/standard 'remainder)
diff --git a/src/compiler/machines/aarch64/rules1.scm b/src/compiler/machines/aarch64/rules1.scm
new file mode 100644
index 000000000..171051727
--- /dev/null
+++ b/src/compiler/machines/aarch64/rules1.scm
@@ -0,0 +1,316 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Data Transfers.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+;;;; Register Assignments
+
+(assert (zero? (remainder address-units-per-object 4)))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+  (assign-register->register target source))
+
+;;;; Tagging and detagging
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (CONS-POINTER (REGISTER (? type))
+                        (REGISTER (? datum))))
+  (cond ((let ((type (register-known-value type)))
+           (and type (zero? type)))
+         (assign-register->register target datum))
+        ((register-copy-if-available datum 'GENERAL target)
+         => (lambda (get-target!)
+              ;; If we already have a suitable register for the target,
+              ;; use bit field insertion to set the type.
+              (let* ((type (standard-source! type))
+                     (target (get-target!))
+                     (lsb scheme-datum-width)
+                     (width scheme-type-width))
+                (LAP (BFI X ,target ,type (&U ,lsb) (&U ,width))))))
+        (else
+         ;; Otherwise, no advantage to using bit field insertion since
+         ;; we'd need two instructions anyway, so just shift and or.
+         (standard-binary target type datum
+           (lambda (target type datum)
+             (LAP (LSL X ,target ,type (&U ,scheme-datum-width))
+                  (ORR X ,target ,target ,datum)))))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (CONS-POINTER (MACHINE-CONSTANT (? type))
+                        (REGISTER (? datum))))
+  (standard-unary target datum
+    (lambda (target datum)
+      (affix-type target type datum))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+  (standard-unary target source object->type))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+  (standard-unary target source object->datum))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+  (standard-unary target source object->address))
+
+;;;; Loading constants
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? n)))
+  (load-signed-immediate (standard-target! target) n))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (CONSTANT (? object)))
+  (load-constant (standard-target! target) object))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (CONS-POINTER (MACHINE-CONSTANT (? type))
+                        (MACHINE-CONSTANT (? datum))))
+  (load-tagged-immediate (standard-target! target) type datum))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+  (load-pc-relative-address
+   (standard-target! target)
+   (rtl-procedure/external-label (label->object label))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+  (rtl-target:=machine-register! target regnum:link-register)
+  (let ((linked (generate-label 'LINKED)))
+    (LAP (BL (@PCR ,linked))
+         (B (@PCR ,label))
+        (LABEL ,linked))))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+  (load-pc-relative (standard-target! target) (free-reference-label name)))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+  (load-pc-relative (standard-target! target) (free-assignment-label name)))
+
+;;;; Address arithmetic
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+                               (REGISTER (? offset))))
+  (load-indexed-address target base offset 1))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+                               (MACHINE-CONSTANT (? offset))))
+  (load-displaced-address target base offset 1))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (OFFSET-ADDRESS (REGISTER (? base))
+                          (REGISTER (? offset))))
+  (load-indexed-address target base offset address-units-per-object))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (OFFSET-ADDRESS (REGISTER (? base))
+                          (MACHINE-CONSTANT (? offset))))
+  (load-displaced-address target base offset address-units-per-object))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+                                (REGISTER (? offset))))
+  (load-indexed-address target base offset address-units-per-float))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+                                (MACHINE-CONSTANT (? offset))))
+  (load-displaced-address target base offset address-units-per-float))
+
+;;;; Loads and stores
+
+;;; Load indexed
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (OFFSET (REGISTER (? base)) (REGISTER (? offset))))
+  (QUALIFIER (not (= offset rsp)))
+  (standard-binary target base offset
+    (lambda (target base offset)
+      (LAP (LDR X ,target (+ ,base (LSL ,offset 3)))))))
+
+;;; Store indexed
+
+(define-rule statement
+  (ASSIGN (OFFSET (REGISTER (? base)) (REGISTER (? offset)))
+          (? source register-expression))
+  (QUALIFIER (not (= offset rsp)))
+  (standard-ternary-effect base offset source
+    (lambda (base offset source)
+      (LAP (STR X ,source (+ ,base (LSL ,offset 3)))))))
+
+;;; Load with displacement
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
+  (QUALIFIER (fits-in-unsigned-12? offset))
+  (standard-unary target base
+    (lambda (target base)
+      (LAP (LDR X ,target (+ ,base (&U (* 8 ,offset))))))))
+
+;;; Store with displacement
+
+(define-rule statement
+  (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+          (? source register-expression))
+  (QUALIFIER (fits-in-unsigned-12? offset))
+  (standard-binary-effect base source
+    (lambda (base source)
+      (LAP (STR X ,source (+ ,base (&U (* 8 ,offset))))))))
+
+;;;; Loads and stores with pre/post-increment
+
+;;; Load with pre-increment: *++x
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (PRE-INCREMENT (REGISTER (? sp)) (? offset)))
+  (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+  (standard-unary target sp
+    (lambda (target sp)
+      (LAP (LDR X ,target (PRE+ ,sp (& ,offset)))))))
+
+;;; Load with post-increment: *x++
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? sp)) (? offset)))
+  (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+  (standard-unary target sp
+    (lambda (target sp)
+      (LAP (LDR X ,target (POST+ ,sp (& ,offset)))))))
+
+;;; Store with pre-increment: *++x = y
+
+(define-rule statement
+  (ASSIGN (PRE-INCREMENT (REGISTER (? sp)) (? offset))
+          (? source register-expression))
+  (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+  (standard-binary-effect sp source
+    (lambda (sp source)
+      (let ((offset (* offset (quotient address-units-per-object 4))))
+        (LAP (STR X ,source (PRE+ ,sp (& ,offset))))))))
+
+;;; Store with post-increment: *x++ = y
+
+(define-rule statement
+  (ASSIGN (POST-INCREMENT (REGISTER (? sp)) (? offset))
+          (? source register-expression))
+  (QUALIFIER (<= -64 (* offset (quotient address-units-per-object 4)) 63))
+  (standard-binary-effect sp source
+    (lambda (sp source)
+      (let ((offset (* offset (quotient address-units-per-object 4))))
+        (LAP (STR X ,source (POST+ ,sp (& ,offset))))))))
+
+;;;; Byte access
+
+;;; Detagging a character -- no ASCII->CHAR because that's just
+;;; CONS-NON-POINTER = CONS-POINTER.
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (CHAR->ASCII (REGISTER (? source))))
+  (standard-unary target source
+    (lambda (target source)
+      (LAP (AND X ,target ,source (&U #xff))))))
+
+;;; Load byte indexed
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (BYTE-OFFSET (REGISTER (? base)) (REGISTER (? offset))))
+  (QUALIFIER (not (= offset rsp)))
+  (standard-binary target base offset
+    (lambda (target base offset)
+      (LAP (LDR B ,target (+ ,base ,offset))))))
+
+;;; Store byte indexed
+
+(define-rule statement
+  (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (REGISTER (? offset)))
+          (? source register-expression))
+  (standard-ternary-effect base offset source
+    (lambda (base offset source)
+      (LAP (STR B ,source (+ ,base ,offset))))))
+
+;;; Detag and store byte indexed
+
+(define-rule statement
+  (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (REGISTER (? offset)))
+          (CHAR->ASCII (? source register-expression)))
+  (standard-ternary-effect base offset source
+    (lambda (base offset source)
+      (LAP (STR B ,source (+ ,base ,offset))))))
+
+;;; Load byte with displacement
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (BYTE-OFFSET (REGISTER (? base))
+                       (MACHINE-CONSTANT (? offset))))
+  (QUALIFIER (not (= offset rsp)))
+  (standard-binary target base offset
+    (lambda (target base offset)
+      (LAP (LDR B ,target (+ ,base (&U ,offset)))))))
+
+;;; Store byte with displacement
+
+(define-rule statement
+  (ASSIGN (BYTE-OFFSET (REGISTER (? base))
+                       (MACHINE-CONSTANT (? offset)))
+          (? source register-expression))
+  (QUALIFIER (not (= offset rsp)))
+  (standard-binary-effect source base
+    (lambda (source base)
+      (LAP (STR B ,target (+ ,base (&U ,offset)))))))
+
+;;; Detag and store byte with displacement
+
+(define-rule statement
+  (ASSIGN (BYTE-OFFSET (REGISTER (? base))
+                       (MACHINE-CONSTANT (? offset)))
+          (CHAR->ASCII (? source register-expression)))
+  (QUALIFIER (not (= offset rsp)))
+  (standard-binary-effect source base
+    (lambda (source base)
+      (LAP (STR B ,target (+ ,base (&U ,offset)))))))
diff --git a/src/compiler/machines/aarch64/rules2.scm b/src/compiler/machines/aarch64/rules2.scm
new file mode 100644
index 000000000..dc5ab2112
--- /dev/null
+++ b/src/compiler/machines/aarch64/rules2.scm
@@ -0,0 +1,112 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Predicates
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+(define-rule predicate
+  (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
+  (set-equal-branches!)
+  (standard-binary-effect source1 source2
+    (lambda (source1 source2)
+      (LAP (CMP X ,source1 ,source2)))))
+
+(define-rule predicate
+  (EQ-TEST (REGISTER (? source)) (MACHINE-CONSTANT (? immediate)))
+  (eq-test/register*immediate! (standard-source! source) immediate))
+
+(define-rule predicate
+  (EQ-TEST (MACHINE-CONSTANT (? immediate)) (REGISTER (? source)))
+  (eq-test/register*immediate! (standard-source! source) immediate))
+
+(define-rule predicate
+  (EQ-TEST (REGISTER (? source))
+           (CONS-POINTER (MACHINE-CONSTANT (? type))
+                         (MACHINE-CONSTANT (? datum))))
+  (eq-test/register*tagged-immediate! (standard-source! source) type datum))
+
+(define-rule predicate
+  (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+                         (MACHINE-CONSTANT (? datum)))
+           (REGISTER (? source)))
+  (eq-test/register*tagged-immediate! (standard-source! source) type datum))
+
+(define-rule predicate
+  (EQ-TEST (REGISTER (? source)) (CONSTANT (? constant)))
+  (QUALIFIER
+   ;; Worth it only if we can confirm it's zero.
+   (and (non-pointer-object? constant)
+        (= 0 (non-pointer->literal constant))))
+  (zero-test! (standard-source! source)))
+
+(define-rule predicate
+  (EQ-TEST (CONSTANT (? constant)) (REGISTER (? source)))
+  (QUALIFIER
+   ;; Worth it only if we can confirm it's zero.
+   (and (non-pointer-object? constant)
+        (= 0 (non-pointer->literal constant))))
+  (zero-test! (standard-source! source)))
+
+(define-rule predicate
+  (TYPE-TEST (REGISTER (? register)) (? type))
+  (immediate-equal-test! (standard-source! register) type))
+
+;; Test tag and sign in one swell foop.
+
+(define-rule predicate
+  (PRED-1-ARG INDEX-FIXNUM? (REGISTER (? register)))
+  (let ((temp (standard-move-to-temporary! register)))
+    (set-equal-branches!)
+    (LAP (LSR X ,temp (&U ,(- scheme-datum-width 1)))
+         (CMP X ,temp (&U ,(* 2 type-code:fixnum))))))
+
+(define (set-equal-branches!)
+  (set-current-branches! (lambda (label) (LAP (B.EQ (@PCR ,label))))
+                         (lambda (label) (LAP (B.NE (@PCR ,label))))))
+
+(define (set-not-equal-branches!)
+  (set-current-branches! (lambda (label) (LAP (B.NE (@PCR ,label))))
+                         (lambda (label) (LAP (B.EQ (@PCR ,label))))))
+
+(define (set-equal-zero-branches! source)
+  (set-current-branches! (lambda (label) (LAP (CBZ ,source (@PCR ,label))))
+                         (lambda (label) (LAP (CBNZ ,source (@PCR ,label))))))
+
+(define (zero-test! register)
+  (set-equal-zero-branches! register)
+  (LAP))
+
+(define (eq-test/register*tagged-immediate! register type datum)
+  (eq-test/register*immediate! register (make-non-pointer-literal type datum)))
+
+(define (eq-test/register*immediate! register immediate)
+  (if (= immediate 0)
+      (zero-test! register)
+      (begin
+        (set-equal-branches!)
+        (cmp-immediate register immediate))))
diff --git a/src/compiler/machines/aarch64/rules3.scm b/src/compiler/machines/aarch64/rules3.scm
new file mode 100644
index 000000000..e4e1fe5ba
--- /dev/null
+++ b/src/compiler/machines/aarch64/rules3.scm
@@ -0,0 +1,742 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+;;;; Invocations
+
+(define-rule statement
+  (POP-RETURN)
+  (let* ((checks (get-interrupt-checks))
+         (prefix (clear-map!))
+         (suffix
+          (if (pair? checks)
+              (pop-return/interrupt-check)
+              (pop-return))))
+    (LAP ,@prefix
+         ,@suffix)))
+
+(define (pop-return)
+  (LAP ,@(pop rlr)
+       ,@(object->address rlr rlr)
+       (RET)))
+
+(define (pop-return/interrupt-check)
+  (share-instruction-sequence! 'POP-RETURN
+    (lambda (shared-label) (LAP (B (@PCR ,shared-label))))
+    (lambda (shared-label)
+      (let ((interrupt-label (generate-label 'INTERRUPT)))
+        (LAP (LABEL ,shared-label)
+             ,@(interrupt-check '(HEAP) label)
+             ,@(pop-return)
+             (LABEL ,interrupt-label)
+             ,@(invoke-hook entry:compiler-interrupt-continuation-2))))))
+
+(define-rule statement
+  (INVOCATION:APPLY (? frame-size) (? continuation))
+  continuation
+  (let* ((prefix (clear-map!))
+         (setup (apply-setup frame-size)))
+    (LAP ,@prefix
+         ,@(pop ,regnum:apply-target)
+         ,@setup
+         (BR ,regnum:apply-pc))))
+
+(define (apply-setup frame-size)
+  (case frame-size
+    ((1) (invoke-hook/subroutine entry:compiler-apply-setup-size-1))
+    ((2) (invoke-hook/subroutine entry:compiler-apply-setup-size-2))
+    ((3) (invoke-hook/subroutine entry:compiler-apply-setup-size-3))
+    ((4) (invoke-hook/subroutine entry:compiler-apply-setup-size-4))
+    ((5) (invoke-hook/subroutine entry:compiler-apply-setup-size-5))
+    ((6) (invoke-hook/subroutine entry:compiler-apply-setup-size-6))
+    ((7) (invoke-hook/subroutine entry:compiler-apply-setup-size-7))
+    ((8) (invoke-hook/subroutine entry:compiler-apply-setup-size-8))
+    (else
+     (LAP ,@(load-unsigned-immediate regnum:utility-arg0 frame-size)
+          ,@(invoke-hook/subroutine entry:compiler-apply-setup)))))
+
+(define-rule statement
+  (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+  frame-size continuation
+  (expect-no-exit-interrupt-checks)
+  (LAP ,@(clear-map!)
+       (B (@PCR ,label))))
+
+(define (entry->pc pc entry)
+  ;; XXX Would be nice to skip the SUB, but LDR doesn't have a signed
+  ;; offset without pre/post-increment.
+  (LAP (SUB X ,pc ,entry (&U 8))
+       (LDR X ,pc ,pc)
+       (ADD X ,pc ,pc ,entry)))
+
+(define-rule statement
+  (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+  frame-size continuation
+  (expect-no-exit-interrupt-checks)
+  ;; Tagged entry is on top of stack.
+  (LAP ,@(clear-map!)
+       ,@(pop regnum:apply-target)
+       ,@(object->address regnum:apply-target regnum:apply-target)
+       ,@(entry->pc regnum:apply-pc regnum:apply-target)
+       (BR ,regnum:apply-pc)))
+
+(define-rule statement
+  (INVOCATION:LEXPR (? number-pushed) (? continuation) (? labe))
+  (LAP ,@(clear-map!)
+       ,@(load-pc-relative-address regnum:utility-arg0 label)
+       ,@(load-unsigned-immediate regnum:utility-arg1 number-pushed)
+       ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+  (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation) (? labe))
+  (LAP ,@(clear-map!)
+       ,@(pop regnum:utility-arg0)
+       ,@(object->address regnum:utility-arg0 regnum:utility-arg0)
+       ,@(load-unsigned-immediate regnum:utility-arg1 number-pushed)
+       ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+  (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+  continuation
+  (expect-no-exit-interrupt-checks)
+  (LAP ,@(clear-map!)
+       (B (@PCRO ,(free-uuo-link-label name frame-size)
+                 ,(uuo-link-label-offset)))))
+
+(define-rule statement
+  (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+  continuation
+  (expect-no-exit-interrupt-checks)
+  (LAP ,@(clear-map!)
+       (B (@PCRO ,(global-uuo-link-label name frame-size)
+                 ,(uuo-link-label-offset)))))
+
+(define-rule statement
+  (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
+  (error "Unsupported RTL:"
+         `(INVOCATION:CACHE-REFERENCE ,frame-size ,continuation ,extension)))
+
+(define-rule statement
+  (INVOCATION:LOOKUP (? frame-size) (? continuation) (? extension))
+  (error "Unsupported RTL:"
+         `(INVOCATION:CACHE-REFERENCE ,frame-size ,continuation ,extension)))
+
+(define-rule statement
+  (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+  continuation
+  (cond ((eq? primitive compiled-error-procedure)
+         (generate/compiled-error frame-size))
+        ;; ((eq? primitive (ucode-primitive set-interrupt-enables!)) ...)
+        ;; ((eq? primitive (ucode-primitive with-interrupt-mask)) ...)
+        ;; ((eq? primitive (ucode-primitive with-interrupts-reduced)) ...)
+        ;; ((eq? primitive (ucode-primitive with-stack-marker)) ...)
+        (else
+         (generate/generic-primitive frame-size primitive))))
+
+(define (generate/compiled-error frame-size)
+  (let* ((prefix (clear-map!))
+         (arg0 (load-unsigned-immediate regnum:utility-arg0 frame-size))
+         (invocation (invoke-hook entry:compiler-error)))
+    (LAP ,@prefix
+         ,@arg0
+         ,@invocation)))
+
+(define (generate/generic-primitive frame-size primitive)
+  (let* ((prefix (clear-map!))
+         (arg0 (load-constant primitive regnum:utility-arg0)))
+    (LAP ,@prefix
+         ,@arg0
+         ,@(let ((arity (primitive-procedure-arity primitive)))
+             (cond ((not (negative? arity))
+                    (generate/primitive-apply))
+                   ((= arity -1)
+                    (generate/primitive-lexpr-apply frame-size))
+                   (else
+                    (generate/generic-apply frame-size)))))))
+
+(define (generate/primitive-apply)
+  (invoke-hook entry:compiler-primitive-apply))
+
+(define (generate/primitive-lexpr-apply frame-size)
+  (let* ((load-nargs
+          (load-unsigned-immediate regnum:scratch-0 (- frame-size 1)))
+         (invocation (invoke-hook entry:compiler-primitive-lexpr-apply)))
+    (LAP ,@load-nargs
+         (STR X ,regnum:scratch-0 ,reg:lexpr-primitive-apply)
+         ,@invocation)))
+
+(define (generate/generic-apply frame-size)
+  (let* ((arg1 (load-unsigned-immediate regnum:utility-arg1 frame-size))
+         (invocation (invoke-interface code:compiler-apply)))
+    (LAP ,@arg1
+         ,@invocation)))
+
+(let-syntax
+    ((define-primitive-invocation
+       (sc-macro-transformer
+        (lambda (form environment)
+          (let ((name (cadr form)))
+            `(define-rule statement
+               (INVOCATION:SPECIAL-PRIMITIVE
+                (? frame-size)
+                (? continuation)
+                ,(make-primitive-procedure name #t))
+               frame-size continuation
+               (expect-no-exit-interrupt-checks)
+               #|
+               (special-primitive-invocation
+                ,(close-syntax (symbol 'CODE:COMPILER- name)
+                               environment))
+               |#
+               (optimized-primitive-invocation
+                ,(close-syntax (symbol 'ENTRY:COMPILER- name)
+                               environment))))))))
+
+  (define-primitive-invocation &+)
+  (define-primitive-invocation &-)
+  (define-primitive-invocation &*)
+  (define-primitive-invocation &/)
+  (define-primitive-invocation &=)
+  (define-primitive-invocation &<)
+  (define-primitive-invocation &>)
+  (define-primitive-invocation 1+)
+  (define-primitive-invocation -1+)
+  (define-primitive-invocation zero?)
+  (define-primitive-invocation positive?)
+  (define-primitive-invocation negative?)
+  (define-primitive-invocation quotient)
+  (define-primitive-invocation remainder))
+
+(define (special-primitive-invocation code)
+  (let* ((prefix (clear-map!))
+         (invocation (invoke-interface code)))
+    (LAP ,@prefix
+         ,@invocation)))
+
+(define (optimized-primitive-invocation entry)
+  (let* ((prefix (clear-map!))
+         (invocation (invoke-hook entry)))
+    (LAP ,@prefix
+         ,@invocation)))
+
+;;;; Invocation Prefixes
+
+;;; (INVOCATION-PREFIX:MOVE-FRAME-UP <nwords> <address>)
+;;;
+;;;     Pop <nwords> off the stack, set the stack to <address>, and
+;;;     push them back on the stack.
+;;;
+;;; (INVOCATION-PREFIX:DYNAMIC-LINK <nwords> <address> <dynamic-link>)
+;;;
+;;;     Pop <nwords> off the stack, set the stack pointer to the larger
+;;;     (i.e., more items on the stack, or lower addresses) of
+;;;     <address> or <dynamic-link>, and push them back on the stack.
+
+(define-rule statement
+  (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? address)))
+  (let ((address (standard-source! address)))
+    (assert (not (= register regnum:stack-pointer)))
+    (generate/move-frame-up frame-size address)))
+
+(define-rule statement
+  (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
+                                  (REGISTER (? address))
+                                  (REGISTER (? dynamic-link)))
+  ;; Could try to get a temporary out of the dynamic link, but we have
+  ;; lots of temporaries and this is probably the dedicated dynamic
+  ;; link machine register anyway.
+  (let* ((dynamic-link (standard-source! dynamic-link))
+         (address (standard-move-to-temporary! address)))
+    (assert (not (= address regnum:stack-pointer)))
+    (assert (not (= dynamic-link regnum:stack-pointer)))
+    (LAP (CMP X ,address ,dynamic-link)
+         (CSEL.GT ,address ,address ,dynamic-link)
+         ,@(generate/move-frame-up frame-size address))))
+
+(define (generate/move-frame-up frame-size address)
+  (assert (not (= register regnum:stack-pointer)))
+  (if (<= frame-size 6)                 ;Covers vast majority of cases.
+      (generate/move-frame-up/unrolled frame-size register)
+      (generate/move-frame-up/loop frame-size register)))
+
+(define (generate/move-frame-up/loop frame-size address)
+  (assert (not (= register regnum:stack-pointer)))
+  (assert (>= frame-size 2))
+  (assert (fits-in-unsigned-12? (* 8 frame-size))) ;XXX
+  (assert (= 8 address-units-per-object))
+  (let* ((temp1 (allocate-temporary-register! 'GENERAL))
+         (temp2 (allocate-temporary-register! 'GENERAL))
+         (index (allocate-temporary-register! 'GENERAL))
+         (label (generate-label 'MOVE-LOOP))
+         ;; Unroll an odd element if there is one; then do an even
+         ;; number of iterations.
+         (loop-count (- frame-size (remainder frame-size 2))))
+    (assert (= loop-count (* (quotient frame-size 2) 2)))
+    (LAP (ADD X ,regnum:stack-pointer ,regnum:stack-pointer
+                   (&U ,(* 8 frame-size)))
+         ,@(if (odd? frame-size)
+               (LAP (LDR X ,temp (PRE- ,regnum:stack-pointer (&U 8)))
+                    (STR X ,temp (PRE- ,address (&U 8))))
+               (LAP))
+         ,@(load-unsigned-immediate index loop-count)
+        (LABEL ,label)
+         (SUB X ,index (&U #x10))
+         (LDRP X ,temp1 ,temp2 (PRE- ,regnum:stack-pointer (&U #x10)))
+         (STRP X ,temp1 ,temp2 (PRE- ,address (&U #x10)))
+         (CBNZ X ,index (@PCR ,label))
+         ,@(register->register-transfer address regnum:stack-pointer))))
+
+(define (generate/move-frame-up/unrolled frame-size address)
+  (assert (not (= address regnum:stack-pointer)))
+  (assert (< frame-size 24))       ;Only 24 temporaries, incl. address.
+  (assert (= 8 address-units-per-object))
+  (let ((temps
+         ;; Allocate in order to get reproducible results.
+         (let loop ((n frame-size) (temps '()))
+           (if (zero? n)
+               temps
+               (let ((temp (allocate-temporary-register! 'GENERAL)))
+                 (loop (- n 1) (cons temp temps)))))))
+    (LAP ,@(let loop ((temps temps))
+             ;; (pop2 r1 r2) (pop2 r3 r4) (pop r5)
+             (if (pair? temps)
+                 (if (pair (cdr? temps))
+                     (LAP ,@(pop2 (car temps) (cadr temps))
+                          ,@(loop (cddr temps)))
+                     (pop (car temps)))
+                 (LAP)))
+         ,@(register->register-transfer address regnum:stack-pointer)
+         ,@(let loop ((temps temps))
+             ;; (push r5) (push r3 r4) (push r1 r2)
+             (if (pair? temps)
+                 (if (pair? (cdr temps))
+                     (LAP ,@(loop (cddr temps))
+                          ,@(push2 (car temps) (cadr temps)))
+                     (push (car temps)))
+                 (LAP))))))
+
+;;;; External Labels
+
+;;; Entry point types
+
+(define (make-procedure-code-word min max)
+  ;; The "min" byte must be less than #x80; the "max" byte may not
+  ;; equal #x80 but can take on any other value.
+  (if (or (negative? min) (>= min #x80))
+      (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
+  (if (>= (abs max) #x80)
+      (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
+  (make-code-word min (if (negative? max) (+ #x100 max) max)))
+
+(define internal-entry-code-word
+  (make-code-word #xff #xfe))
+
+(define internal-continuation-code-word
+  (make-code-word #xff #xfc))
+
+(define (frame-size->code-word offset default)
+  (cond ((not offset)
+         default)
+        ((< offset #x2000)
+         ;; This uses up through (#xff #xdf).
+         (let ((qr (integer-divide offset #x80)))
+           (make-code-word (+ #x80 (integer-divide-remainder qr))
+                           (+ #x80 (integer-divide-quotient qr)))))
+        (else
+         (error "Unable to encode continuation offset"
+                offset))))
+
+(define (continuation-code-word label)
+  (frame-size->code-word
+   (if label
+       (rtl-continuation/next-continuation-offset (label->object label))
+       0)
+   internal-continuation-code-word))
+
+(define (internal-procedure-code-word rtl-proc)
+  (frame-size->code-word
+   (rtl-procedure/next-continuation-offset rtl-proc)
+   internal-entry-code-word))
+
+;;;; Procedure headers
+
+;;; The following calls MUST appear as the first thing at the entry
+;;; point of a procedure.  They assume that the register map is clear
+;;; and that no register contains anything of value.
+;;;
+;;; The only reason that this is true is that no register is live
+;;; across calls.  If that were not true, then we would have to save
+;;; any such registers on the stack so that they would be GC'ed
+;;; appropriately.
+;;;
+;;; The only exception is the dynamic link register, handled
+;;; specially.  Procedures that require a dynamic link use a different
+;;; interrupt handler that saves and restores the dynamic link
+;;; register.
+
+(define (interrupt-check checks label)
+  (LAP ,@(if (or (memq 'INTERRUPT checks) (memq 'HEAP checks))
+             (LAP (LDR X ,regnum:scratch-0 ,reg:memtop)
+                  (CMP X ,regnum:free-pointer ,regnum:scratch-0)
+                  (B.GE (@PCR ,label)))
+             (LAP))
+       ,@(if (memq 'STACK checks)
+             (LAP (LDR X ,regnum:scratch-0 ,reg:stack-guard)
+                  (CMP X ,regnum:stack-pointer ,regnum:scratch-0)
+                  (B.LT (@PCR ,label)))
+             (LAP))))
+
+(define (simple-procedure-header code-word label entry)
+  (let ((checks (get-entry-interrupt-checks))
+        (interrupt-label (generate-label 'INTERRUPT)))
+    ;; Put the interrupt check branch target after the branch so that
+    ;; it is a forward branch, which CPUs will predict not taken by
+    ;; default, in the absence of dynamic branch prediction profile
+    ;; data.
+    (if (pair? checks)
+        (add-end-of-block-code!
+         (lambda ()
+           (LAP (LABEL ,interrupt-label)
+                ,@(invoke-hook/reentry entry label)))))
+    (LAP ,@(make-external-label code-word label)
+         ,@(interrupt-check checks interrupt-label))))
+
+(define-rule statement
+  (CONTINUATION-ENTRY (? internal-label))
+  (expect-no-entry-interrupt-checks)
+  (make-external-label (continuation-code-word internal-label)
+                       internal-label))
+
+(define-rule statement
+  (CONTINUATION-HEADER (? internal-label))
+  #|
+  (simple-procedure-header (continuation-code-word internal-label)
+                           internal-label
+                           entry:compiler-interrupt-continuation)
+  |#
+  (expect-no-entry-interrupt-checks)
+  (make-external-label (continuation-code-word internal-label)
+                       internal-label))
+
+(define-rule statement
+  (IC-PROCEDURE-HEADER (? internal-label))
+  (error "IC procedures not supported:"
+         `(IC-PROCEDURE-HEADER ,internal-label)))
+
+(define-rule statement
+  (OPEN-PROCEDURE-HEADER (? internal-label))
+  (let ((rtl-proc (label->object internal-label)))
+    (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
+         ,@(simple-procedure-header (internal-procedure-code-word rtl-proc)
+                                    internal-label
+                                    (if (rtl-procedure/dynamic-link? rtl-proc)
+                                        entry:compiler-interrupt-dlink
+                                        entry:compiler-interrupt-procedure)))))
+
+(define-rule statement
+  (PROCEDURE-HEADER (? internal-label) (? min) (? max))
+  (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
+               ,internal-label)
+       ,@(simple-procedure-header (make-procedure-code-word min max)
+                                  internal-label
+                                  entry:compiler-interrupt-procedure)))
+
+;;;; Closures
+
+(define-rule statement
+  (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+  entry                                 ;ignore
+  (let* ((rtl-proc (label->object internal-label))
+         (external-label (rtl-procedure/external-label rtl-proc))
+         (checks (get-entry-interrupt-checks))
+         (type type-code:compiled-entry))
+    (define (label+adjustment)
+      (LAP ,@(make-external-label internal-entry-code-word external-label)
+           ;; regnum:apply-target holds the untagged entry address.
+           ;; Push and tag it.
+           ,@(affix-type regnum:apply-target type regnum:apply-target)
+           ,@(push regnum:apply-target)
+          (LABEL ,internal-label)))
+    (cond ((zero? nentries)
+           (LAP (EQUATE ,external-label ,internal-label)
+                ,@(simple-procedure-header
+                   (internal-procedure-code-word rtl-proc)
+                   internal-label
+                   entry:compiler-interrupt-procedure)))
+          ((pair? checks)
+           (LAP ,@(label+adjustment)
+                ,@(interrupt-check checks (closure-interrupt-label))))
+          (else
+           (label+adjustment)))))
+
+(define (closure-interrupt-label)
+  (or (block-association 'INTERRUPT-CLOSURE)
+      (let ((label (generate-label 'INTERRUPT-CLOSURE)))
+        (add-end-of-block-code!
+         (lambda ()
+           (LAP (LABEL ,label)
+                ,@(invoke-hook entry:compiler-interrupt-closure))))
+        (block-associate! 'INTERRUPT-CLOSURE label)
+        label)))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+                        (? min) (? max) (? size)))
+  (generate/cons-closure target procedure-label min max size))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+  (case nentries
+    ((0)
+     ;; Allocate a vector, initialized with garbage -- caller must
+     ;; initialize it before we can GC.
+     (let* ((target (standard-target! target))
+            (Free regnum:free-pointer))
+       (LAP ,@(load-tagged-immediate type-code:manifest-vector size target)
+            (STR X ,target ,Free)
+            ,@(register->register-transfer Free target)
+            ,@(add-immediate Free Free
+                             (* address-units-per-object (+ 1 size))))))
+    ((1)
+     (let ((entry (vector-ref entries 0)))
+       (generate/cons-closure target
+                              (car entry) (cadr entry) (caddr entry)
+                              size)))
+    (else
+     (generate/cons-multiclosure target nentries size
+                                 (vector->list entries)))))
+
+(define (generate/cons-closure target label min max size)
+  (let* ((target (standard-target! target))
+         (temp (allocate-temporary-register! 'GENERAL))
+         (manifest-type type-code:closure-manifest)
+         (manifest-size (closure-manifest-size size))
+         (Free Free))
+    (LAP ,@(load-tagged-immediate manifest-type manifest-size temp)
+         (STR X ,temp (POST+ ,Free (& 8)))
+         ,@(generate-closure-entry label min max 1 temp)
+         ;; Free now points at the entry.  Save it in target.
+         ,@(register->register-transfer Free target)
+         ;; Bump Free to point at the last component, one word before
+         ;; the next object.  We do this because we need to set the
+         ;; last component here, but we do not have negative load/store
+         ;; offsets without pre/post-increment.
+         ,@(with-immediate-unsigned-12 (* 8 size)
+             (lambda (addend)
+               (LAP (ADD X ,Free ,Free ,addend))))
+         ;; Set the last component to be the relocation reference point.
+         ,@(affix-type temp type-code:compiled-entry target)
+         (STR X ,temp (POST+ ,Free (& 8))))))
+
+(define (generate/cons-multiclosure target nentries size entries)
+  (let* ((target (standard-target! target))
+         (temp (allocate-temporary-register! 'GENERAL))
+         (manifest-type type-code:closure-manifest)
+         (manifest-size (multiclosure-manifest-size nentries size))
+         ;; 8 for manifest, 8 for padding & format word, 8 for PC offset.
+         (offset0 #x18)
+         (Free regnum:free-pointer))
+    (define (generate-primary-entry entry)
+      (let ((label (car entry)) (min (cadr entry)) (max (caddr entry)))
+        (generate-closure-entry label nentries min max offset0 temp)))
+    (define (generate-subsidiary-entry entry n)
+      (let ((label (car entry))
+            (min (cadr entry))
+            (max (caddr entry))
+            (offset (+ offset0 (* n address-units-per-closure-entry))))
+        (generate-closure-entry label 0 min max offset temp)))
+    (define generate-subsidiary-entries entries
+      (assert (pair? entries))
+      (LAP ,@(generate-subsidiary-entry (car entries))
+           ,@(if (pair? (cdr entries))
+                 (generate-subsidiary-entries (cdr entries))
+                 (LAP))))
+    (LAP ,@(load-tagged-immediate manifest-type manifest-size temp)
+         (STR X ,temp (POST+ ,Free (& 8)))
+         ,@(generate-primary-entry (car entries))
+         ,@(register->register-transfer Free target)
+         ,@(generate-subsidiary-entries (cdr entries))
+         ;; Bump Free to point at the last component, one word before
+         ;; the next object.  We do this because we need to set the
+         ;; last component here, but we do not have negative load/store
+         ;; offsets without pre/post-increment.
+         ,@(with-immediate-unsigned-12 (* 8 size)
+             (lambda (addend)
+               (LAP ADD X ,Free ,Free ,addend)))
+         ;; Set the last component to be the relocation reference point.
+         ,@(affix-type temp type-code:compiled-entry target)
+         (STR X ,temp (POST+ ,Free (& 8))))))
+
+(define (generate-closure-entry label padding min max offset temp)
+  (let* ((label* (rtl-procedure/external-label (label->object label)))
+         (code-word (make-procedure-code-word min max))
+         (Free regnum:free-pointer))
+    ;; Could avoid zeroing the padding if we don't need it, but there's
+    ;; no advantage.
+    (define (padded-word)
+      ;; padding(32) || code-word(16) || offset(16)
+      (case endianness
+        ((BIG)
+         (bitwise-ior (shift-left padding 32)
+                      (bitwise-ior (shift-left code-word 16)
+                                   offset)))
+        ((LITTLE)
+         (bitwise-ior padding
+                      (bitwise-ior (shift-left code-word 32)
+                                   (shift-left offset 48))))
+        (else
+         (error "Unknown endianness:" endianness))))
+    (LAP ,@(load-unsigned-immediate temp (padded-word))
+         (STR X ,temp (POST+ ,Free (& 8)))
+         ;; Set temp := label - 8.
+         (ADR X ,temp (@PCR (- ,label* 8)))
+         ;; Set temp := label - 8 - free = label - (free + 8).
+         (SUB X ,temp ,temp ,Free)
+         ;; Store the PC offset.
+         (STR X ,temp (POST+ ,Free (& 8))))))
+
+(define (closure-manifest-size size)
+  (multiclosure-manifest-size 1 size))
+
+(define (multiclosure-manifest-size nentries size)
+  ;; Each entry occupies two object-sized units.
+  (+ (* 2 nentries)
+     ;; Add one for the relocation reference point.
+     (+ size 1)))
+
+;;;; Entry Header
+
+(define (generate/quotation-header environment-label free-ref-label n-sections)
+  (let ((continuation-label (generate-label /LINKED)))
+    (LAP (LDR X ,r0 ,reg:environment)
+         (ADR X ,r1 (@PCR ,environment-label))
+         (STR X ,r0 ,r1)
+         (ADR X ,regnum:utility-arg0 (@PCR ,*block-label*))
+         (ADR X ,regnum:utility-arg1 (@PCR ,free-ref-label))
+         ,@(load-unsigned-immediate regnum:utility-arg2 n-sections)
+         ,@(invoke-hook/call entry:compiler-link continuation-label)
+         ,@(make-external-label (continuation-code-word #f)
+                                continuation-label))))
+
+;;; XXX Why is this hand-coded assembly and not a C function?
+
+(define (generate/remote-links n-blocks vector-label nsects)
+  (if (zero? n-blocks)
+      (LAP)
+      ...))
+
+(define (generate/constants-block constants references assignments
+                                  uuo-links global-links static-vars)
+  (let ((constant-info
+         (declare-constants 0 (transmogrifly uuo-links)
+           (declare-constants 1 references
+             (declare-constants 2 assignments
+               (declare-constants 3 (transmogrifly global-links)
+                 (declare-constants false
+                     (map (lambda (pair)
+                            (cons false (cdr pair)))
+                          static-vars)
+                   (declare-constants false constants
+                     (cons false (LAP))))))))))
+    (let ((free-ref-label (car constant-info))
+          (constants-code (cdr constant-info))
+          (debugging-information-label (allocate-constant-label))
+          (environment-label (allocate-constant-label))
+          (n-sections
+           (+ (if (null? uuo-links) 0 1)
+              (if (null? references) 0 1)
+              (if (null? assignments) 0 1)
+              (if (null? global-links) 0 1))))
+      (values
+       (LAP ,@constants-code
+            ;; Place holder for the debugging info filename
+            (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+            ;; Place holder for the load time environment if needed
+            (SCHEME-OBJECT ,environment-label
+                           ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+       environment-label
+       free-ref-label
+       n-sections))))
+
+(define (declare-constants tag constants info)
+  (define (inner constants)
+    (if (null? constants)
+        (cdr info)
+        (let ((entry (car constants)))
+          (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry))
+               ,@(inner (cdr constants))))))
+  (if (and tag (not (null? constants)))
+      (let ((label (allocate-constant-label)))
+        (cons label
+              (inner
+               `((,(let ((datum (length constants)))
+                     (if (> datum #xffff)
+                         (error "datum too large" datum))
+                     (+ (* tag #x10000) datum))
+                  . ,label)
+                 ,@constants))))
+      (cons (car info) (inner constants))))
+
+(define (transmogrifly variable.caches-list)
+  (append-map
+   (lambda (variable.caches)
+     (append-map (let ((variable (car variable.caches)))
+                   (lambda (cache)
+                     (let ((frame-size (car cache))
+                           (label (cdr cache)))
+                       ;; Must match UUO_LINK_SIZE in cmpintmd/aarch64.h.
+                       (case endianness
+                         ((BIG)
+                          `((,variable . ,(allocate-constant-label))
+                            (#f . ,label)
+                            (#f . ,(allocate-constant-label))
+                            (,frame-size . ,(allocate-constant-label))))
+                         ((LITTLE)
+                          `((,variable . ,(allocate-constant-label))
+                            (,frame-size . ,label)
+                            (#f . ,(allocate-constant-label))
+                            (#f . ,(allocate-constant-label))))
+                         (else
+                          (error "Unknown endianness:" endianness))))))
+                 (cdr variable.caches)))
+   variable.caches-list))
+
+(define (uuo-link-label-offset)
+  (case endianness
+    ;; On big-endian systems, the label points exactly at the code,
+    ;; aligned on an object boundary.
+    ((BIG) 0)
+    ;; On little-endian systems, the code starts halfway in the middle
+    ;; of the frame size object, clobbering the fixnum tag but leaving
+    ;; the 16-bit value intact.
+    ((LITTLE) 4)
+    (else (error "Unknown endianness:" endianness))))
diff --git a/src/compiler/machines/aarch64/rules4.scm b/src/compiler/machines/aarch64/rules4.scm
new file mode 100644
index 000000000..a7f638637
--- /dev/null
+++ b/src/compiler/machines/aarch64/rules4.scm
@@ -0,0 +1,111 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Interpreter Calls
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+;;;; Variable cache trap handling.
+
+(define-rule statement
+  (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
+  (QUALIFIER (interpreter-call-argument? extension))
+  (define (get-argument value register)
+    (interpreter-call-argument->machine-register! value register))
+  (let ((set-extension (get-argument extension regnum:utility-arg1)))
+    (LAP ,@set-extension
+         ,@(clear-map!)
+         #|
+         ,@(invoke-interface/call
+            (if safe?
+                code:compiler-safe-reference-trap
+                code:compiler-reference-trap)
+            cont)
+         |#
+         ,@(invoke-hook/call
+            (if safe?
+                entry:compiler-safe-reference-trap
+                entry:compiler-reference-trap)
+            cont))))
+
+(define-rule statement
+  (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value))
+  (QUALIFIER (and (interpreter-call-argument? extension)
+                  (interpreter-call-argument? value)))
+  (define (get-argument value register)
+    (interpreter-call-argument->machine-register! value register))
+  (let* ((set-extension (get-argument extension regnum:utility-arg1))
+         (set-value (get-argument extension regnum:utility-arg2)))
+    (LAP ,@set-extension
+         ,@set-value
+         ,@(clear-map!)
+         #|
+         ,@(invoke-interface/call code:compiler-assignment-trap cont)
+         |#
+         ,@(invoke-hook/call entry:compiler-assignment-trap cont))))
+
+(define-rule statement
+  (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
+  (QUALIFIER (interpreter-call-argument? extension))
+  (define (get-argument value register)
+    (interpreter-call-argument->machine-register! value register))
+  (let ((set-extension (get-argument extension regnum:utility-arg1)))
+    (LAP ,@set-extension
+         ,@(clear-map!)
+         ,@(invoke-interface/call code:compiler-unassigned?-trap cont))))
+
+;;; Obsolete interpreter calls, should be flushed.
+
+(define-rule statement
+  (INTERPRETER-CALL:ACCESS (? cont) (? environment) (? name))
+  (error "Unsupported interpreter call:"
+         `(INTERPRETER-CALL:ACCESS ,cont ,environment ,name)))
+
+(define-rule statement
+  (INTERPRETER-CALL:LOOKUP (? cont) (? environment) (? name) (? safe?))
+  (error "Unsupported interpreter call:"
+         `(INTERPRETER-CALL:LOOKUP ,cont ,environment ,name ,safe?)))
+
+(define-rule statement
+  (INTERPRETER-CALL:UNASSIGNED? (? cont) (? environment) (? name))
+  (error "Unsupported interpreter call:"
+         `(INTERPRETER-CALL:UNASSIGNED? ,cont ,environment ,name)))
+
+(define-rule statement
+  (INTERPRETER-CALL:UNBOUND? (? cont) (? environment) (? name))
+  (error "Unsupported interpreter call:"
+         `(INTERPRETER-CALL:UNBOUND? ,cont ,environment ,name)))
+
+(define-rule statement
+  (INTERPRETER-CALL:DEFINE (? cont) (? environment) (? name) (? value))
+  (error "Unsupported interpreter call:"
+         `(INTERPRETER-CALL:DEFINE ,cont ,environment ,name ,value)))
+
+(define-rule statement
+  (INTERPRETER-CALL:SET! (? cont) (? environment) (? name) (? value))
+  (error "Unsupported interpreter call:"
+         `(INTERPRETER-CALL:SET! ,cont ,environment ,name ,value)))
diff --git a/src/compiler/machines/aarch64/rulfix.scm b/src/compiler/machines/aarch64/rulfix.scm
new file mode 100644
index 000000000..d5c7d792d
--- /dev/null
+++ b/src/compiler/machines/aarch64/rulfix.scm
@@ -0,0 +1,269 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; LAP Generation Rules: Fixnum operations.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+  (standard-unary target source object->fixnum))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+  (load-immediate (standard-target! target) (* constant fixnum-1) #t))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+  (standard-unary target source fixnum->object))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+  (standard-unary target source address->fixnum))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
+  (standard-unary target source fixnum->address))
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
+  ;; Works out the same.
+  (standard-unary target source object->fixnum))
+
+(define (object->fixnum target source)
+  (LAP (LSL X ,target ,source (&U ,scheme-type-width))))
+
+(define (fixnum->object target source)
+  (LAP (ORR X ,target ,source (&U ,type-code:fixnum))
+       (ROR X ,target ,target (&U ,scheme-type-width))))
+
+(define (address->fixnum target source)
+  (LAP (LSL X ,target ,source (&U ,scheme-type-width))))
+
+(define (fixnum->address target source)
+  (LAP (LSR X ,target ,source (&U ,scheme-type-width))))
+
+(define (word->fixnum target source)
+  (LAP (AND X ,target ,source (&U ,(- (expt 2 scheme-type-width) 1)))))
+
+;;;; Unary Fixnum Operations
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
+  (standard-unary target source
+    (lambda (target source)
+      ((fixnum-1-arg/operator operator) target source overflow?))))
+
+(define (fixnum-1-arg/operator operator)
+  (lookup-arithmetic-method operator fixnum-methods/1-arg))
+
+(define fixnum-methods/1-arg
+  (list 'FIXNUM-METHODS/1-ARG))
+
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
+  (lambda (target source overflow?)
+    (assert (not overflow?))
+    (LAP (MVN X ,target ,source))))
+
+(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+  (lambda (target source overflow?)
+    (fixnum-add-constant target source +1 overflow?)))
+
+(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+  (lambda (target source overflow?)
+    (fixnum-add-constant target source -1 overflow?)))
+
+(define (set-always-branches!)
+  (set-current-branches! (lambda (label) (LAP (B (@PCR ,label))))
+                         (lambda (label) label (LAP))))
+
+(define (set-never-branches!)
+  (set-current-branches! (lambda (label) label (LAP))
+                         (lambda (label) (LAP (B (@PCR ,label))))))
+
+(define (set-carry-branches!)
+  (set-current-branches! (lambda (label) (LAP (B.CS (@PCR ,label))))
+                         (lambda (label) (LAP (B.CC (@PCR ,label))))))
+
+(define (fixnum-add-constant target source n overflow?)
+  (let ((imm (* fixnum-1 n)))
+    (cond ((not overflow?)
+           (add-immediate target source imm))
+          ((zero? n)
+           (set-never-branches!)
+           (register->register-transfer source target))
+          (else
+           (set-carry-branches!)
+           (add-immediate-with-flags target source imm)))))
+
+(define (load-fixnum-constant target n)
+  (load-signed-immediate target (* n fixnum-1)))
+
+;;;; Binary Fixnum Operations
+
+(define-rule statement
+  (ASSIGN (REGISTER (? target))
+          (FIXNUM-2-ARGS (? operator)
+                         (REGISTER (? source1))
+                         (REGISTER (? source2))
+                         (? overflow?)))
+  (standard-binary target source1 source2
+    (lambda (target source1 source2)
+      ((fixnum-2-args/operator operator) target source1 source2 overflow?))))
+
+(define (fixnum-2-args/operator operator)
+  (lookup-arithmetic-method operator fixnum-methods/2-args))
+
+(define fixnum-methods/2-args
+  (list 'FIXNUM-METHODS/2-ARGS))
+
+(define ((fixnum-2-args/additive flags no-flags)
+         target source1 source2 overflow?)
+  (if overflow?
+      (begin
+        (set-carry-branches!)
+        (LAP (,flags ,target ,source1 ,source2)))
+      (LAP (,no-flags ,target ,source1 ,source2))))
+
+(define ((fixnum-2-args/bitwise op) target source1 source2 overflow?)
+  (assert (not overflow?))
+  (LAP (,op ,target ,source1 ,source2)))
+
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args
+  (fixnum-2-args/additive 'ADDS 'ADD))
+
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args
+  (fixnum-2-args/additive 'SUBS 'SUB))
+
+(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args
+  (fixnum-2-args/bitwise 'AND))
+
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
+  (fixnum-2-args/bitwise 'BIC))         ;Bitwise Bit Clear
+
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args
+  (fixnum-2-args/bitwise 'ORR))
+
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args
+  (fixnum-2-args/bitwise 'EOR))         ;fans of Winnie the Pooh
+
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+  (lambda (target source1 source2 overflow?)
+    ;; We have x 2^t and y 2^t, and we want x y 2^t, so divide one of
+    ;; them first by 2^t.
+    (if (not overflow?)
+        (LAP (ASR ,regnum:scratch-0 ,source1 (&U ,scheme-type-width))
+             (MUL ,target ,regnum:scratch-0 ,source2))
+        (let* ((mask (allocate-temporary-register! 'GENERAL))
+               (hi (allocate-temporary-register! 'GENERAL)))
+          ;; We're going to test whether the high 64-bits is equal to
+          ;; the -1 or 0 we expect it to be.  Overflow if not equal, no
+          ;; overflow if equal.
+          (set-not-equal-branches!)
+          ;; Set mask to -1 if same sign, 0 if different sign.  The
+          ;; mask is equal to the high 64 bits of a non-overflowing
+          ;; multiply, so its xor with the high 64 bits is zero iff no
+          ;; overflow.
+          (LAP (MOVZ X ,mask (&U 0))
+               (CMP X ,source1 (&U 0))
+               (CINV.LT X ,mask ,mask)
+               (CMP X ,source2 (&U 0))
+               (CINV.LT X ,mask ,mask)
+               (ASR X ,regnum:scratch-0 ,source1 (&U ,scheme-type-width))
+               (SMULH ,hi ,regnum:scratch-0 ,source2)
+               (MUL X ,target ,regnum:scratch-0 ,source2)
+               (CMP X ,mask ,hi))))))
+
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+  (lambda (target source1 source2 overflow?)
+    (assert (not overflow?))
+    (if (= source1 source2)             ;XXX Avoid this earlier on.
+        (load-fixnum-constant target 1)
+        (LAP (SDIV X ,target ,source1 ,source2)
+             (LSL X ,target ,target (&U ,scheme-type-width))))))
+
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+  (lambda (target source1 source2 overflow?)
+    (assert (not overflow?))
+    (if (= source1 source2)             ;XXX Avoid this earlier on.
+        (load-fixnum-constant target 0)
+        (LAP (SDIV X ,target ,source1 ,source2)
+             ;; source1 = n, source2 = d, target = q
+             ;; target := n - d*q
+             (MSUB X ,target ,source1 ,source2 ,target)
+             (LSL X ,target ,target (&U ,scheme-type-width))))))
+
+;; XXX Constant operands.
+;; XXX Fast division by multiplication.
+
+;;;; Fixnum Predicates
+
+(define-rule predicate
+  (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
+  (fixnum-branch! (fixnum-predicate/unary->binary predicate))
+  (LAP (CMP X ,(standard-source! register) (& 0))))
+
+(define-rule predicate
+  (FIXNUM-PRED-1-ARG FIXNUM-ZERO? (REGISTER (? register)))
+  (zero-test! (standard-source! register)))
+
+(define-rule predicate
+  (FIXNUM-PRED-2-ARGS (? predicate)
+                      (REGISTER (? source1))
+                      (REGISTER (? source2)))
+  (fixnum-branch! predicate)
+  (standard-unary-effect source1 source2
+    (lambda ()
+      (LAP (CMP X ,source1 ,source2)))))
+
+(define (fixnum-predicate/unary->binary predicate)
+  (case predicate
+    ((ZERO-FIXNUM?) 'EQUAL-FIXNUM?)
+    ((NEGATIVE-FIXNUM?) 'LESS-THAN-FIXNUM?)
+    ((POSITIVE-FIXNUM?) 'GREATER-THAN-FIXNUM?)
+    (else (error "Unknown unary predicate:" predicate))))
+
+(define (fixnum-branch! predicate)
+  (case predicate
+    ((EQUAL-FIXNUM?)
+     (set-equal-branches!))
+    ((LESS-THAN-FIXNUM?)
+     (set-current-branches! (lambda (label) (LAP (B.LT (@PCR ,label))))
+                            (lambda (label) (LAP (B.GE (@PCR ,label))))))
+    ((GREATER-THAN-THAN-FIXNUM?)
+     (set-current-branches! (lambda (label) (LAP (B.GT (@PCR ,label))))
+                            (lambda (label) (LAP (B.LE (@PCR ,label))))))
+    ((UNSIGNED-LESS-THAN-FIXNUM?)
+     (set-current-branches! (lambda (label) (LAP (B.MI (@PCR ,label))))
+                            (lambda (label) (LAP (B.PL (@PCR ,label))))))
+    ((UNSIGNED-LESS-THAN-FIXNUM?)
+     (set-current-branches! (lambda (label) (LAP (B.PL (@PCR ,label))))
+                            (lambda (label) (LAP (B.MI (@PCR ,label))))))
+    (else
+     (error "Unknown fixnum predicate:" predicate))))
diff --git a/src/compiler/machines/aarch64/rulrew.scm b/src/compiler/machines/aarch64/rulrew.scm
new file mode 100644
index 000000000..d8d7a9c6c
--- /dev/null
+++ b/src/compiler/machines/aarch64/rulrew.scm
@@ -0,0 +1,207 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+(define-rule rewriting
+  (CONS-NON-POINTER (? type) (? datum))
+  ;; On aarch64, there's no difference between an address and a datum,
+  ;; so the rules for constructing non-pointer objects are the same as
+  ;; those for pointer objects.
+  (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+  (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+  (QUALIFIER (rtl:machine-constant? type))
+  (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+  (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+  (QUALIFIER
+   (and (rtl:object->type? type)
+        (rtl:constant? (rtl:object->type-expression type))))
+  (rtl:make-cons-pointer
+   (rtl:make-machine-constant
+    (back-end:object-type
+     (rtl:constant-value (rtl:object->type-expression datum))))
+   datum))
+
+(define-rule rewriting
+  (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+  (QUALIFIER (rtl:machine-constant? datum))
+  (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+  (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+  (QUALIFIER
+   (and (rtl:object->datum? datum)
+        (rtl:constant-non-pointer? (rtl:object->datum-expression datum))))
+  (rtl:make-cons-pointer
+   type
+   (rtl:make-machine-constant
+    (back-end:object-datum
+     (rtl:constant-value (rtl:object->datum-expression datum))))))
+
+(define-rule rewriting
+  (OBJECT->TYPE (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:constant? source))
+  (rtl:make-machine-constant
+   (back-end:object-type (rtl:constant-value source))))
+
+(define-rule rewriting
+  (OBJECT->DATUM (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:constant-non-pointer? source))
+  (rtl:make-machine-constant
+   (back-end:object-datum (rtl:constant-value source))))
+
+(define (rtl:constant-non-pointer? expression)
+  (and (rtl:constant? expression)
+       (non-pointer-object? (rtl:constant-value expression))))
+
+;;; These rules are losers because there's no abstract way to cons a
+;;; statement or a predicate without also getting some CFG structure.
+
+(define-rule rewriting
+  (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+  (QUALIFIER (rtl:immediate-zero-constant? comparand))
+  (list 'ASSIGN target comparand))
+
+(define-rule rewriting
+  (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+  (QUALIFIER (rtl:immediate-zero-constant? comparand))
+  (list 'EQ-TEST source comparand))
+
+(define-rule rewriting
+  (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+  (QUALIFIER (rtl:immediate-zero-constant? comparand))
+  (list 'EQ-TEST source comparand))
+
+(define (rtl:immediate-zero-constant? expression)
+  (cond ((rtl:constant? expression)
+         (let ((value (rtl:constant-value expression)))
+           (and (non-pointer-object? value)
+                (zero? (back-end:object-type value))
+                (zero? (back-end:object-datum value)))))
+        ((rtl:cons-pointer? expression)
+         (and (let ((expression (rtl:cons-pointer-type expression)))
+                (and (rtl:machine-constant? expression)
+                     (zero? (rtl:machine-constant-value expression))))
+              (let ((expression (rtl:cons-pointer-datum expression)))
+                (and (rtl:machine-constant? expression)
+                     (zero? (rtl:machine-constant-value expression))))))
+        (else #f)))
+
+;;;; Fixnums
+
+(define-rule rewriting
+  (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:constant-fixnum? source))
+  (rtl:make-object->fixnum source))
+
+(define-rule rewriting
+  (OBJECT->FIXNUM (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:cons-non-pointer? source))
+  (rtl:make-address->fixnum (rtl:cons-non-pointer-datum source)))
+
+(define-rule rewriting
+  (ADDRESS->FIXNUM (REGISTER (? source register-known-value)))
+  (QUALIFIER (rtl:object->datum? source))
+  ;; Pun: ADDRESS->FIXNUM has the same effect as OBJECT->FIXNUM even on
+  ;; tagged objects.  If we ever changed the representation of
+  ;; addresses (which is unlikely -- there's no temptation to disable
+  ;; HEAP_IN_LOW_MEMORY because we have 58 bits for addresses) we would
+  ;; have to change this.
+  (rtl:make-address->fixnum (rtl:object->datum-expression source)))
+
+#|
+;;; Disabled until we have fixnum rules with constant operands.
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+                 (REGISTER (? operand-1 register-known-value))
+                 (? operand-2)
+                 (? overflow?))
+  (QUALIFIER (rtl:constant-fixnum-test operand-1 (lambda (n) n true)))
+  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+                 (? operand-1)
+                 (REGISTER (? operand-2 register-known-value))
+                 (? overflow?))
+  (QUALIFIER
+   (and (rtl:constant-fixnum-test operand-2 (lambda (n) n true))))
+  (rtl:make-fixnum-2-args 'MULTIPLY-FIXNUM operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS (? operator)
+                 (? operand-1)
+                 (REGISTER (? operand-2 register-known-value))
+                 (? overflow?))
+  (QUALIFIER
+   (and (memq operator '(PLUS-FIXNUM MINUS-FIXNUM))
+        (rtl:register? operand-1)
+        (rtl:constant-fixnum-test operand-2 zero?)))
+  (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS (? operator)
+                 (? operand-1)
+                 (REGISTER (? operand-2 register-known-value))
+                 (? overflow?))
+  (QUALIFIER
+   (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER))
+        (rtl:register? operand-1)
+        (rtl:constant-fixnum-test operand-2
+          (lambda (value)
+            (not (zero? value))))))
+  (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
+
+(define-rule rewriting
+  (FIXNUM-2-ARGS FIXNUM-LSH
+                 (? operand-1)
+                 (REGISTER (? operand-2 register-known-value))
+                 #F)
+  (QUALIFIER (and (rtl:register? operand-1)
+                  (rtl:constant-fixnum-test operand-2 (lambda (n) n true))))
+  (rtl:make-fixnum-2-args 'FIXNUM-LSH operand-1 operand-2 #F))
+
+(define (rtl:constant-fixnum? expression)
+  (and (rtl:constant? expression)
+       (fix:fixnum? (rtl:constant-value expression))
+       (rtl:constant-value expression)))
+
+(define (rtl:constant-fixnum-test expression predicate)
+  (and (rtl:object->fixnum? expression)
+       (let ((expression (rtl:object->fixnum-expression expression)))
+         (and (rtl:constant? expression)
+              (let ((n (rtl:constant-value expression)))
+                (and (fix:fixnum? n)
+                     (predicate n)))))))
+|#
diff --git a/src/microcode/cmpintmd/aarch64.c b/src/microcode/cmpintmd/aarch64.c
new file mode 100644
index 000000000..ead2df7c1
--- /dev/null
+++ b/src/microcode/cmpintmd/aarch64.c
@@ -0,0 +1,340 @@
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Compiled code interface for AArch64.  */
+
+#include "cmpint.h"
+
+extern void * tospace_to_newspace (void *);
+extern void * newspace_to_tospace (void *);
+
+bool
+read_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+  return
+    (decode_old_style_format_word (cet, (((const uint16_t *) address) [-6])));
+}
+
+bool
+write_cc_entry_type (cc_entry_type_t * cet, insn_t * address)
+{
+  return (encode_old_style_format_word (cet, (((uint16_t *) address) - 6)));
+}
+
+bool
+read_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+  uint16_t n = (((const uint16_t *) address) [-5]);
+  (ceo->offset) = (n >> 1);
+  (ceo->continued_p) = ((n & 1) != 0);
+  return (false);
+}
+
+bool
+write_cc_entry_offset (cc_entry_offset_t * ceo, insn_t * address)
+{
+  if (! ((ceo->offset) < 0x4000))
+    return (true);
+  (((uint16_t *) address) [-5])
+    = (((ceo->offset) << 1) | ((ceo->continued_p) ? 1 : 0));
+  return (false);
+}
+
+insn_t *
+cc_return_address_to_entry_address (insn_t * pc)
+{
+  insn_t insn = (pc[0]);
+  if ((insn & 0xfc000000UL) == 0x14000000UL) /* B */
+    return (pc + (insn & 0x3fffffff));
+  else
+    /* XXX What if it got branch-tensioned?  */
+    error_external_return ();
+}
+
+/* Compiled closures */
+
+/* start_closure_reloation (scan, ref)
+
+   `scan' points at the manifest of a compiled closure.  Initialize
+   `ref' with whatever we need to relocate the entries in it.  */
+
+void
+start_closure_relocation (SCHEME_OBJECT * scan, reloc_ref_t * ref)
+{
+  /* The last element of the block is always the tagged first entry of
+     the closure, which tells us where the closure was in oldspace.  */
+  (ref->old_addr) = (CC_ENTRY_ADDRESS (* ((CC_BLOCK_ADDR_END (scan)) - 1)));
+  /* Find the address of the first entry in newspace.  */
+  (ref->new_addr)
+    = (tospace_to_newspace
+       (compiled_closure_entry (compiled_closure_start (scan + 1))));
+}
+
+/* read_compiled_closure_target (start, ref)
+
+   `start' points to the start of a closure entry in tospace, beginning
+   with the format word and block offset.  `ref' was initialized with
+   `start_closure_relocation'.  Return the untagged compiled entry
+   address in oldspace that the closure entry points to.  */
+
+insn_t *
+read_compiled_closure_target (insn_t * start, reloc_ref_t * ref)
+{
+  insn_t * addr = (start + CC_ENTRY_HEADER_SIZE);
+  insn_t * base = (tospace_to_newspace (addr));
+  /* If we're relocating, find where base was in the oldspace.  */
+  if (ref)
+    base += (ref->old_addr - ref->new_addr);
+  return (base + (((int64_t *) addr)[-1]));
+}
+
+/* write_compiled_closure_target(target, start)
+
+   `target' is an untagged compiled entry address in newspace.  `start'
+   points to the start of a closure entry in tospace, beginning with
+   the format word and block offset.  Set the closure entry at `start'
+   to go to `target'.  */
+
+void
+write_compiled_closure_target (insn_t * target, insn_t * start)
+{
+  insn_t * addr = (start + CC_ENTRY_HEADER_SIZE);
+  (((int64_t *) addr)[-1]) =
+    (target - ((insn_t *) (tospace_to_newspace (addr))));
+}
+
+unsigned long
+compiled_closure_count (SCHEME_OBJECT * block)
+{
+  /* `block' is a pointer to the first object after the manifest.  The
+     first object following it is the entry count.  */
+  return ((unsigned long) (* ((uint32_t *) block)));
+}
+
+insn_t *
+compiled_closure_start (SCHEME_OBJECT * block)
+{
+  return ((insn_t *) block);
+}
+
+insn_t *
+compiled_closure_entry (insn_t * start)
+{
+  return (start + CC_ENTRY_PADDING_SIZE + CC_ENTRY_HEADER_SIZE);
+}
+
+insn_t *
+compiled_closure_next (insn_t * start)
+{
+  return (start + CC_ENTRY_PADDING_SIZE + CC_ENTRY_HEADER_SIZE);
+}
+
+SCHEME_OBJECT *
+skip_compiled_closure_padding (insn_t * start)
+{
+  return ((SCHEME_OBJECT *) start);
+}
+
+SCHEME_OBJECT
+compiled_closure_entry_to_target (insn_t * entry)
+{
+  return (MAKE_CC_ENTRY (entry + (((int64_t *) entry)[-1])));
+}
+
+/* Execution caches (UUO links)
+
+   An execution cache is a region of memory that lives in the
+   constants section of a compiled-code block.  It is an indirection
+   for calling external procedures that allows the linker to control
+   the calling process without having to find and change all the
+   places in the compiled code that refer to it.
+
+   Prior to linking, the execution cache has two pieces of
+   information: (1) the name of the procedure being called (a symbol),
+   and (2) the number of arguments that will be passed to the
+   procedure.  `saddr' points to the arity at the beginning of the
+   execution cache.  */
+
+SCHEME_OBJECT
+read_uuo_symbol (SCHEME_OBJECT * saddr)
+{
+  return (saddr[0]);
+}
+
+unsigned int
+read_uuo_frame_size (SCHEME_OBJECT * saddr)
+{
+#ifdef WORDS_BIGENDIAN
+  return ((saddr[1]) & 0xffff);
+#else
+  return ((saddr[2]) & 0xffff);
+#endif
+}
+
+insn_t *
+read_uuo_target (SCHEME_OBJECT * saddr)
+{
+  return ((insn_t *) (saddr[0]));
+}
+
+insn_t *
+read_uuo_target_no_reloc (SCHEME_OBJECT * saddr)
+{
+  return (read_uuo_target (saddr));
+}
+
+static void
+write_uuo_insns (const insn_t * target, insn_t * iaddr, int pcrel)
+{
+  /* ldr x0, pc-pcrel */
+  (iaddr[0]) = (0x58000000UL | ((((unsigned) pcrel) & 0x7ffff) << 5));
+
+  /* If the target PC is right after the target offset, then the PC
+     requires no further relocation and we can jump to a fixed address.
+     But if the target is a compiled closure pointing into a block
+     somewhere else, the block may not have been relocated yet and so
+     we don't know where the PC will be in the newspace.  */
+  if ((((const int64_t *) (newspace_to_tospace (target)))[-1]) == 0)
+    {
+      ptrdiff_t offset = (target - (&iaddr[1]));
+      if ((-0x40000 <= offset) && (offset <= 0x3ffff))
+	{
+	  uint32_t immlo = (offset & 3);
+	  uint32_t immhi = ((((uint32_t) offset) & 0x7fffc) >> 2);
+	  /* adr x1, target */
+	  (addr[1]) = (0x10000001UL | (immlo << 29) | (immhi << 5));
+	  /* br x1 */
+	  (addr[2]) = 0xd61f0020UL;
+	}
+      else
+	{
+	  uintptr_t target_page = (((uintptr_t) target) >> 12);
+	  uintptr_t iaddr_page = (((uintptr_t) (&iaddr[1])) >> 12);
+	  ptrdiff_t offset_page = (target_page - iaddr_page);
+	  if ((-0x40000 <= offset_page) && (offset_page <= 0x3ffff))
+	    {
+	      uint32_t immlo = (offset_page & 3);
+	      uint32_t immhi = ((((uint32_t) offset_page) & 0x7fffc) >> 2);
+	      uint32_t imm12 = (((uintptr_t) target) - target_page);
+	      /* adrp x1, target */
+	      (iaddr[1]) = (0x90000001UL | (immlo << 29) | (immhi << 5));
+	      /* add x1, x1, #off */
+	      (iaddr[2]) = (0x91000021UL | (imm12 << 10));
+	      /* br x1 */
+	      (iaddr[3]) = 0xd61f0020UL;
+	    }
+	  else
+	    /* You have too much memory.  */
+	    error_external_return ();
+	}
+    }
+  else
+    {
+      (iaddr[1]) = 0xd1002001UL; /* sub x1, x0, #8 */
+      (iaddr[2]) = 0xf9400021UL; /* ldr x1, [x1] */
+      (iaddr[3]) = 0x8b000021UL; /* add x1, x1, x0 */
+      (iaddr[4]) = 0xd61f0020UL; /* br x1 */
+    }
+}
+
+void
+write_uuo_target (insn_t * target, SCHEME_OBJECT * saddr)
+{
+  insn_t * iaddr;
+  int ioff;
+
+#ifdef WORDS_BIGENDIAN
+  ioff = 2;
+#else
+  ioff = 3;
+#endif
+
+  (saddr[0]) = ((SCHEME_OBJECT) target);
+  iaddr = (((insn_t *) saddr) + ioff);
+  write_uuo_insns (target, iaddr, -ioff);
+}
+
+#define TRAMPOLINE_ENTRY_PADDING_SIZE 1
+#define OBJECTS_PER_TRAMPOLINE_ENTRY 4
+
+unsigned long
+trampoline_entry_size (unsigned long n_entries)
+{
+  return (n_entries * OBJECTS_PER_TRAMPOLINE_ENTRY);
+}
+
+insn_t *
+trampoline_entry_addr (SCHEME_OBJECT * block, unsigned long index)
+{
+  return (((insn_t *) (block + 2 + (index * OBJECTS_PER_TRAMPOLINE_ENTRY)))
+	  + TRAMPOLINE_ENTRY_PADDING_SIZE + CC_ENTRY_HEADER_SIZE);
+}
+
+insn_t *
+trampoline_return_addr (SCHEME_OBJECT * block, unsigned long index)
+{
+  return (trampoline_entry_addr (block, index));
+}
+
+#define REGNUM_REGS_POINTER		19
+#define	REGBLOCK_SCHEME_TO_INTERFACE	0
+
+bool
+store_trampoline_insns (insn_t * entry, uint8_t code)
+{
+  (entry[-2]) = 0;		/* PC offset, first half */
+  (entry[-1]) = 0;		/* PC offset, other half */
+  /* movz x16, #code */
+  (entry[0]) = (0xd2800010UL | (((unsigned) code) << 5));
+  /* adr x1, storage */
+  (entry[1]) = 0x10000061UL;
+  /* ldr x17, [x19, #<scheme_to_interface>] */
+  {
+    unsigned Rn = REGNUM_REGS_POINTER;
+    unsigned imm12 = REGBLOCK_SCHEME_TO_INTERFACE;
+    (entry[2]) = (0xf9400011UL | (imm12 << 10) | (Rn << 5));
+  }
+  /* br x17 */
+  (entry[3]) = 0xd61f0220UL;
+}
+
+#define SETUP_REGISTER(hook) do			\
+{						\
+  Registers[offset++] = ((unsigned long) hook);	\
+  declare_builtin (((unsigned long) hook), #hook);
+} while (0)
+
+void
+aarch64_reset_hook (void)
+{
+  unsigned offset = COMPILER_REGBLOCK_N_FIXED;
+
+  /* Must agree with compiler/machines/aarch64/lapgen.scm.  */
+  SETUP_REGISTER (asm_scheme_to_interface);		/* 0 */
+  ...
+
+  /* XXX Make sure we're mapped write and execute.  (Such is the state...)  */
+}
diff --git a/src/microcode/cmpintmd/aarch64.h b/src/microcode/cmpintmd/aarch64.h
new file mode 100644
index 000000000..bf1046890
--- /dev/null
+++ b/src/microcode/cmpintmd/aarch64.h
@@ -0,0 +1,243 @@
+/* -*-C-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+    2017, 2018, 2019 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+*/
+
+/* Compiled code interface macros for AArch64.  */
+
+#ifndef SCM_CMPINTMD_H_INCLUDED
+#define SCM_CMPINTMD_H_INCLUDED 1
+
+/*
+
+- Execute cache, little-endian:
+
+	(before linking)
+	0x00	8 [symbol: <name>]
+	0x08	8 [fixnum: <frame size>]
+	0x10	16 (padding)
+	0x20 end
+
+	(after linking, pointing to near open procedure)
+target	0x00	8 <entry address>
+	0x08	4 <frame size>
+uuo	0x0c	4 ldr x0, target		; Load entry address.
+	0x10	4 adr x1, target_pc		; Load PC-relative address.
+	0x14	4 br x1
+	0x18	8 (padding)
+	0x20
+
+	(after linking, pointing to far open procedure)
+target	0x00	8 <entry address>
+	0x08	4 <frame size>
+uuo	0x0c	4 ldr x0, target		; Load entry address.
+	0x10	4 adrp x1, target_pc		; Load PC-relative page addr.
+	0x14	4 add x1, x1, #page_offset	: Add page offset.
+	0x18	4 br x1
+	0x1c	4 (padding)
+	0x20
+
+	(after linking, pointing to closure)
+target	0x00	8 <entry address>
+	0x08	4 <frame size>
+uuo	0x0c	4 ldr x0, target		; Load entry address.
+	0x10	4 sub x1, x0, #8		; Get address of PC offset.
+	0x14	4 ldr x1, [x1]			; Load PC offset.
+	0x18	4 add x1, x1, x0		; Compute PC = entry + offset.
+	0x1c	4 br x1
+	0x20
+
+- Execute cache, big-endian:
+
+	(before linking)
+	0x00	8 [symbol: <name>]
+	0x08	16 (padding)
+	0x18	8 [fixnum: <frame size>]
+	0x20
+
+	(after linking, pointing to near open procedure)
+target	0x00	8 <entry address>
+uuo	0x08	4 ldr x0, target		; Load entry address.
+	0x0c	4 adr x1, target_pc		; Load PC-relative address.
+	0x10	4 br x1
+	0x14	8 (padding)
+	0x1c	4 <frame size>
+	0x20
+
+	(after linking, pointing to far open procedure)
+target	0x00	8 <entry address>
+uuo	0x08	4 ldr x0, target		; Load entry address.
+	0x0c	4 adrp x1, target_pc		; Load PC-relative page addr.
+	0x10	4 add x1, x1, #page_offset	; Add page offset.
+	0x14	4 br x1
+	0x18	4 (padding)
+	0x1c	4 <frame size>
+	0x20
+
+	(after linking, pointing to closure)
+target	0x00	8 <entry address>
+uuo	0x08	4 ldr x0, target		; Load entry address.
+	0x0c	4 sub x1, x0, #8		; Get address of PC offset.
+	0x10	4 ldr x1, [x1]			; Load PC offset.
+	0x14	4 add x1, x1, x0		; Compute PC = entry + offset.
+	0x18	4 br x1
+	0x1c	4 <frame size>
+	0x20
+
+- Closure format:
+
+start	0x00	8 [manifest-closure: <nwords>]
+	0x08	4 <entry count>
+	0x0c	2 <type/arity for entry0>
+	0x0e	2 <block offset for entry0: 2*(entry0 - start)>
+	0x10	8 <PC offset for entry0: pc0 - entry0>
+entry0	0x18	4 (padding)
+	0x1c	2 <type/arity for entry1>
+	0x1e	2 <block offset for entry1: 2*(entry1 - start)>
+	0x20	8 <PC offset for entry1: pc1 - entry1>
+entry1	0x28	4 (padding)
+	0x2c	2 <type/arity for entry2>
+	0x2e	2 <block offset for entry2: 2*(entry2 - start)>
+	0x30	8 <PC offset for entry2: pc2 - entry2>
+entry2
+slots	0x38	8 [tag: first object]
+	0x40	8 [tag: second object]
+	...
+
+  Note the block offsets are all multiplied by two.  The low bit
+  specifies whether the offset is from the start of the block, or from
+  another offset, which is relevant to large compiled blocks but not
+  relevant to closures unless you use gargantuan multiclosures, and we
+  don't even generate multiclosures, so.
+
+- Trampoline encoding:
+
+	-0x10	4 (padding)
+	-0x0c	2 <type/arity info>
+	-0x0a	2 <block offset>
+	-0x08	8 <PC offset = 0>		00 00 00 00 00 00 00 00
+entry	0x00	4 movz x16, #<code>		; Set utility number.
+	0x04	4 adr x1, storage		; Set x1 to storage pointer.
+	0x08	4 ldr x17, [x19, #<scheme_to_interface>]
+	0x0c	4 br x17
+storage	0x10	8 [tag: first trampoline datum]
+	0x18	8 [tag: second trampoline datum]
+	...
+
+*/
+
+#define ASM_RESET_HOOK aarch64_reset_hook
+
+void aarch64_reset_hook (void);
+
+#define CMPINT_USE_STRUCS 1
+
+/* Must agree with cmpauxmd/aarch64.s.  */
+#define COMPILER_REGBLOCK_N_FIXED ...
+#define COMPILER_TEMP_SIZE 1 /* size in objects of largest RTL registers */
+#define COMPILER_REGBLOCK_N_TEMPS 256
+#define COMPILER_REGBLOCK_N_HOOKS ...
+#define COMPILER_HOOK_SIZE 1
+
+#define COMPILER_REGBLOCK_EXTRA_SIZE ...
+
+/* All aarch64 instructions are 32-bit-aligned.  */
+typedef uint32_t insn_t;
+
+/* Number of insn_t units for padding before entry.  */
+#define CC_ENTRY_PADDING_SIZE 1
+
+/* Number of insn_t units for type/arity, block offset, and PC offset.  */
+#define CC_ENTRY_HEADER_SIZE 3
+
+/* Use of this struct no doubt constitutes a strict-aliasing violation,
+   but it is a well-known fact that if you write a comment about the
+   undefined behaviour you're invoking, the C compiler is obligated to
+   do what you meant.  */
+struct cc_entry
+{
+  uint32_t padding;
+  uint16_t type_arity;
+  uint16_t block_offset;
+  int64_t pc_offset;
+};
+
+/* We don't put GC trap code before an entry any more.  */
+#define CC_ENTRY_GC_TRAP_SIZE 0
+
+/* A compiled entry address points to _after_ the PC offset that, when
+   added to the entry address, gives the address of instructions for
+   the CPU to execute.
+
+   XXX This is suboptimal because aarch64 does not have immediate
+   negative load offsets, but putting the offset after the label causes
+   other annoying issues.  */
+
+#define CC_ENTRY_ADDRESS_PTR(e)		(e)
+#define CC_ENTRY_ADDRESS_PC(e)		((e) + (((const int64_t *) (e))[-1]))
+
+/* A compiled return address points to a jump instruction that jumps to
+   the continuation's body.  */
+
+#define CC_RETURN_ADDRESS_PTR(r)	(r)
+#define CC_RETURN_ADDRESS_PC(r)		((insn_t *) interface_to_scheme_return)
+
+insn_t * cc_return_address_to_entry_address (insn_t *);
+
+#define CC_RETURN_ADDRESS_TO_ENTRY_ADDRESS cc_return_address_to_entry_address
+
+#define EMBEDDED_CLOSURE_ADDRS_P 1
+
+typedef struct
+{
+  insn_t * old_addr;
+  insn_t * new_addr;
+} reloc_ref_t;
+
+#define DECLARE_RELOCATION_REFERENCE(name) reloc_ref_t name
+
+#define START_CLOSURE_RELOCATION(scan, ref)				\
+  start_closure_relocation ((scan), (&ref))
+
+#define START_OPERATOR_RELOCATION(scan, ref)	do {(void)ref;} while (0)
+
+#define OPERATOR_RELOCATION_OFFSET 0
+
+#define READ_COMPILED_CLOSURE_TARGET(a, r)				\
+  read_compiled_closure_target ((a), (&r))
+
+void start_closure_relocation (SCHEME_OBJECT *, reloc_ref_t *);
+insn_t * read_compiled_closure_target (insn_t *, reloc_ref_t *);
+
+/* Number of objects in an execute cache.  Must match aarch64/rules3.scm.  */
+#define UUO_LINK_SIZE 4
+
+#define UUO_WORDS_TO_COUNT(nw) ((nw) / UUO_LINK_SIZE)
+#define UUO_COUNT_TO_WORDS(nc) ((nc) * UUO_LINK_SIZE)
+
+#define READ_UUO_TARGET(a, r) read_uuo_target (a)
+
+insn_t * read_uuo_target (SCHEME_OBJECT *);
+
+#endif /* SCM_CMPINTMD_H_INCLUDED */
-- 
2.25.1