From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 13 Jan 2019 22:52:06 +0000 (+0000)
Subject: Fill in some more files, add some build goo, fix some bugs.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~66^2~95
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=79cdea461a6a0d12f050f77f712e98f0fc738ede;p=mit-scheme.git

Fill in some more files, add some build goo, fix some bugs.

Invent a way to do assembler macros so we can do legible branch
tensioning rules and reuse ADRP/ADD patterns.
---

diff --git a/src/compiler/choose-machine.sh b/src/compiler/choose-machine.sh
index 48947f6d8..61bf6f3c4 100755
--- a/src/compiler/choose-machine.sh
+++ b/src/compiler/choose-machine.sh
@@ -43,6 +43,12 @@ svm1-32be|svm1-32le|svm1-64be|svm1-64le)
     exit 0
 esac
 
+case ${TARGET_ARCH} in
+aarch64be|aarch64le)
+    echo aarch64
+    exit 0
+esac
+
 if test -d "${HERE}/machines/${TARGET_ARCH}"; then
     echo "${TARGET_ARCH}"
     exit 0
diff --git a/src/compiler/configure b/src/compiler/configure
index bf04e0cd8..640274e38 100755
--- a/src/compiler/configure
+++ b/src/compiler/configure
@@ -67,10 +67,10 @@ svm1-64be|svm1-64le)
 esac
 
 case ${TARGET_ARCH} in
-svm1-32be|svm1-64be)
+svm1-32be|svm1-64be|aarch64be)
     ln -sf big-endian.scm machine/endian.scm
     ;;
-svm1-32le|svm1-64le)
+svm1-32le|svm1-64le|aarch64le)
     ln -sf little-endian.scm machine/endian.scm
     ;;
 esac
diff --git a/src/compiler/machines/aarch64/TODO b/src/compiler/machines/aarch64/TODO
index 08af65f71..4553b6e04 100644
--- a/src/compiler/machines/aarch64/TODO
+++ b/src/compiler/machines/aarch64/TODO
@@ -1,8 +1,5 @@
 - Make it work.
-  [ ] assmd
   [ ] cmpauxmd
-  [ ] coerce
-  [ ] insmac
   [ ] instr: branch tensioning, review it all, simd, float
   [ ] insutl
   [ ] logical immediate encoding
diff --git a/src/compiler/machines/aarch64/assmd.scm b/src/compiler/machines/aarch64/assmd.scm
new file mode 100644
index 000000000..aedb36042
--- /dev/null
+++ b/src/compiler/machines/aarch64/assmd.scm
@@ -0,0 +1,78 @@
+#| -*-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.
+
+|#
+
+;;;; Assembler Machine Dependencies.  AArch64 version
+
+(declare (usual-integrations))
+
+(define-integrable maximum-padding-length
+  ;; Instruction length is always a multiple of 32 bits
+  32)
+
+(define-integrable padding-string
+  ;; Pad with HLT #0 instructions
+  (unsigned-integer->bit-string 32 #xd4400000))
+
+(define-integrable block-offset-width
+  ;; Block offsets are always 16 bit words
+  16)
+
+(define-integrable maximum-block-offset
+  ;; PC always aligned on 32-bit boundary
+  (- (expt 2 (1+ block-offset-width)) 4))
+
+(define-integrable (block-offset->bit-string offset start?)
+  (unsigned-integer->bit-string block-offset-width
+                                (+ (* 2 offset)
+                                   (if start? 0 1))))
+
+;;; Machine dependent instruction order
+
+(define (instruction-initial-position block)
+  (case endianness
+    ((BIG) (bit-string-length block))
+    ((LITTLE) 0)
+    (else (error "Unknown endianness:" endianness))))
+
+(define (instruction-insert! bits block position receiver)
+  (let ((l (bit-string-length bits)))
+    (case endianness
+      ((BIG)
+       (let ((new-position (- position l)))
+         (bit-substring-move-right! bits 0 l block new-position)
+         (receiver new-position)))
+      ((LITTLE)
+       (let ((new-position (+ position l)))
+         (bit-substring-move-right! bits 0 l block position)
+         (receiver new-position)))
+      (else
+       (error "Unknown endianness:" endianness)))))
+
+(define (instruction-append x y)
+  (case endianness
+    ((BIG) (bit-string-append-reversed x y))
+    ((LITTLE) (bit-string-append x y))
+    (else (error "Unknown endianness:" endianness))))
diff --git a/src/compiler/machines/aarch64/order-be.scm b/src/compiler/machines/aarch64/big-endian.scm
similarity index 100%
rename from src/compiler/machines/aarch64/order-be.scm
rename to src/compiler/machines/aarch64/big-endian.scm
diff --git a/src/compiler/machines/aarch64/coerce.scm b/src/compiler/machines/aarch64/coerce.scm
new file mode 100644
index 000000000..399641f53
--- /dev/null
+++ b/src/compiler/machines/aarch64/coerce.scm
@@ -0,0 +1,57 @@
+#| -*-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.
+
+|#
+
+;;;; AArch64 Specific Coercions
+
+(declare (usual-integrations))
+
+(define make-coercion
+  (coercion-maker
+   `((UNSIGNED . ,coerce-unsigned-integer)
+     (SIGNED . ,coerce-signed-integer))))
+
+(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
+(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
+(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
+(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
+(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
+(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
+(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7))
+(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
+
+(define coerce-12-bit-unsigned (make-coercion 'UNSIGNED 12))
+(define coerce-14-bit-unsigned (make-coercion 'UNSIGNED 14))
+(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
+(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
+(define coerce-64-bit-unsigned (make-coercion 'UNSIGNED 64))
+
+(define coerce-7-bit-signed (make-coercion 'SIGNED 7))
+(define coerce-9-bit-signed (make-coercion 'SIGNED 9))
+
+(define coerce-19-bit-signed (make-coercion 'SIGNED 19))
+(define coerce-26-bit-signed (make-coercion 'SIGNED 26))
+(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
+(define coerce-64-bit-signed (make-coercion 'SIGNED 64))
diff --git a/src/compiler/machines/aarch64/compiler.pkg b/src/compiler/machines/aarch64/compiler.pkg
index 52a7ad963..c5bffcdc2 100644
--- a/src/compiler/machines/aarch64/compiler.pkg
+++ b/src/compiler/machines/aarch64/compiler.pkg
@@ -36,6 +36,8 @@ USA.
          "base/sets"                    ;set abstraction
          "base/mvalue"                  ;multiple-value support
          "base/scode"                   ;SCode abstraction
+         "rtlbase/valclass"             ;RTL: value classes
+         "machines/aarch64/endian"      ;byte order
          "machines/aarch64/machine"     ;machine dependent stuff
          "back/asutl"                   ;back-end odds and ends
          "base/utils"                   ;odds and ends
@@ -63,7 +65,6 @@ USA.
          "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
          )
@@ -766,6 +767,7 @@ USA.
   (export (compiler top-level)
           assemble))
 
+#;
 (define-package (compiler disassembler)
   (files "machines/aarch64/dassm1"
          "machines/aarch64/dassm2"
diff --git a/src/compiler/machines/aarch64/compiler.sf b/src/compiler/machines/aarch64/compiler.sf
index 74b77c285..f5bf8f0f9 100644
--- a/src/compiler/machines/aarch64/compiler.sf
+++ b/src/compiler/machines/aarch64/compiler.sf
@@ -67,6 +67,8 @@ USA.
 	((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 '("rtlbase/valclass") '(compiler))
+      (sf-and-load '("machines/aarch64/endian") '(compiler))
       (sf-and-load '("machines/aarch64/machine") '(compiler))
       (fluid-let ((sf/default-declarations
 		   '((integrate-external "insseq")
diff --git a/src/compiler/machines/aarch64/decls.scm b/src/compiler/machines/aarch64/decls.scm
index 66ace9402..d92feb2a7 100644
--- a/src/compiler/machines/aarch64/decls.scm
+++ b/src/compiler/machines/aarch64/decls.scm
@@ -343,7 +343,8 @@ USA.
                               "lapgn1" "lapgn2" "lapgn3" "linear" "regmap"
                               "symtab" "syntax")
              (filename/append "machines/aarch64"
-                              "dassm1" "insmac" "lapopt" "machine" "rgspcm"
+                              #;"dassm1"
+                              "insmac" "lapopt" "machine" "rgspcm"
                               "rulrew")
              (filename/append "fggen"
                               "declar" "fggen" "canon")
diff --git a/src/compiler/machines/aarch64/endian.scm b/src/compiler/machines/aarch64/endian.scm
new file mode 120000
index 000000000..df05313d1
--- /dev/null
+++ b/src/compiler/machines/aarch64/endian.scm
@@ -0,0 +1 @@
+little-endian.scm
\ No newline at end of file
diff --git a/src/compiler/machines/aarch64/insmac.scm b/src/compiler/machines/aarch64/insmac.scm
new file mode 100644
index 000000000..3c3de986f
--- /dev/null
+++ b/src/compiler/machines/aarch64/insmac.scm
@@ -0,0 +1,116 @@
+#| -*-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.
+
+|#
+
+;;;; AArch64 Instruction Set Macros
+
+(declare (usual-integrations))
+
+(define (parse-instruction form forms early? environment)
+  (assert (not early?))
+  (receive (expansion bits) (process* form forms environment)
+    bits
+    expansion))
+
+(define (process* form forms environment)
+  (let recur ((form form) (forms forms))
+    (receive (expansion bits) (process form environment)
+      (if (pair? forms)
+          (receive (tail bits*) (recur (car forms) (cdr forms))
+            (values `(,(close-syntax 'APPEND environment) ,expansion ,tail)
+                    (+ bits bits*)))
+          (values expansion bits)))))
+
+(define (process form environment)
+  (if (not (pair? form))
+      (error "Invalid instruction syntax:" form))
+  (case (car form)
+    ((IF) (process-if form environment))
+    ((BITS) (process-fixed form environment))
+    ((VARIABLE-WIDTH) (process-variable form environment))
+    ((MACRO) (process-macro form environment))
+    (else (error "Unknown instruction syntax:" form))))
+
+(define (process-if form environment)
+  (let ((condition (cadr form))
+        (consequent (caddr form))
+        (alternative (cadddr form)))
+    (receive (con-exp con-bits) (process consequent environment)
+      (receive (alt-exp alt-bits) (process alternative environment)
+        (assert (eqv? con-bits alt-bits))
+        (values `(,(close-syntax 'IF environment) ,condition ,con-exp ,alt-exp)
+                con-bits)))))
+
+(define (process-fixed form environment)
+  (receive (expansion bits) (expand-fields (cdr form) environment)
+    (values (optimize-group-syntax expansion #f environment) bits)))
+
+(define (process-variable form environment)
+  (let ((variable (cadr form))
+        (expression (caddr form))
+        (clauses (cdddr form)))
+    (let ((options (map (process-variable-clause environment) clauses)))
+      (let ((expression
+             (variable-width-expression-syntaxer variable
+                                                 expression
+                                                 environment
+                                                 options)))
+        (values expression #f)))))
+
+(define ((process-variable-clause environment) clause)
+  (let ((range (car clause))
+        (forms (cdr clause)))
+    (receive (expansion bits) (process* (car forms) (cdr forms) environment)
+      (assert bits "Variable within variable prohibited!")
+      (assert (zero? (remainder bits 32)) "Wrong number of bits!")
+      `(,expansion ,bits ,range))))
+
+(define (process-macro form environment)
+  (let ((width (cadr form))
+        (expansion (caddr form)))
+    (values ;; XXX Check the width here.  Check for cycles.
+            `((,(close-syntax 'INSTRUCTION-LOOKUP environment)
+               (,(close-syntax 'QUASIQUOTE environment)
+                ,expansion)))
+            width)))
+
+(define (expand-fields fields environment)
+  (let loop ((fields fields) (elements '()) (bits 0))
+    (if (pair? fields)
+        (receive (element1 bits1) (expand-field (car fields) environment)
+          (loop (cdr fields) (cons element1 elements) (+ bits1 bits)))
+        (values (reverse! elements) bits))))
+
+(define (expand-field field environment)
+  (let ((bits (car field))
+        (expression (cadr field))
+        (coercion (if (pair? (cddr field)) (caddr field) 'UNSIGNED)))
+    (values
+     (case coercion
+       ((BLOCK-OFFSET)
+        `(,(close-syntax 'LIST environment) 'BLOCK-OFFSET ,expression))
+       (else
+        (integer-syntaxer expression environment coercion bits)))
+     bits)))
diff --git a/src/compiler/machines/aarch64/instr.scm b/src/compiler/machines/aarch64/instr1.scm
similarity index 52%
rename from src/compiler/machines/aarch64/instr.scm
rename to src/compiler/machines/aarch64/instr1.scm
index d4b328495..ac30505f6 100644
--- a/src/compiler/machines/aarch64/instr.scm
+++ b/src/compiler/machines/aarch64/instr1.scm
@@ -24,137 +24,33 @@ USA.
 
 |#
 
-;;;; AArch Instruction Set
+;;;; AArch64 Instruction Set, part 1
 ;;; 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:
+;;; XXX 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)))
+(define-instruction EXTERNAL-LABEL
+  (((? type/arity) (? label))
+   (if (eq? endianness 'BIG)
+       (BITS (16 label BLOCK-OFFSET)
+             (16 type/arity))
+       (BITS (16 type/arity)
+             (16 label BLOCK-OFFSET)))))
+
+(define-instruction DATA
+  ((32 S (? value))
+   (BITS (32 value SIGNED)))
+  ((32 U (? value))
+   (BITS (32 value UNSIGNED)))
+  ((64 S (? value))
+   (BITS (64 value SIGNED)))
+  ((64 U (? value))
+   (BITS (64 value UNSIGNED))))
 
 ;;;; Instructions, ordered by sections in ARMv8-A ARM, C3
 
@@ -162,19 +58,49 @@ USA.
 
 (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))))))))
+      (sc-macro-transformer
+       (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
+              (((@PCO (? offset)))
+               (BITS (7 #b0101010)
+                     (1 ,o1)
+                     (19 offset SIGNED)
+                     (1 ,o0)
+                     (4 ,condition)))
+              (((@PCR (? target) (? temp register<31)))
+               (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4)
+                 ;; If it fits in a signed 19-bit displacement, great.
+                 ((#x-40000 #x3ffff)
+                  (MACRO 32 (,mnemonic (@PCO ,',offset))))
+                 ;; If not, we have to use ADRP and ADD with a
+                 ;; temporary register.  Preserve forward or backward
+                 ;; branches to preserve static branch predictions.
+                 ;; The PC relative to which we compute the target
+                 ;; address is marked with (*) to explain the curious
+                 ;; bounds.
+                 ((0 #x100000001)
+                  ;; Forward branch.
+                  (MACRO 32 (,mnemonic (@PCO 2))) ;1f
+                  (MACRO 32 (B (@PCO 4)))         ;2f
+                  ;; 1:
+                  (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*)
+                  (MACRO 32 (BR ,',temp))
+                  ;; 2:
+                  )
+                 ((#x-fffffffe -1)
+                  ;; Backward branch.
+                  (MACRO 32 (B (@PCO 4))) ;1f
+                  ;; 2:
+                  (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*)
+                  (MACRO 32 (BR ,',temp))
+                  ;; 1:
+                  (MACRO 32 (,mnemonic (@PCO -3))) ;2b
+                  )))))))))
   ;; PSTATE condition bits:
   ;; .n = negative
   ;; .z = zero
@@ -202,7 +128,7 @@ USA.
   (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
@@ -210,17 +136,39 @@ USA.
          environment
          (receive (mnemonic op) (apply values (cdr form))
            `(define-instruction ,mnemonic
-              (((? sf sf-size) (? Rt register-31=z) (@PCR (? label)))
+              (((? sf sf-size) (? Rt register-31=z) (@PCO (? offset)))
                (BITS (1 sf)
                      (6 #b011010)
                      (1 ,op)
-                     (19 `(QUOTIENT (- ,label *PC*) 4) SIGNED)
-                     (5 Rt)))))))))
+                     (19 offset SIGNED)
+                     (5 Rt)))
+              (((? sf) (? Rt) (@PCR (? target) (? temp register<31)))
+               (VARIABLE-WIDTH offset `(/ (- ,target *PC*) 4)
+                 ((#x-40000 #x3ffff)
+                  (MACRO 32 (,mnemonic (@PCO ,',offset))))
+                 ((0 #x100000001)
+                  ;; Forward branch.
+                  (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO 2))) ;1f
+                  (MACRO 32 (B (@PCO 4))) ;2f
+                  ;; 1:
+                  (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*)
+                  (MACRO 32 (BR ,',temp))
+                  ;; 2:
+                  )
+                 ((#x-fffffffe -1)
+                  ;; Backward branch.
+                  (MACRO 32 (B (@PCO 4))) ;1f
+                  ;; 2:
+                  (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*)
+                  (MACRO 32 (BR ,',temp))
+                  ;; 1:
+                  (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO -3))) ;2b
+                  )))))))))
   ;; 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
@@ -230,46 +178,84 @@ USA.
            `(define-instruction ,mnemonic
               ((W (? Rt register-31=z)
                   (&U (? bit unsigned-5))
-                  (@PCR (? label)))
+                  (@PCO (? offset)))
                (BITS (1 0)              ;b5, fifth bit of bit index
                      (6 #b011011)
                      (1 ,op)
                      (5 bit)
-                     (14 `(- ,label *PC*))
+                     (14 offset)
                      (5 Rt)))
               ((X (? Rt register-31=z)
                   (&U (? bit unsigned-6))
-                  (@PCR (? label)))
-               (BITS (1 bit B5)
+                  (@PCO (? offset)))
+               (BITS (1 (shift-right bit 5))
                      (6 #b011011)
-                     (5 bit B40)
-                     (14 `(- ,label *PC*))
-                     (5 Rt)))))))))
+                     (5 (bitwise-and bit #b1111))
+                     (14 offset)
+                     (5 Rt)))
+              (((? sf)
+                (? Rt)
+                (&U (? bit))
+                (@PCR (? target) (? temp register<31)))
+               (VARIABLE-WIDTH offset (/ `(- ,target *PC*) 4)
+                 ((#x-2000 #x1fff)
+                  (MACRO 32
+                         (,mnemonic ,',sf ,',Rt (&U ,',bit) (@PCO ,',offset))))
+                 ((0 #x100000001)
+                  ;; Forward branch.
+                  (MACRO 32 (,mnemonic ,',sf ,',Rt (&U ,',bit) (@PCO 2))) ;1f
+                  (MACRO 32 (B (@PCO 4))) ;2f
+                  ;; 1:
+                  (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*)
+                  (MACRO 32 (BR ,',temp))
+                  ;; 2:
+                  )
+                 ((#x-fffffffe -1)
+                  ;; Backward branch.
+                  (MACRO 32 (B (@PCO 4))) ;1f
+                  ;; 2:
+                  (MACRO 64 (ADRP-ADD X ,',temp (@PCO ,',(- offset 2)))) ;(*)
+                  (MACRO 32 (BR ,',temp))
+                  ;; 1:
+                  (MACRO 32 (,mnemonic ,',sf ,',Rt (@PCO -3))) ;2b
+                  )))))))))
   ;; 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.
+;; Branch unconditional to PC-relative.
 
 (define-instruction B
-  (((@PCR (? label)))
+  (((@PCO (? offset)))
    (BITS (1 0)                          ;no link
          (5 #b00101)
-         (26 `(- ,label *PC*) SIGNED))))
+         (26 offset SIGNED)))
+  (((@PCR (? target) (? temp register<31)))
+   (VARIABLE-WIDTH offset (/ `(- ,target *PC*) 4)
+     ((#x-2000000 #x1ffffff)
+      (MACRO 32 (B (@PCO ,offset))))
+     ((#x-100000000 #xffffffff)
+      (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*)
+      (MACRO 32 (BR ,temp))))))
 
 ;; Branch and link unconditional to PC-relative
 
 (define-instruction BL
-  (((@PCR (? label)))
+  (((@PCO (? offset)))
    (BITS (1 1)                          ;link
          (5 #b00101)
-         (26 `(- ,label *PC*) SIGNED))))
-
+         (26 offset SIGNED)))
+  (((@PCR (? target) (? temp register<31)))
+   (VARIABLE-WIDTH offset (/ `(- ,target *PC*) 4)
+     ((#x-2000000 #x1ffffff)
+      (MACRO 32 (BL (@PCO ,offset))))
+     ((#x-100000000 #xffffffff)
+      (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*)
+      (MACRO 32 (BLR ,temp))))))
+
 ;;; C.3.1.3 Unconditional branch (register)
 
 ;; Unconditional branch to register
@@ -320,7 +306,7 @@ USA.
          (1 0)                          ;M
          (5 Rn)
          (5 0))))
-
+
 ;;; C3.1.4 Exception generation and return
 
 (let-syntax
@@ -363,7 +349,7 @@ USA.
          (1 0)                          ;M
          (5 31)                         ;Rn
          (5 0))))                       ;op4
-
+
 ;;; C3.1.5 System register instructions
 
 ;; Move to special register
@@ -383,7 +369,7 @@ USA.
   )
 
 ;; XXX MRS
-
+
 ;;; C3.1.6 System instructions
 
 ;; XXX SYS, SYSL, IC, DC, AT, TLBI
@@ -459,25 +445,9 @@ USA.
          (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)
@@ -505,11 +475,6 @@ USA.
          (3 #b010)                      ;op2
          (5 31))))
 
-(define (isb-option o)
-  (case o
-    ((SY) #b1111)
-    (else #f)))
-
 (define-instruction ISB
   (()
    (BITS (8 #b11010101)
@@ -532,25 +497,9 @@ USA.
          (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)
@@ -577,7 +526,7 @@ USA.
          (4 #b0000)
          (3 #b100)                      ;op2
          (5 31))))
-
+
 ;;; C3.1.9 Pointer authentication instructions
 
 ;; XXX pointer authentication instructions
@@ -629,6 +578,7 @@ USA.
                      (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)
@@ -695,6 +645,7 @@ USA.
                      (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
@@ -756,6 +707,7 @@ USA.
                      (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)
@@ -800,14 +752,24 @@ USA.
   (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)))
+    (((? opc ldr-literal-size) (? Rt register-31=z) (@PCO (? offset)))
      (BITS (2 opc)
            (3 #b011)
            (1 0)                        ;general
            (2 #b00)
-           (19 `(QUOTIENT (- ,label *PC*) 4))
-           (5 Rt)))))
-
+           (19 offset SIGNED)
+           (5 Rt)))
+    (((? size) (? Rt) (@PCR (? label) (? temp register<31)))
+     (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4)
+       ((#x-40000 #x3ffff)
+        (MACRO 32 (LDR ,size ,Rt (@PCO ,offset))))
+       ((#x-100000000 #xffffffff)
+        ;; Could maybe use ADRP and LDR with unsigned 8-byte offset,
+        ;; but only if the offset is even because this instruction is
+        ;; aligned, wich the assembler can't handle easily.
+        (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*)
+        (MACRO 32 (LDR X ,Rt ,temp)))))))
+
 ;;; C3.2.9 Load/Store scalar SIMD and floating-point
 
 (let-syntax
@@ -880,6 +842,7 @@ USA.
                      (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)
@@ -936,6 +899,7 @@ USA.
                      (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)
@@ -1013,6 +977,7 @@ USA.
                      (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)
@@ -1061,14 +1026,21 @@ USA.
   (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)))
+    (((? opc ldr-literal-simd/fp-size) (? Vt vregister) (@PCO (? offset)))
      (BITS (2 opc)
            (3 #b011)
            (1 1)                        ;SIMD/FP
            (2 #b00)
-           (19 `(QUOTIENT (- ,label *PC*) 4))
-           (5 Vt)))))
-
+           (19 offset SIGNED)
+           (5 Vt)))
+    (((? size) (? Vt) (@PCR (? label) (? temp register<31)))
+     (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4)
+       ((#x-40000 #x3ffff)
+        (MACRO 32 (LDR.V ,size ,Vt (@PCO ,offset))))
+       ((#x-100000000 #xffffffff)
+        (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*)
+        (MACRO 32 (LDR.V X ,Vt ,temp)))))))
+
 ;; Load register signed
 
 (define-instruction LDRS
@@ -1119,14 +1091,22 @@ USA.
          (2 #b11)                       ;pre-index
          (5 Rn)
          (5 Rt)))
+
   ;; Literal
-  (((? Rt register-31=z) (@PCR (? label)))
+  (((? Rt register-31=z) (@PCO (? offset)))
    (BITS (2 #b10)                       ;opc
          (3 #b011)
          (1 0)                          ;general
          (2 #b00)
-         (19 `(QUOTIENT (- ,label *PC*) 4))
+         (19 offset SIGNED)
          (5 Rt)))
+  (((? Rt register-31=z) (@PCR (? label) (? temp register<31)))
+   (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4)
+       ((#x-40000 #x3ffff)
+        (MACRO 32 (LDRS ,Rt (@PCO ,offset))))
+       ((#x-100000000 #xffffffff)
+        (MACRO 64 (ADRP-ADD X ,temp (@PCO ,offset))) ;(*)
+        (MACRO 32 (LDRS ,Rt ,temp)))))
   ;; Register, no extend
   (((? Rt register-31=z) (? Rn register-31=sp) (? Rm register-31=z))
    (BITS (2 #b10)                       ;size
@@ -1158,748 +1138,7 @@ USA.
          (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))
+;;; Local Variables:
+;;; eval: (put 'variable-width 'scheme-indent-function 2)
+;;; End:
diff --git a/src/compiler/machines/aarch64/instr2.scm b/src/compiler/machines/aarch64/instr2.scm
new file mode 100644
index 000000000..949a4ae1e
--- /dev/null
+++ b/src/compiler/machines/aarch64/instr2.scm
@@ -0,0 +1,754 @@
+#| -*-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.
+
+|#
+
+;;;; AArch64 Instruction Set, part 2
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+;;; 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) (@PCO (? offset)))
+               (BITS (1 ,op)
+                     (2 (bitwise-and offset #b11))
+                     (1 1)
+                     (4 #b0000)
+                     (19 (bitwise-and (shift-right offset 2) #x1ffff))
+                     (5 Rd)))))))))
+  ;; PC-relative byte offset
+  (define-adr-instruction %ADR 0 1)
+  ;; PC-relative page offset
+  (define-adr-instruction %ADRP 1 4096))
+
+(define-instruction ADRP-ADD
+  ((X (? Rd) (@PCO ,offset))
+   (MACRO 32 (ADRP X ,Rd ,(shift-right offset 12)))
+   (MACRO 32 (ADD X ,Rd ,Rd ,(bitwise-and offset #xfff)))))
+
+(define-instruction ADR
+  ((X (? Rd) (@PCO (? offset)))
+   (MACRO 32 (%ADR X ,Rd (@PCO ,offset))))
+  ((X (? Rd) (@PCR (? label) (? temp register<31)))
+   (VARIABLE-WIDTH offset `(/ (- ,label *PC*) 4)
+     ((#x-40000 #x3ffff)
+      (MACRO 32 (ADR X ,Rd (@PCO ,offset))))
+     ((#x-100000000 #xffffffff)
+      (MACRO 64 (ADRP-ADD X ,Rd (@PCO ,offset)))))))
+
+(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 add/sub-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 add/sub-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 add/sub-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))
+
+(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 logical-shift/rotate-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 logical-shift/rotate-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))
+
+(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
+         (define-syntax receive
+           (syntax-rules ()
+             ((RECEIVE bvl expression body0 body1+ ...)
+              (CALL-WITH-VALUES (LAMBDA () expression)
+                (LAMBDA bvl body0 body1+ ...)))))
+         (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))
+
+;;; Local Variables:
+;;; eval: (put 'variable-width 'scheme-indent-function 2)
+;;; End:
diff --git a/src/compiler/machines/aarch64/instrf.scm b/src/compiler/machines/aarch64/instrf.scm
new file mode 100644
index 000000000..af8bc6a12
--- /dev/null
+++ b/src/compiler/machines/aarch64/instrf.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.
+
+|#
+
+;;;; AArch64 SIMD and Floating-Point Instruction Set
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+;;; XXX not yet
diff --git a/src/compiler/machines/aarch64/insutl.scm b/src/compiler/machines/aarch64/insutl.scm
new file mode 100644
index 000000000..acd494618
--- /dev/null
+++ b/src/compiler/machines/aarch64/insutl.scm
@@ -0,0 +1,272 @@
+#| -*-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.
+
+|#
+
+;;;; AArch64 Instruction Set, utilities
+
+(declare (usual-integrations))
+
+(define (signed-9 x)
+  (and (exact-integer? x)
+       (<= #x-200 x #x1ff)
+       x))
+
+(define (unsigned-2 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x 3)
+       x))
+
+(define (unsigned-3 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x 7)
+       x))
+
+(define (unsigned-4 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x #xf)
+       x))
+
+(define (unsigned-5 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x #x1f)
+       x))
+
+(define (unsigned-5+1 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 1 x #x20)
+       (- x 1)))
+
+(define (unsigned-6 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x #x3f)
+       x))
+
+(define (unsigned-7 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x #x7f)
+       x))
+
+(define (unsigned-12 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x #xfff)
+       x))
+
+(define (unsigned-16 x)
+  (and (exact-nonnegative-integer? x)
+       (<= 0 x #xffff)
+       x))
+
+(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-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)))
+
+(define (add/sub-extend-type t)
+  (case t
+    ((UXTB) #b000)
+    ((UXTH) #b001)
+    ((UXTW) #b010)
+    ((UXTX) #b011)
+    ((SXTB) #b100)
+    ((SXTH) #b101)
+    ((SXTW) #b110)
+    ((SXTX) #b111)
+    (else #f)))
+
+(define (add/sub-shift-type t)
+  (case t
+    ((LSL) #b00)
+    ((LSR) #b01)
+    ((ASR) #b10)
+    (else #f)))
+
+(define (logical-shift/rotate-type t)
+  (case t
+    ((LSL) #b00)
+    ((LSR) #b01)
+    ((ASR) #b10)
+    ((ROR) #b11)
+    (else #f)))
+
+(define (logical-imm-32 imm)
+  ;; XXX
+  imm
+  (error "XXX not yet implemented"))
+
+(define (logical-imm-64 imm)
+  ;; XXX
+  imm
+  (error "XXX not yet implemented"))
+
+(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))))
+
+(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 (isb-option o)
+  (case o
+    ((SY) #b1111)
+    (else #f)))
+
+(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)))
diff --git a/src/compiler/machines/aarch64/lapgen.scm b/src/compiler/machines/aarch64/lapgen.scm
index bd2f59a71..e6305e9c5 100644
--- a/src/compiler/machines/aarch64/lapgen.scm
+++ b/src/compiler/machines/aarch64/lapgen.scm
@@ -56,7 +56,7 @@ USA.
    ;r20 - free pointer
    ;r21 - dynamic link
    ;r22 - memtop
-   r23
+   ;r23 - scheme-to-interface
    r24
    r25
    r26
@@ -65,6 +65,7 @@ USA.
    ;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
+   ;      XXX could pick another one for our stack and leave this alone?
    ;; 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))
@@ -100,9 +101,7 @@ USA.
       (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 (ADD X ,target ,source (&U 0)))
              (LAP (ORR X ,target ,source (&U 0)))))
         ((FLOAT)
          (LAP (FMOV D ,target ,source)))
@@ -143,13 +142,45 @@ USA.
      (error "Unknown register type:" target))))
 
 (define (register->memory-transfer source offset base)
-  (case (register-type target)
+  (case (register-type source)
     ((GENERAL)
-     (LAP (STR X ,target (OFFSET ,base ,offset))))
+     (LAP (STR X ,source (OFFSET ,base ,offset))))
     ((FLOAT)
-     (LAP (STR D ,target (OFFSET ,base ,offset))))
+     (LAP (STR D ,source (OFFSET ,base ,offset))))
     (else
-     (error "Unknown register type:" target))))
+     (error "Unknown register type:" source))))
+
+;;; References, for machine register allocator.
+
+(define (ea/mode ea) (car ea))
+
+(define (offset-reference register offset)
+  (INST-EA (OFFSET ,register ,offset)))
+
+(define (offset-ea? ea)
+  (eq? 'OFFSET (ea/mode ea)))
+
+(define (offset-ea/register ea)
+  (guarantee offset-ea? ea)
+  (cadr ea))
+
+(define (offset-ea/offset ea)
+  (guarantee offset-ea? ea)
+  (caddr ea))
+
+(define (register-ea? ea)
+  (eq? 'R (ea/mode ea)))
+
+(define (register-ea/register ea)
+  (guarantee register-ea? ea)
+  (cadr ea))
+
+(define (vector-ea? ea)
+  (eq? 'V (ea/mode ea)))
+
+(define (vector-ea/register ea)
+  (guarantee vector-ea? ea)
+  (cadr ea))
 
 ;;; Utilities
 
@@ -165,11 +196,34 @@ USA.
 
 (define (standard-move-to-temporary! source)
   (if (eq? source 'Z)
-      (let ((temp (standard-temporary!)))
+      (let ((temp (allocate-temporary-register! 'GENERAL)))
         (prefix-instructions! (LAP (MOVZ X ,temp (&U 0))))
         temp)
       (move-to-temporary-register! source (register-type source))))
 
+(define (assign-register->register target source)
+  (move-to-alias-register! source (register-type source) target)
+  (LAP))
+
+(define (require-register! machine-reg)
+  (flush-register! machine-reg)
+  (need-register! machine-reg))
+
+(define (flush-register! machine-reg)
+  (prefix-instructions! (clear-registers! machine-reg)))
+
+(define (rtl-target:=machine-register! rtl-reg machine-reg)
+  (if (machine-register? rtl-reg)
+      (begin
+        (require-register! machine-reg)
+        (if (not (= rtl-reg machine-reg))
+            (suffix-instructions!
+             (register->register-transfer machine-reg rtl-reg))))
+      (begin
+        (delete-register! rtl-reg)
+        (flush-register! machine-reg)
+        (add-pseudo-register-alias! rtl-reg machine-reg))))
+
 (define (register-expression expression)
   (case (rtl:expression-type expression)
     ((REGISTER)
@@ -218,23 +272,40 @@ USA.
 
 (define (pop register)
   (LAP (LDR X ,register
-            (POST+ ,regnum:stack-pointer ,addressing-units-per-object))))
+            (POST+ ,regnum:stack-pointer ,address-units-per-object))))
 
 (define (push register)
   (LAP (STR X ,register
-            (PRE- ,regnum:stack-pointer ,addressing-units-per-object))))
+            (PRE- ,regnum:stack-pointer ,address-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)))))
+                    ,(* 2 address-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)))))
+             (PRE- ,regnum:stack-pointer ,(* 2 address-units-per-object)))))
+
+(define (fits-in-unsigned-12? x)
+  (<= 0 x #xfff))
+
+(define (fits-in-unsigned-16? x)
+  (<= 0 x #xffff))
+
+(define (fits-in-unsigned-32? x)
+  (<= 0 x #xffffffff))
+
+(define (fits-in-unsigned-48? x)
+  (<= 0 x #xffffffffffff))
 
+;; XXX doesn't belong here
+
+(define-integrable type-code:fixnum #x1a)
+(define-integrable type-code:manifest-closure #x0d)
+
 (define (scale->shift scale)
   (case scale
     ((1) 0)
@@ -257,7 +328,7 @@ USA.
   (load-unsigned-immediate target (bitwise-and imm #xffffffffffffffff)))
 
 (define (load-unsigned-immediate target imm)
-  (define (try-shift shift)
+  (define (try-shift imm shift)
     (and (zero? (bitwise-and imm (bit-mask shift 0)))
          (fits-in-unsigned-16? (shift-right imm shift))
          shift))
@@ -266,6 +337,8 @@ USA.
         (try-shift imm 16)
         (try-shift imm 32)
         (try-shift imm 48)))
+  (define (chunk16 pos)
+    (bitwise-and (shift-right imm 16) pos))
   (cond ((find-shift imm)
          => (lambda (shift)
               (LAP (MOVZ X ,target (LSL (&U ,imm) ,shift)))))
@@ -275,6 +348,7 @@ USA.
         ((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))
@@ -283,7 +357,12 @@ USA.
          => (lambda))
         ((fits-in-unsigned-16? (bitwise-not imm))
          (LAP (MOVN X ,target (&U ,(bitwise-not imm)))))
-        ...))
+	(else
+	 ;; XXX give up
+	 (LAP (MOVZ X ,target (&U ,(chunk16 0)))
+	      (MOVK X ,target (LSL (&U ,(chunk16 16)) 16))
+	      (MOVK X ,target (LSL (&U ,(chunk16 32)) 32))
+	      (MOVK X ,target (LSL (&U ,(chunk16 48)) 48))))))
 
 (define (load-pc-relative-address target label)
   ;; XXX What happens if label is >1 MB away?
@@ -294,13 +373,13 @@ USA.
        (LDR X ,target ,target)))
 
 (define (load-tagged-immediate target type datum)
-  (load-unsigned-immediate (make-non-pointer-literal type datum)))
+  (load-unsigned-immediate target (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)))
@@ -330,7 +409,7 @@ USA.
               (fits-in-unsigned-12? (shift-right (- immediate) 12)))
          (sub `(&U ,(- immediate) LSL 12)))
         (else
-         (let ((temp (standard-temporary!)))
+         (let ((temp (allocate-temporary-register! 'GENERAL)))
            (LAP ,@(load-unsigned-immediate temp immediate)
                 ,@(add temp))))))
 
@@ -376,8 +455,245 @@ USA.
 (define (object->address target source)
   (object->datum target source))
 
+;;;; Linearizer interface
+
 (define (lap:make-label-statement label)
   (LAP (LABEL ,label)))
 
 (define (lap:make-unconditional-branch label)
-  (LAP (B (@PCR ,label))))
+  (LAP (B (@PCR ,label ,regnum:scratch-0))))
+
+(define (lap:make-entry-point label block-start-label)
+  block-start-label
+  (LAP (ENTRY-POINT ,label)
+       ,@(make-external-label expression-code-word label)))
+
+(define (make-external-label type/arity label)
+  (set! *external-labels* (cons label *external-labels*))
+  (LAP (PADDING 32 64 0)
+       (EXTERNAL-LABEL ,type/arity ,label)
+       (DATA 64 U 0)
+       (LABEL ,label)))
+
+(define (make-code-word min max)
+  (+ (* #x100 min) max))
+
+(define expression-code-word
+  (make-code-word #xff #xff))
+
+;;;; Named registers, codes, and entries
+
+(define reg:memtop
+  (offset-reference regnum:regs-pointer
+                    register-block/memtop-offset))
+
+(define reg:environment
+  (offset-reference regnum:regs-pointer
+                    register-block/environment-offset))
+
+(define reg:lexpr-primitive-arity
+  (offset-reference regnum:regs-pointer
+                    register-block/lexpr-primitive-arity-offset))
+
+(define reg:stack-guard
+  (offset-reference regnum:regs-pointer
+                    register-block/stack-guard-offset))
+
+(define reg:int-mask
+  (offset-reference regnum:regs-pointer
+                    register-block/int-mask-offset))
+
+(define reg:int-code
+  (offset-reference regnum:regs-pointer
+                    register-block/int-code-offset))
+
+(define reg:reflect-to-interface
+  (offset-reference regnum:regs-pointer
+                    register-block/reflect-to-interface-offset))
+
+(define-syntax define-codes
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     `(BEGIN
+        ,@(let loop ((names (cddr form)) (index (cadr form)))
+            (if (pair? names)
+                (cons `(DEFINE-INTEGRABLE ,(symbol 'CODE:COMPILER- (car names))
+                         ,index)
+                      (loop (cdr names) (+ index 1)))
+                '()))))))
+
+;; Must match utility_table in cmpint.c.
+(define-codes #x012
+  primitive-apply
+  primitive-lexpr-apply
+  apply
+  error
+  lexpr-apply
+  link
+  interrupt-closure
+  interrupt-dlink
+  interrupt-procedure
+  interrupt-continuation
+  interrupt-ic-procedure
+  assignment-trap
+  cache-reference-apply
+  reference-trap
+  safe-reference-trap
+  unassigned?-trap
+  -1+
+  &/
+  &=
+  &>
+  1+
+  &<
+  &-
+  &*
+  negative?
+  &+
+  positive?
+  zero?
+  access
+  lookup
+  safe-lookup
+  unassigned?
+  unbound?
+  set!
+  define
+  lookup-apply
+  primitive-error
+  quotient
+  remainder
+  modulo)
+
+(define-syntax define-entries
+  (sc-macro-transformer
+   (lambda (form environment)
+     environment
+     `(BEGIN
+        ,@(let loop ((names (cddr form)) (index (cadr form)))
+            (if (pair? names)
+                (cons `(DEFINE-INTEGRABLE
+                           ,(symbol 'ENTRY:COMPILER- (car names))
+                         ,index)
+                      (loop (cdr names) (+ index 1)))
+                '()))))))
+
+;; Must match aarch64_reset_hook in cmpintmd/aarch64.c.
+(define-entries 16
+  scheme-to-interface                   ; Main entry point (only one necessary)
+  interrupt-procedure
+  interrupt-continuation
+  interrupt-continuation-2
+  interrupt-closure
+  interrupt-dlink
+  primitive-apply
+  primitive-lexpr-apply
+  assignment-trap
+  reference-trap
+  safe-reference-trap
+  link
+  error
+  primitive-error
+  &+
+  &-
+  &*
+  &/
+  &=
+  &<
+  &>
+  1+
+  -1+
+  zero?
+  positive?
+  negative?
+  quotient
+  remainder
+  modulo
+  fixnum-shift
+  apply-setup
+  apply-setup-size-1
+  apply-setup-size-2
+  apply-setup-size-3
+  apply-setup-size-4
+  apply-setup-size-5
+  apply-setup-size-6
+  apply-setup-size-7
+  apply-setup-size-8
+  set-interrupt-enables!)
+
+(define-integrable (invoke-hook entry)
+  (LAP (LDR X ,regnum:scratch-0 (+ ,regnum:regs-pointer (&U (* 8 ,entry))))
+       (BR ,regnum:scratch-0)))
+
+;; Invoke a hook that will return to the address in the link register
+;; with RET.  To be used for super-cheap assembly hooks that never fail
+;; but are a little too large to copy in every caller.
+
+(define-integrable (invoke-hook/subroutine entry)
+  (LAP (LDR X ,regnum:scratch-0 (+ ,regnum:regs-pointer (&U (* 8 ,entry))))
+       (BLR ,regnum:scratch-0)))
+
+;; Invoke a hook that expects an untagged compiled return address in
+;; the link register, may examine it, and will eventually pop it and
+;; return to it with RET.  It is worthwhile to use paired BL/RET here
+;; because in the fast path, non-error case, the hook will just return
+;; to Scheme; only in error or complicated cases will it return to C.
+;; To be used for compiler utilities that are usually cheap but may
+;; have error cases and may call back into C.
+
+(define-integrable (invoke-hook/call entry label)
+  (LAP ,@(invoke-hook/subroutine entry)
+       (B (@PCR ,label ,regnum:scratch-0))))
+
+;; Invoke a hook that expects a compiled entry address as the first
+;; utility argument, and will later jump to it with BR.  It is not
+;; worthwhile to use paired BL/RET here because the microcode will RET
+;; back into C code on the C stack to handle it, which wrecks the
+;; return address branch target predictor anyway.  To be used for,
+;; e.g., interrupts, which are assumed to be always expensive.
+
+(define-integrable (invoke-hook/reentry entry label)
+  (LAP (ADR X ,regnum:utility-arg0 (@PCR ,label ,regnum:scratch-0))
+       ,@(invoke-hook entry)))
+
+(define-integrable (invoke-interface code)
+  (LAP (MOVZ X ,regnum:utility-index (&U ,code))
+       (BR ,regnum:scheme-to-interface)))
+
+(define-integrable (invoke-interface/call code label)
+  (LAP (MOVZ X ,regnum:utility-index (&U ,code))
+       (BLR ,regnum:scheme-to-interface)
+       (B (@PCR ,label ,regnum:scratch-0))))
+
+(define-integrable (invoke-interface/reentry code label)
+  (LAP (ADR X ,regnum:utility-arg0 (@PCR ,label ,regnum:scratch-0))
+       ,@(invoke-interface code)))
+
+;; Operation tables
+
+(define (define-arithmetic-method operator methods method)
+  (let ((entry (assq operator (cdr methods))))
+    (if entry
+        (set-cdr! entry method)
+        (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+  operator)
+
+(define (lookup-arithmetic-method operator methods)
+  (cdr (or (assq operator (cdr methods))
+           (error "Unknown operator" operator))))
+
+(define (pre-lapgen-analysis rgraphs)
+  (for-each (lambda (rgraph)
+              (for-each (lambda (edge)
+                          (determine-interrupt-checks (edge-right-node edge)))
+                        (rgraph-entry-edges rgraph)))
+            rgraphs))
+
+;; XXX
+
+(define (back-end:object-type object)
+  (object-type object))
+
+(define (back-end:object-datum object)
+  (object-datum object))
diff --git a/src/compiler/machines/aarch64/order-le.scm b/src/compiler/machines/aarch64/little-endian.scm
similarity index 100%
rename from src/compiler/machines/aarch64/order-le.scm
rename to src/compiler/machines/aarch64/little-endian.scm
diff --git a/src/compiler/machines/aarch64/machine.scm b/src/compiler/machines/aarch64/machine.scm
index 4dfe339d2..83cca0e8c 100644
--- a/src/compiler/machines/aarch64/machine.scm
+++ b/src/compiler/machines/aarch64/machine.scm
@@ -189,7 +189,7 @@ USA.
 (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 r23 23) ;scheme-to-interface callee-saved
 (define-integrable r24 24) ;temporary           callee-saved
 (define-integrable r25 25) ;temporary           callee-saved
 (define-integrable r26 26) ;temporary           callee-saved
@@ -261,6 +261,7 @@ USA.
 (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:scheme-to-interface r23)
 (define-integrable regnum:c-frame-pointer r29)
 (define-integrable regnum:link-register rlr) ;Return address.
 (define-integrable regnum:stack-pointer rsp)
@@ -269,6 +270,7 @@ USA.
 ;; these.
 (define-integrable regnum:apply-target regnum:scratch-0)
 (define-integrable regnum:apply-pc regnum:scratch-1)
+(define-integrable regnum:utility-index regnum:scratch-1)
 
 (define-integrable (machine-register-known-value register)
   register                              ;ignore
@@ -400,6 +402,7 @@ USA.
         (cost:imm32 2)                  ;MOVZ/MOVN + 1*MOVK
         (cost:imm48 3)                  ;MOVZ/MOVN + 2*MOVK
         (cost:imm64 4)                  ;MOVZ/MOVN + 3*MOVK
+        (cost:add 1)
         (cost:adr 1)
         (cost:ldr 10)
         (cost:bl 2))
@@ -426,7 +429,6 @@ USA.
     (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
diff --git a/src/compiler/machines/aarch64/rules1.scm b/src/compiler/machines/aarch64/rules1.scm
index 171051727..5579d952a 100644
--- a/src/compiler/machines/aarch64/rules1.scm
+++ b/src/compiler/machines/aarch64/rules1.scm
@@ -302,7 +302,7 @@ USA.
   (QUALIFIER (not (= offset rsp)))
   (standard-binary-effect source base
     (lambda (source base)
-      (LAP (STR B ,target (+ ,base (&U ,offset)))))))
+      (LAP (STR B ,source (+ ,base (&U ,offset)))))))
 
 ;;; Detag and store byte with displacement
 
@@ -313,4 +313,4 @@ USA.
   (QUALIFIER (not (= offset rsp)))
   (standard-binary-effect source base
     (lambda (source base)
-      (LAP (STR B ,target (+ ,base (&U ,offset)))))))
+      (LAP (STR B ,source (+ ,base (&U ,offset)))))))
diff --git a/src/compiler/machines/aarch64/rules2.scm b/src/compiler/machines/aarch64/rules2.scm
index dc5ab2112..c629be907 100644
--- a/src/compiler/machines/aarch64/rules2.scm
+++ b/src/compiler/machines/aarch64/rules2.scm
@@ -74,7 +74,7 @@ USA.
 
 (define-rule predicate
   (TYPE-TEST (REGISTER (? register)) (? type))
-  (immediate-equal-test! (standard-source! register) type))
+  (eq-test/register*immediate! (standard-source! register) type))
 
 ;; Test tag and sign in one swell foop.
 
diff --git a/src/compiler/machines/aarch64/rules3.scm b/src/compiler/machines/aarch64/rules3.scm
index e4e1fe5ba..b06de2637 100644
--- a/src/compiler/machines/aarch64/rules3.scm
+++ b/src/compiler/machines/aarch64/rules3.scm
@@ -64,7 +64,7 @@ USA.
   (let* ((prefix (clear-map!))
          (setup (apply-setup frame-size)))
     (LAP ,@prefix
-         ,@(pop ,regnum:apply-target)
+         ,@(pop regnum:apply-target)
          ,@setup
          (BR ,regnum:apply-pc))))
 
@@ -108,14 +108,16 @@ USA.
        (BR ,regnum:apply-pc)))
 
 (define-rule statement
-  (INVOCATION:LEXPR (? number-pushed) (? continuation) (? labe))
+  (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+  continuation
   (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))
+  (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
+  continuation
   (LAP ,@(clear-map!)
        ,@(pop regnum:utility-arg0)
        ,@(object->address regnum:utility-arg0 regnum:utility-arg0)
@@ -283,8 +285,8 @@ USA.
 (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)))
+      (generate/move-frame-up/unrolled frame-size address)
+      (generate/move-frame-up/loop frame-size address)))
 
 (define (generate/move-frame-up/loop frame-size address)
   (assert (not (= register regnum:stack-pointer)))
@@ -302,8 +304,8 @@ USA.
     (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 (LDR X ,temp1 (PRE- ,regnum:stack-pointer (&U 8)))
+                    (STR X ,temp1 (PRE- ,address (&U 8))))
                (LAP))
          ,@(load-unsigned-immediate index loop-count)
         (LABEL ,label)
@@ -327,7 +329,7 @@ USA.
     (LAP ,@(let loop ((temps temps))
              ;; (pop2 r1 r2) (pop2 r3 r4) (pop r5)
              (if (pair? temps)
-                 (if (pair (cdr? temps))
+                 (if (pair? (cdr temps))
                      (LAP ,@(pop2 (car temps) (cadr temps))
                           ,@(loop (cddr temps)))
                      (pop (car temps)))
@@ -538,7 +540,7 @@ USA.
 (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-type type-code:manifest-closure)
          (manifest-size (closure-manifest-size size))
          (Free Free))
     (LAP ,@(load-tagged-immediate manifest-type manifest-size temp)
@@ -550,9 +552,7 @@ USA.
          ;; 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))))
+	 ,@(add-immediate Free Free (* 8 size))
          ;; Set the last component to be the relocation reference point.
          ,@(affix-type temp type-code:compiled-entry target)
          (STR X ,temp (POST+ ,Free (& 8))))))
@@ -560,7 +560,7 @@ USA.
 (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-type type-code:manifest-closure)
          (manifest-size (multiclosure-manifest-size nentries size))
          ;; 8 for manifest, 8 for padding & format word, 8 for PC offset.
          (offset0 #x18)
@@ -574,24 +574,22 @@ USA.
             (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
+    (define (generate-subsidiary-entries entries n)
       (assert (pair? entries))
-      (LAP ,@(generate-subsidiary-entry (car entries))
+      (LAP ,@(generate-subsidiary-entry (car entries) n)
            ,@(if (pair? (cdr entries))
-                 (generate-subsidiary-entries (cdr entries))
+                 (generate-subsidiary-entries (cdr entries) (+ n 1))
                  (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))
+         ,@(generate-subsidiary-entries (cdr entries) 1)
          ;; 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)))
+	 ,@(add-immediate Free Free (* 8 size))
          ;; Set the last component to be the relocation reference point.
          ,@(affix-type temp type-code:compiled-entry target)
          (STR X ,temp (POST+ ,Free (& 8))))))
@@ -636,7 +634,7 @@ USA.
 ;;;; Entry Header
 
 (define (generate/quotation-header environment-label free-ref-label n-sections)
-  (let ((continuation-label (generate-label /LINKED)))
+  (let ((continuation-label (generate-label 'LINKED)))
     (LAP (LDR X ,r0 ,reg:environment)
          (ADR X ,r1 (@PCR ,environment-label))
          (STR X ,r0 ,r1)
@@ -650,9 +648,10 @@ USA.
 ;;; XXX Why is this hand-coded assembly and not a C function?
 
 (define (generate/remote-links n-blocks vector-label nsects)
+  vector-label nsects
   (if (zero? n-blocks)
       (LAP)
-      ...))
+      (error "XXX not yet implemented")))
 
 (define (generate/constants-block constants references assignments
                                   uuo-links global-links static-vars)
diff --git a/src/compiler/machines/aarch64/rulfix.scm b/src/compiler/machines/aarch64/rulfix.scm
index d5c7d792d..4f5ab88ec 100644
--- a/src/compiler/machines/aarch64/rulfix.scm
+++ b/src/compiler/machines/aarch64/rulfix.scm
@@ -35,7 +35,7 @@ USA.
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
-  (load-immediate (standard-target! target) (* constant fixnum-1) #t))
+  (load-signed-immediate (standard-target! target) (* constant fixnum-1)))
 
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
@@ -70,6 +70,9 @@ USA.
 
 (define (word->fixnum target source)
   (LAP (AND X ,target ,source (&U ,(- (expt 2 scheme-type-width) 1)))))
+
+(define-integrable fixnum-1
+  (shift-left 1 scheme-type-width))
 
 ;;;; Unary Fixnum Operations
 
diff --git a/src/compiler/machines/aarch64/rulflo.scm b/src/compiler/machines/aarch64/rulflo.scm
new file mode 100644
index 000000000..527acf8bd
--- /dev/null
+++ b/src/compiler/machines/aarch64/rulflo.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.
+
+|#
+
+;;;; LAP Generation Rules: Flonum rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+
+;;; XXX not yet
diff --git a/src/microcode/aclocal.m4 b/src/microcode/aclocal.m4
index 54361014d..3380e4de6 100644
--- a/src/microcode/aclocal.m4
+++ b/src/microcode/aclocal.m4
@@ -150,6 +150,9 @@ i?86|x86)
 x86-64|x86_64|amd64)
     mit_scheme_architecture=x86-64
     ;;
+aarch64le|aarch64be)
+    mit_scheme_architecture=aarch64
+    ;;
 *)
     AC_MSG_ERROR([unknown compiler architecture: ${_mit_scheme_architecture_spec}])
     ;;
diff --git a/src/microcode/cmpauxmd/aarch64.m4 b/src/microcode/cmpauxmd/aarch64.m4
new file mode 100644
index 000000000..6df47d63f
--- /dev/null
+++ b/src/microcode/cmpauxmd/aarch64.m4
@@ -0,0 +1,29 @@
+### -*- Asm -*-
+###
+### 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.
+
+### Local Variables:
+### comment-start: "#"
+### asm-comment-char: ?#
+### End:
diff --git a/src/microcode/cmpintmd/aarch64-config.h b/src/microcode/cmpintmd/aarch64-config.h
new file mode 100644
index 000000000..bfaccc0ce
--- /dev/null
+++ b/src/microcode/cmpintmd/aarch64-config.h
@@ -0,0 +1,33 @@
+/* -*-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.
+
+*/
+
+#ifndef SCM_CMPINTMD_CONFIG_H_INCLUDED
+#define SCM_CMPINTMD_CONFIG_H_INCLUDED 1
+
+#define COMPILER_PROCESSOR_TYPE COMPILER_AARCH64_TYPE
+#define CC_IS_NATIVE 1
+
+#endif /* !SCM_CMPINTMD_CONFIG_H_INCLUDED */
diff --git a/src/microcode/cmpintmd/aarch64.c b/src/microcode/cmpintmd/aarch64.c
index ead2df7c1..5619c53b4 100644
--- a/src/microcode/cmpintmd/aarch64.c
+++ b/src/microcode/cmpintmd/aarch64.c
@@ -219,37 +219,35 @@ write_uuo_insns (const insn_t * target, insn_t * iaddr, int pcrel)
      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]));
+      ptrdiff_t offset = (((uintptr_t) target) - ((uintptr_t) (&iaddr[1])));
       if ((-0x40000 <= offset) && (offset <= 0x3ffff))
 	{
-	  uint32_t immlo = (offset & 3);
-	  uint32_t immhi = ((((uint32_t) offset) & 0x7fffc) >> 2);
+	  unsigned immlo2 = (offset & 3);
+	  unsigned immhi19 = ((((unsigned) offset) >> 2) & 0x1ffff);
+	  assert (offset == ((ptrdiff_t) ((immhi19 << 2) | immlo2)));
 	  /* adr x1, target */
-	  (addr[1]) = (0x10000001UL | (immlo << 29) | (immhi << 5));
+	  (addr[1]) = (0x10000001UL | (immlo2 << 29) | (immhi19 << 5));
 	  /* br x1 */
 	  (addr[2]) = 0xd61f0020UL;
 	}
-      else
+      else if (((- (INT64_C (0x200000000))) <= offset) &&
+	       (offset <= (INT64_C (0x1ffffffff))))
 	{
-	  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 ();
+	  unsigned long lo12 = (offset & 0xfff);
+	  unsigned long pglo2 = ((((unsigned long) offset) >> 12) & 3);
+	  unsigned long pghi19 = ((((unsigned long) offset) >> 14) & 0x1ffff);
+	  assert
+	    (offset == ((ptrdiff_t) ((pghi19 << 14) | (pglo2 << 12) | lo12)));
+	  /* adrp x1, target */
+	  (iaddr[1]) = (0x90000001UL | (pglo2 << 29) | (pghi19 << 5));
+	  /* add x1, x1, #off */
+	  (iaddr[2]) = (0x91000021UL | (lo12 << 10));
+	  /* br x1 */
+	  (iaddr[3]) = 0xd61f0020UL;
 	}
+      else
+	/* You have too much memory.  */
+	error_external_return ();
     }
   else
     {
diff --git a/src/microcode/confshared.h b/src/microcode/confshared.h
index af4747375..a40bc4378 100644
--- a/src/microcode/confshared.h
+++ b/src/microcode/confshared.h
@@ -221,11 +221,12 @@ typedef enum
   FASL_PPC64,
   FASL_IA64,
   FASL_ARM,
-  FASL_AARCH64,
+  FASL_AARCH64LE,
   FASL_SVM1_32BE,
   FASL_SVM1_32LE,
   FASL_SVM1_64BE,
   FASL_SVM1_64LE,
+  FASL_AARCH64BE,
 } fasl_arch_t;
 
 /* Possible values for COMPILER_PROCESSOR_TYPE.  This identifies the
@@ -240,6 +241,7 @@ typedef enum
   COMPILER_C_TYPE = 12,
   COMPILER_SVM_TYPE = 13,
   COMPILER_X86_64_TYPE = 14,
+  COMPILER_AARCH64_TYPE = 15,
 } cc_arch_t;
 
 #include "cmpintmd-config.h"