chez-openbsd/s/arm32.ss

;;; arm32.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; SECTION 1: registers
;;; ABI:
;;;  Register usage:
;;;   r0-r3 aka a1-a4: C argument registers, caller-save
;;;   r4-r8, r10, r11 aka v1-v5, v7, v8: callee-save
;;;   r9 aka v6, sb, or tr: platform-specific, callee-save
;;;   r12 aka ip: caller-save (possibly usurped by linker at call boundaries)
;;;   r13 aka sp: C stack pointer
;;;   r14 aka lr: link register
;;;   r15 aka pc: program counter
;;;   --------
;;;   s0-s31: single-precision registers (with vfp-v2) overlap with d0-d15
;;;   d0-d15: double-precision registers (with vfp-v2)
;;;   d16-d31: double-precision registers (with vfp-v3)
;;;  Alignment:
;;;   double-floats & 64-bit integers are 8-byte aligned in structs
;;;   double-floats & 64-bit integers are 8-byte aligned on the stack
;;;   stack must be 8-byte aligned at call boundaries (otherwise 4-byte)
;;;  Parameter passing:
;;;   8- and 16-bit integer arguments zero- or sign-extended to 32-bits
;;;   32-bit integer arguments passed in a1-a4, then on stack
;;;   64-bit integer arguments passed in a1 or a3, then on stack
;;;       little-endian: a1 (a3) holds lsw, a2 (a4) holds msw
;;;       big-endian: a1 (a3) holds msw, a2 (a4) holds lsw
;;;   8- and 16-bit integer return value zero- or sign-extended to 32-bits
;;;   32-bit integer return value returned in r0 (aka a1)
;;;   64-bit integer return value passed in r0 & r1 (aka a1 & a2)
;;;       little-endian: r0 holds lsw, r1 holds msw
;;;       big-endian: r0 holds msw, r1 holds lsw
;;;   single-floats passed in s0-s15
;;;   double-floats passed in d0-d7 (overlapping single)
;;;   float return value returned in s0 or d0
;;;   must allocate to a single-float reg if it's passed by for double-float alignment
;;;     (e.g., single, double, single => s0, d1, s1)
;;;   ... unless a double has been stack-allocated
;;;     (e.g., 15 singles, double => s0-s14, stack, stack)
;;;   stack grows downwards.  first stack args passed at lowest new frame address.
;;;   return address passed in LR
;;; questions:
;;;   least significant bit is always designated as bit 0...how does this affect
;;;      bit fields in big-endian mode?
;;; meta questions:
;;;   should we have both little- and big-endian support?
;;;   can pidora (or some other linux distribution) run using both little- and big-endian modes?

(define-registers
  (reserved
    [%tc  %r9                   #t  9]
    [%sfp %r10                  #t 10]
    [%ap  %r5                   #t  5]
    #;[%esp]
    #;[%eap]
    [%trap %r8                  #t  8])
  (allocable
    [%ac0 %r4                   #t  4]
    [%xp  %r6                   #t  6]
    [%ts  %ip                   #f 12]
    [%td  %r11                  #t 11]
    #;[%ret]
    [%cp  %r7                   #t  7]
    #;[%ac1]
    #;[%yp]
    [     %r0  %Carg1 %Cretval  #f  0]
    [     %r1  %Carg2           #f  1]
    [     %r2  %Carg3           #f  2]
    [     %r3  %Carg4           #f  3]
    [     %lr                   #f 14] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room
  )
  (machine-dependent
    [%sp                        #t 13]
    [%pc                        #f 15]
    [%Cfparg1 %Cfpretval %d0  %s0   #f  0] ; < 32: low bit goes in D, N, or M bit, high bits go in Vd, Vn, Vm
    [%Cfparg1b                %s1   #f  1]
    [%Cfparg2            %d1  %s2   #f  2]
    [%Cfparg2b                %s3   #f  3]
    [%Cfparg3            %d2  %s4   #f  4]
    [%Cfparg3b                %s5   #f  5]
    [%Cfparg4            %d3  %s6   #f  6]
    [%Cfparg4b                %s7   #f  7]
    [%Cfparg5            %d4  %s8   #f  8]
    [%Cfparg5b                %s9   #f  9]
    [%Cfparg6            %d5  %s10  #f 10]
    [%Cfparg6b                %s11  #f 11]
    [%Cfparg7            %d6  %s12  #f 12]
    [%Cfparg7b                %s13  #f 13]
    [%Cfparg8            %d7  %s14  #f 14]
    [%Cfparg8b                %s15  #f 15]
    [%flreg1             %d8  %s16  #f 16]
    [%flreg2             %d9  %s18  #f 18]
    ; etc.
    #;[                  %d16       #f 32] ; >= 32: high bit goes in D, N, or M bit, low bits go in Vd, Vn, Vm
    #;[                  %d17       #f 33]
    ; etc.
    ))

;;; SECTION 2: instructions
(module (md-handle-jump) ; also sets primitive handlers
  (import asm-module)

  (define-syntax seq
    (lambda (x)
      (syntax-case x ()
        [(_ e ... ex)
         (with-syntax ([(t ...) (generate-temporaries #'(e ...))])
           #'(let ([t e] ...)
               (with-values ex
                 (case-lambda
                   [(x*) (cons* t ... x*)]
                   [(x* p) (values (cons* t ... x*) p)]))))])))

  ; don't bother with literal@? check since lvalues can't be literals
  (define lmem? mref?)

  (define mem?
    (lambda (x)
      (or (lmem? x) (literal@? x))))

  (define imm-funky12?
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) (and (funky12 imm) #t)]
        [else #f])))

  (define imm-negate-funky12?
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) (and (funky12 (- imm)) #t)]
        [else #f])))

  (define imm-lognot-funky12?
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) (and (funky12 (lognot imm)) #t)]
        [else #f])))

  (define imm-shift-count?
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) (shift-count? imm)]
        [else #f])))

  (define imm-unsigned8?
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) (unsigned8? imm)]
        [else #f])))

  (define imm-unsigned12?
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) (unsigned12? imm)]
        [else #f])))

  (define imm-constant?
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) #t]
        [else #f])))

  (define uword8?
    (lambda (imm)
      (and (fixnum? imm) ($fxu< imm (expt 2 10)) (not (fxlogtest imm #b11)))))

  (define imm-uword8?
    ;; immediate is a nonnegative 8-bit word offset
    ;; effectively 8-bit unsigned left-shifted by 2
    (lambda (x)
      (nanopass-case (L15c Triv) x
        [(immediate ,imm) (uword8? imm)]
        [else #f])))

  (define-pass imm->negate-imm : (L15c Triv) (ir) -> (L15d Triv) ()
    (Triv : Triv (ir) -> Triv ()
      [(immediate ,imm) `(immediate ,(- imm))]
      [else (sorry! who "~s is not an immediate" ir)]))

  (define-pass imm->lognot-imm : (L15c Triv) (ir) -> (L15d Triv) ()
    (Triv : Triv (ir) -> Triv ()
      [(immediate ,imm) `(immediate ,(lognot imm))]
      [else (sorry! who "~s is not an immediate" ir)]))

  (define lvalue->ur
    (lambda (x k)
      (if (mref? x)
          (let ([u (make-tmp 'u)])
            (seq
              (set-ur=mref u x)
              (k u)))
          (k x))))

  (define mref->mref
    (lambda (a k)
      (define return
        (lambda (x0 x1 imm)
          ; arm load & store instructions support index or offset but not both
          (safe-assert (or (eq? x1 %zero) (eqv? imm 0)))
          (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm)))))
      (nanopass-case (L15c Triv) a
        [(mref ,lvalue0 ,lvalue1 ,imm)
         (lvalue->ur lvalue0
           (lambda (x0)
             (lvalue->ur lvalue1
               (lambda (x1)
                 (cond
                   [(and (eq? x1 %zero) (or (unsigned12? imm) (unsigned12? (- imm))))
                    (return x0 %zero imm)]
                   [(funky12 imm)
                    ; NB: dubious value?  check to see if it's exercised
                    ; NB: might should safe-assert x1 is %zero
                    (let ([u (make-tmp 'u)])
                      (seq
                       (build-set! ,u (asm ,null-info ,(asm-add #f) ,x0 (immediate ,imm)))
                       (return u x1 0)))]
                   [(funky12 (- imm))
                    ; NB: dubious value?  check to see if it's exercised
                    ; NB: might should safe-assert x1 is %zero
                    (let ([u (make-tmp 'u)])
                      (seq
                       (build-set! ,u (asm ,null-info ,(asm-sub #f) ,x0 (immediate ,imm)))
                       (return u x1 0)))]
                   [else
                    (let ([u (make-tmp 'u)])
                      (seq
                        (build-set! ,u (immediate ,imm))
                        (if (eq? x1 %zero)
                            (return x0 u 0)
                            (seq
                              (build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1))
                              (return x0 u 0)))))])))))])))

  (define mem->mem
    (lambda (a k)
      (cond
        [(literal@? a)
         (let ([u (make-tmp 'u)])
           (seq
             (build-set! ,u ,(literal@->literal a))
             (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0)))))]
        [else (mref->mref a k)])))

  (define-syntax coercible?
    (syntax-rules ()
      [(_ ?a ?aty*)
       (let ([a ?a] [aty* ?aty*])
         (or (memq 'ur aty*)
             (and (memq 'funky12 aty*) (imm-funky12? a))
             (and (memq 'negate-funky12 aty*) (imm-negate-funky12? a))
             (and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a))
             (and (memq 'shift-count aty*) (imm-shift-count? a))
             (and (memq 'unsigned8 aty*) (imm-unsigned8? a))
             (and (memq 'unsigned12 aty*) (imm-unsigned12? a))
             (and (memq 'imm-constant aty*) (imm-constant? a))
             (and (memq 'uword8 aty*) (imm-uword8? a))
             (and (memq 'mem aty*) (mem? a))))]))

  (define-syntax coerce-opnd ; passes k something compatible with aty*
    (syntax-rules ()
      [(_ ?a ?aty* ?k)
       (let ([a ?a] [aty* ?aty*] [k ?k])
         (cond
           [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
           [(and (memq 'funky12 aty*) (imm-funky12? a)) (k (imm->imm a))]
           [(and (memq 'negate-funky12 aty*) (imm-negate-funky12? a)) (k (imm->negate-imm a))]
           [(and (memq 'lognot-funky12 aty*) (imm-lognot-funky12? a)) (k (imm->lognot-imm a))]
           [(and (memq 'shift-count aty*) (imm-shift-count? a)) (k (imm->imm a))]
           [(and (memq 'unsigned8 aty*) (imm-unsigned8? a)) (k (imm->imm a))]
           [(and (memq 'unsigned12 aty*) (imm-unsigned12? a)) (k (imm->imm a))]
           [(and (memq 'imm-constant aty*) (imm-constant? a)) (k (imm->imm a))]
           [(and (memq 'uword8 aty*) (imm-uword8? a)) (k (imm->imm a))]
           [(memq 'ur aty*)
            (cond
              [(ur? a) (k a)]
              [(imm? a)
               (let ([u (make-tmp 'u)])
                 (seq
                   (build-set! ,u ,(imm->imm a))
                   (k u)))]
              [(mem? a)
               (mem->mem a
                 (lambda (a)
                   (let ([u (make-tmp 'u)])
                     (seq
                       (build-set! ,u ,a)
                       (k u)))))]
              [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
           [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))

  (define set-ur=mref
    (lambda (ur mref)
      (mref->mref mref
        (lambda (mref)
          (build-set! ,ur ,mref)))))

  (define md-handle-jump
    (lambda (t)
      (with-output-language (L15d Tail)
        (define long-form
          (lambda (e)
            (let ([tmp (make-tmp 'utmp)])
              (values
                (in-context Effect `(set! ,(make-live-info) ,tmp ,e))
                `(jump ,tmp)))))
        (nanopass-case (L15c Triv) t
          [,lvalue
           (if (mem? lvalue)
               (mem->mem lvalue (lambda (e) (values '() `(jump ,e))))
               (values '() `(jump ,lvalue)))]
          [(literal ,info)
           (guard (and (not (info-literal-indirect? info))
                       (memq (info-literal-type info) '(entry library-code))))
           ; NB: really need to use unspillable or mark %ip (aka %ts) killed here but can't without extending jump syntax
           (values '() `(jump (literal ,info)))]
          [(label-ref ,l ,offset)
           ; NB: really need to use unspillable or mark %ip (aka %ts) killed here but can't without extending jump syntax
           (values '() `(jump (label-ref ,l ,offset)))]
          [else (long-form t)]))))

  (define-syntax define-instruction
    (lambda (x)
      (define make-value-clause
        (lambda (fmt)
          (syntax-case fmt (mem ur)
            [(op (c mem) (a ur))
             #`(lambda (c a)
                 (if (lmem? c)
                     (coerce-opnd a '(ur)
                       (lambda (a)
                         (mem->mem c
                           (lambda (c)
                             (rhs c a)))))
                     (next c a)))]
            [(op (c ur) (a aty ...) ...)
             #`(lambda (c a ...)
                 (if (and (coercible? a '(aty ...)) ...)
                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
                         (if (null? a*)
                             #'(if (ur? c)
                                   (rhs c a ...)
                                   (let ([u (make-tmp 'u)])
                                     (seq
                                       (rhs u a ...)
                                       (mref->mref c
                                         (lambda (c)
                                           (build-set! ,c ,u))))))
                             #`(coerce-opnd #,(car a*) '#,(car aty**)
                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
                     (next c a ...)))])))

      (define-who make-pred-clause
        (lambda (fmt)
          (syntax-case fmt ()
            [(op (a aty ...) ...)
             #`(lambda (a ...)
                 (if (and (coercible? a '(aty ...)) ...)
                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
                         (if (null? a*)
                             #'(rhs a ...)
                             #`(coerce-opnd #,(car a*) '#,(car aty**)
                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
                     (next a ...)))])))

      (define-who make-effect-clause
        (lambda (fmt)
          (syntax-case fmt ()
            [(op (a aty ...) ...)
             #`(lambda (a ...)
                 (if (and (coercible? a '(aty ...)) ...)
                     #,(let f ([a* #'(a ...)] [aty** #'((aty ...) ...)])
                         (if (null? a*)
                             #'(rhs a ...)
                             #`(coerce-opnd #,(car a*) '#,(car aty**)
                                 (lambda (#,(car a*)) #,(f (cdr a*) (cdr aty**))))))
                     (next a ...)))])))

      (syntax-case x (definitions)
        [(k context (sym ...) (definitions defn ...) [(op (a aty ...) ...) ?rhs0 ?rhs1 ...] ...)
         ; potentially unnecessary level of checking, but the big thing is to make sure
         ; the number of operands expected is the same on every clause of define-instruction
         (and (not (null? #'(op ...)))
              (andmap identifier? #'(sym ...))
              (andmap identifier? #'(op ...))
              (andmap identifier? #'(a ... ...))
              (andmap identifier? #'(aty ... ... ...)))
         (with-implicit (k info return with-output-language)
           (with-syntax ([((opnd* ...) . ignore) #'((a ...) ...)])
             (define make-proc
               (lambda (make-clause)
                 (let f ([op* #'(op ...)]
                         [fmt* #'((op (a aty ...) ...) ...)]
                         [arg* #'((a ...) ...)]
                         [rhs* #'((?rhs0 ?rhs1 ...) ...)])
                   (if (null? op*)
                       #'(lambda (opnd* ...)
                           (sorry! name "no match found for ~s" (list opnd* ...)))
                       #`(let ([next #,(f (cdr op*) (cdr fmt*) (cdr arg*) (cdr rhs*))]
                               [rhs (lambda #,(car arg*)
                                      (let ([#,(car op*) name])
                                        #,@(car rhs*)))])
                           #,(make-clause (car fmt*)))))))
             (unless (let ([a** #'((a ...) ...)])
                       (let* ([a* (car a**)] [len (length a*)])
                         (andmap (lambda (a*) (fx= (length a*) len)) (cdr a**))))
               (syntax-error x "mismatched instruction arities"))
             (cond
               [(free-identifier=? #'context #'value)
                #`(let ([fvalue (lambda (name)
                                  (lambda (info opnd* ...)
                                    defn ...
                                    (with-output-language (L15d Effect)
                                      (#,(make-proc make-value-clause) opnd* ...))))])
                    (begin
                      (safe-assert (eq? (primitive-type (%primitive sym)) 'value))
                      (primitive-handler-set! (%primitive sym) (fvalue 'sym)))
                    ...)]
               [(free-identifier=? #'context #'pred)
                #`(let ([fpred (lambda (name)
                                 (lambda (info opnd* ...)
                                   defn ...
                                   (with-output-language (L15d Pred)
                                     (#,(make-proc make-pred-clause) opnd* ...))))])
                    (begin
                      (safe-assert (eq? (primitive-type (%primitive sym)) 'pred))
                      (primitive-handler-set! (%primitive sym) (fpred 'sym)))
                    ...)]
               [(free-identifier=? #'context #'effect)
                #`(let ([feffect (lambda (name)
                                   (lambda (info opnd* ...)
                                     defn ...
                                     (with-output-language (L15d Effect)
                                       (#,(make-proc make-effect-clause) opnd* ...))))])
                    (begin
                      (safe-assert (eq? (primitive-type (%primitive sym)) 'effect))
                      (primitive-handler-set! (%primitive sym) (feffect 'sym)))
                    ...)]
               [else (syntax-error #'context "unrecognized context")])))]
        [(k context (sym ...) cl ...) #'(k context (sym ...) (definitions) cl ...)]
        [(k context sym cl ...) (identifier? #'sym) #'(k context (sym) (definitions) cl ...)])))

  (define info-cc-eq (make-info-condition-code 'eq? #f #t))
  (define asm-eq (asm-relop info-cc-eq))

  ; x is not the same as z in any clause that follows a clause where (x z)
  ; and y is coercible to one of its types, however:
  ; WARNING: do not assume that if x isn't the same as z then x is independent
  ; of z, since x might be an mref with z as it's base or index

  (define-instruction value (- -/ovfl -/eq)
    [(op (z ur) (x ur) (y funky12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))]
    [(op (z ur) (x funky12) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-rsb (memq op '(-/ovfl -/eq))) ,y ,x))]
    [(op (z ur) (x ur) (y negate-funky12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(-/ovfl -/eq))) ,x ,y))]
    [(op (z ur) (x ur) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(-/ovfl -/eq))) ,x ,y))])

  (define-instruction value (+ +/ovfl +/carry)
    [(op (z ur) (x ur) (y funky12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]
    [(op (z ur) (x funky12) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))]
    [(op (z ur) (x ur) (y negate-funky12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,x ,y))]
    [(op (z ur) (x negate-funky12) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (memq op '(+/ovfl +/carry))) ,y ,x))]
    [(op (z ur) (x ur) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))])

  (define-instruction value (*)
    ; no imm form available
    [(op (z ur) (x ur) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,asm-mul ,x ,y))])

  (define-instruction value (*/ovfl) ; z flag set iff no overflow
    ; no imm form available
    [(op (z ur) (x ur) (y ur))
     (let ([u (make-tmp 'u)])
       (seq
         `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
         `(set! ,(make-live-info) ,z (asm ,null-info ,asm-smull ,x ,y ,u))
         `(asm ,null-info ,(asm-cmp/shift 31 'sra) ,u ,z)))])

  ; NB: only on ARMv7VE implementations
  #;(define-instruction value (/)
    ; does not affect condition codes
    [(op (z ur) (x ur) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,asm-div ,x ,y))])

  (define-instruction value (logand)
    [(op (z ur) (x ur) (y funky12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))]
    [(op (z ur) (x funky12) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,y ,x))]
    [(op (z ur) (x ur) (y lognot-funky12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-bic #f) ,x ,y))]
    [(op (z ur) (x lognot-funky12) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-bic #f) ,y ,x))]
    [(op (z ur) (x ur) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-logand #f) ,x ,y))])

  (let ()
    (define select-op (lambda (op) (if (eq? op 'logor) asm-logor asm-logxor)))
    (define-instruction value (logor logxor)
      [(op (z ur) (x funky12) (y ur))
       `(set! ,(make-live-info) ,z (asm ,info ,((select-op op) #f) ,y ,x))]
      [(op (z ur) (x ur) (y funky12 ur))
       `(set! ,(make-live-info) ,z (asm ,info ,((select-op op) #f) ,x ,y))]))

  (define-instruction value (lognot)
    [(op (z ur) (x ur))
     `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,x))])

  (define-instruction value (sll srl sra)
    [(op (z ur) (x ur) (y ur shift-count))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-shiftop op) ,x ,y))])

  (define-instruction value (move)
    [(op (z mem) (x ur))
     `(set! ,(make-live-info) ,z ,x)]
    [(op (z ur) (x ur mem imm))
     `(set! ,(make-live-info) ,z ,x)])

  (define-instruction value lea1
    ; NB: would be simpler if offset were explicit operand
    ; NB: why not one version of lea with %zero for y in lea1 case?
    [(op (z ur) (x ur))
     (begin
       (let ([offset (info-lea-offset info)])
         (if (funky12 offset)
             `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x (immediate ,offset)))
             (let ([u (make-tmp 'u)])
               (seq
                 `(set! ,(make-live-info) ,u (immediate ,offset))
                 `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x ,u)))))))])

  (define-instruction value lea2
    ; NB: would be simpler if offset were explicit operand
    [(op (z ur) (x ur) (y ur))
     (let ([offset (info-lea-offset info)] [u (make-tmp 'u)])
       (seq
         (if (funky12 offset)
             `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,y (immediate ,offset)))
             (seq
               `(set! ,(make-live-info) ,u (immediate ,offset))
               `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,u ,y))))
         `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x ,u))))])

  (define-instruction value (sext8 sext16 zext8 zext16)
    [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,info ,(asm-move/extend op) ,x))])

  (let ()
    (define imm-zero (with-output-language (L15d Triv) `(immediate 0)))
    (define load/store
      (lambda (x y w imm8? k) ; x ur, y ur, w ur or imm
        (with-output-language (L15d Effect)
          (if (ur? w)
              (if (eq? y %zero)
                  (k x w imm-zero)
                  (let ([u (make-tmp 'u)])
                    (seq
                      `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w))
                      (k x u imm-zero))))
              (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])])
                (cond
                  [(if imm8?
                       (or (unsigned8? n) (unsigned8? (- n)))
                       (or (unsigned12? n) (unsigned12? (- n))))
                   (let ([w (in-context Triv `(immediate ,n))])
                     (if (or (eq? y %zero) (fx= n 0))
                         (k x y w)
                         (let ([u (make-tmp 'u)])
                           (seq
                             `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y))
                             (k u %zero w)))))]
                  [(funky12 n) =>
                   ; NB: dubious value?  check to see if it's exercised
                   (lambda (n)
                     (let ([u (make-tmp 'u)])
                       (seq
                         `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,n)))
                         (k u y imm-zero))))]
                  [(funky12 (- n)) =>
                   ; NB: dubious value?  check to see if it's exercised
                   (lambda (n)
                     (let ([u (make-tmp 'u)])
                       (seq
                         `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-sub #f) ,x (immediate ,n)))
                         (k u y imm-zero))))]
                  [else 
                   (let ([u (make-tmp 'u)])
                     (seq
                       `(set! ,(make-live-info) ,u (immediate ,n))
                       (if (eq? y %zero)
                           (k x u imm-zero)
                           (seq
                             `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,u))
                             (k u y imm-zero)))))]))))))
    (define-instruction value (load)
      [(op (z ur) (x ur) (y ur) (w ur imm-constant))
       (let ([type (info-load-type info)])
         (load/store x y w (memq type '(integer-16 unsigned-16 integer-8))
           (lambda (x y w)
             (let ([instr `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-load type) ,x ,y ,w))])
               (if (info-load-swapped? info)
                   (seq
                     instr
                     `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-swap type) ,z)))
                   instr)))))])
    (define-instruction effect (store)
      [(op (x ur) (y ur) (w ur imm-constant) (z ur))
       (let ([type (info-load-type info)])
         (load/store x y w (memq type '(integer-16 unsigned-16))
           (lambda (x y w)
             (if (info-load-swapped? info)
                 (let ([u (make-tmp 'unique-bob)])
                   (seq
                     `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-swap type) ,z))
                     `(asm ,null-info ,(asm-store type) ,x ,y ,w ,u)))
                 `(asm ,null-info ,(asm-store type) ,x ,y ,w ,z)))))]))

  (let ()
    (define pick-asm-op
      (lambda (op info)
        (let ([flreg (info-loadfl-flreg info)])
          (case op
            [(load-single->double load-double->single) (asm-fl-load/cvt op flreg)]
            [(store-single->double) (asm-fl-store/cvt op flreg)]
            [else (asm-fl-load/store op flreg)]))))
    (define-instruction effect (load-single->double load-double->single store-single->double
                                 store-single store-double
                                 load-single load-double)
      [(op (x ur) (y ur) (z uword8))
       (if (eq? y %zero)
           `(asm ,info ,(pick-asm-op op info) ,x ,z)
           (let ([u (make-tmp 'u)])
             (seq
               `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,y))
               `(asm ,info ,(pick-asm-op op info) ,u ,z))))]
      [(op (x ur) (y ur) (z ur))
       (let ([u (make-tmp 'u)])
         (seq
           `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,x ,z))
           (if (eq? y %zero)
               `(asm ,info ,(pick-asm-op op info) ,u (immediate 0))
               (seq
                 `(set! ,(make-live-info) ,u (asm ,info ,(asm-add #f) ,u ,y))
                 `(asm ,info ,(pick-asm-op op info) ,u (immediate 0))))))]))

  (let ()
    ; vldr, vstr allow only word offsets, and we require byte offset due to the type tag
    (module (with-flonum-data-pointers)
      (define $flonum-data-pointer
        (lambda (x p)
          (with-output-language (L15d Effect)
            (let ([u (make-tmp 'u)])
              (seq
                `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,(constant flonum-data-disp))))
                (p u))))))
      (define-syntax with-flonum-data-pointers
        (syntax-rules ()
          [(_ () e1 e2 ...) (begin e1 e2 ...)]
          [(_ (x1 x2 ...) e1 e2 ...)
           ($flonum-data-pointer x1
             (lambda (x1)
               (with-flonum-data-pointers (x2 ...) e1 e2 ...)))])))

    (define-instruction effect (flt)
      [(op (x ur) (y ur))
       (with-flonum-data-pointers (y)
         `(asm ,info ,asm-flt ,x ,y))])

    (define-instruction effect (fl+ fl- fl/ fl*)
      [(op (x ur) (y ur) (z ur))
       (with-flonum-data-pointers (x y z)
         `(asm ,info ,(asm-flop-2 op) ,x ,y ,z))])

    (define-instruction effect (flsqrt)
      [(op (x ur) (y ur))
       (with-flonum-data-pointers (x y)
         `(asm ,info ,asm-flsqrt ,x ,y))])

    (define-instruction value (trunc)
      [(op (z ur) (x ur))
       (with-flonum-data-pointers (x)
         `(set! ,(make-live-info) ,z (asm ,info ,asm-trunc ,x)))])

    (define-instruction pred (fl= fl< fl<=)
      [(op (x ur) (y ur))
       (with-flonum-data-pointers (x y)
         (let ([info (make-info-condition-code op #f #f)])
           (values '() `(asm ,info ,(asm-fl-relop info) ,x ,y))))]))

  (define-instruction effect (inc-cc-counter)
    [(op (x ur) (w ur funky12) (z funky12 ur))
     (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
       (seq
         `(set! ,(make-live-info) ,u1 (asm ,null-info ,(asm-add #f) ,x ,w))
         `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
         `(asm ,null-info ,asm-inc-cc-counter ,u1 ,z ,u2)))])

  (define-instruction effect (inc-profile-counter)
    [(op (x mem) (y ur funky12))
     (let ([u (make-tmp 'u)])
       (seq
         `(set! ,(make-live-info) ,u ,x)
         `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,u ,y))
         `(set! ,(make-live-info) ,x ,u)))])

  (define-instruction value (read-time-stamp-counter)
    [(op (z ur)) `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-read-counter 1)))])

  (define-instruction value (read-performance-monitoring-counter)
    [(op (z ur) (x unsigned8))
     ; could require unsigned1 and skip the fxmin...but no point burdening instruction scheduler with an additional one-off type
     (let ([imm (nanopass-case (L15d Triv) x [(immediate ,imm) (fxmin imm 1)])])
       `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-read-counter (fx+ imm 2)))))]
    [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-read-counter) ,x))])

  ;; no kills since we expect to be called when all necessary state has already been saved
  (define-instruction value (get-tc)
    [(op (z ur))
     (safe-assert (eq? z %Cretval))
     (let ([u (make-tmp 'u)] [ulr (make-precolored-unspillable 'ulr %lr)])
       (seq
         `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
         `(set! ,(make-live-info) ,z (asm ,info ,asm-get-tc ,u ,ulr))))])

  (define-instruction value (asmlibcall)
    [(op (z ur))
     (let ([u (make-tmp 'u)])
       (if (info-asmlib-save-ra? info)
           (seq
             `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
             `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info) #t) ,u ,(info-kill*-live*-live* info) ...)))
           (let ([ulr (make-precolored-unspillable 'ulr %lr)])
             (seq
               `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
               `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
               `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info) #f) ,u ,ulr ,(info-kill*-live*-live* info) ...))))))])

  (define-instruction effect (asmlibcall!)
    [(op)
     (let ([u (make-tmp 'u)])
       (if (info-asmlib-save-ra? info)
           (let ([ulr (make-precolored-unspillable 'ulr %lr)])
             (seq
               `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
               `(asm ,info ,(asm-library-call! (info-asmlib-libspec info) #t) ,u ,(info-kill*-live*-live* info) ...)))
           (let ([ulr (make-precolored-unspillable 'ulr %lr)])
             (seq
               `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
               `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
               `(asm ,info ,(asm-library-call! (info-asmlib-libspec info) #f) ,u ,ulr ,(info-kill*-live*-live* info) ...)))))])

  (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
  (define-instruction effect (c-simple-call)
    [(op)
     (let ([u (make-tmp 'u)])
       (if (info-c-simple-call-save-ra? info)
           (seq
             `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
             `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info) #t) ,u))
           (let ([ulr (make-precolored-unspillable 'ulr %lr)])
             (seq
               `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
               `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
               `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info) #f) ,u ,ulr)))))])

  (define-instruction pred (eq? u< < > <= >=)
    [(op (y funky12) (x ur))
     (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #t #t))])
       (values '() `(asm ,info ,(asm-relop info) ,x ,y)))]
    [(op (x ur) (y ur funky12))
     (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #f #t))])
       (values '() `(asm ,info ,(asm-relop info) ,x ,y)))])

  (define-instruction pred (condition-code)
    [(op) (values '() `(asm ,info ,(asm-condition-code info)))])

  (define-instruction pred (type-check?)
    [(op (x ur) (mask funky12 ur) (type funky12 ur))
     (let ([tmp (make-tmp 'u)])
       (values
         (with-output-language (L15d Effect)
           `(set! ,(make-live-info) ,tmp (asm ,null-info ,(asm-logand #f) ,x ,mask)))
         `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))])

  (define-instruction pred (logtest log!test)
    [(op (x funky12) (y ur))
     (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,y ,x))]
    [(op (x ur) (y ur funky12))
     (values '() `(asm ,info-cc-eq ,(asm-logtest (eq? op 'log!test) info-cc-eq) ,x ,y))])

  (let ()
    (define lea->reg
      (lambda (x y w k)
        (with-output-language (L15d Effect)
          (define add-offset
            (lambda (r)
              (if (eqv? (nanopass-case (L15d Triv) w [(immediate ,imm) imm]) 0)
                  (k r)
                  (let ([u (make-tmp 'u)])
                    (seq
                      `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,r ,w))
                      (k u))))))
          (if (eq? y %zero)
              (add-offset x)
              (let ([u (make-tmp 'u)])
                (seq
                  `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y))
                  (add-offset u)))))))
    ; NB: compiler ipmlements init-lock! and unlock! as 32-bit store of zero 
    (define-instruction pred (lock!)
      [(op (x ur) (y ur) (w funky12))
       (let ([u (make-tmp 'u)])
         (values
           (lea->reg x y w
             (lambda (r)
               (with-output-language (L15d Effect)
                 (seq
                   `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
                   `(asm ,null-info ,asm-lock ,r ,u)))))
           `(asm ,info-cc-eq ,asm-eq ,u (immediate 0))))])
    (define-instruction effect (locked-incr! locked-decr!)
      [(op (x ur) (y ur) (w funky12))
       (lea->reg x y w
         (lambda (r)
           (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
             (seq
               `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
               `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
               `(asm ,null-info ,(asm-lock+/- op) ,r ,u1 ,u2)))))])
    (define-instruction effect (cas)
      [(op (x ur) (y ur) (w funky12) (old ur) (new ur))
       (lea->reg x y w
         (lambda (r)
           (let ([u1 (make-tmp 'u1)] [u2 (make-tmp 'u2)])
             (seq
               `(set! ,(make-live-info) ,u1 (asm ,null-info ,asm-kill))
               `(set! ,(make-live-info) ,u2 (asm ,null-info ,asm-kill))
               `(asm ,info ,asm-cas ,r ,old ,new ,u1 ,u2)))))]))

  (define-instruction effect (pause)
    ; NB: user sqrt or something like that?
    [(op) '()])

  (define-instruction effect (c-call)
    [(op (x ur))
     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
       (seq
         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
         `(asm ,info ,asm-indirect-call ,x ,ulr ,(info-kill*-live*-live* info) ...)))])

  (define-instruction effect (pop-multiple)
    [(op) `(asm ,info ,(asm-pop-multiple (info-kill*-kill* info)))])

  (define-instruction effect (push-multiple)
    [(op) `(asm ,info ,(asm-push-multiple (info-kill*-live*-live* info)))])

  (define-instruction effect (vpush-multiple)
    [(op) `(asm ,info ,(asm-vpush-multiple (info-vpush-reg info) (info-vpush-n info)))])

  (define-instruction effect (vpop-multiple)
    [(op) `(asm ,info ,(asm-vpop-multiple (info-vpush-reg info) (info-vpush-n info)))])

  (define-instruction effect save-flrv
    [(op) `(asm ,info ,asm-save-flrv)])

  (define-instruction effect restore-flrv
    [(op) `(asm ,info ,asm-restore-flrv)])

  (define-instruction effect (invoke-prelude)
    [(op) `(set! ,(make-live-info) ,%tc ,%Carg1)])
)

;;; SECTION 3: assembler
(module asm-module (; required exports
                    asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump
                    asm-mul asm-smull asm-cmp/shift asm-add asm-sub asm-rsb asm-logand asm-logor asm-logxor asm-bic
                    asm-pop-multiple asm-shiftop asm-logand asm-lognot
                    asm-logtest asm-fl-relop asm-relop asm-push-multiple asm-vpush-multiple asm-vpop-multiple
                    asm-indirect-jump asm-literal-jump
                    asm-direct-jump asm-return-address asm-jump asm-conditional-jump asm-data-label asm-rp-header
                    asm-indirect-call asm-condition-code
                    asm-fl-load/store
                    asm-fl-load/cvt asm-fl-store/cvt asm-flt asm-trunc
                    asm-lock asm-lock+/- asm-cas
                    asm-flop-2 asm-flsqrt asm-c-simple-call
                    asm-save-flrv asm-restore-flrv asm-return asm-c-return asm-size
                    asm-enter asm-foreign-call asm-foreign-callable
                    asm-read-counter
                    asm-inc-cc-counter
                    funky12
                    shift-count? unsigned8? unsigned12?
                    ; threaded version specific
                    asm-get-tc
                    ; machine dependent exports
                    asm-kill
                    info-vpush-reg info-vpush-n)

  (define-record-type info-vpush (nongenerative)
    (parent info)
    (sealed #t)
    (fields reg n))

  (define ax-register?
    (case-lambda
      [(x) (record-case x [(reg) r #t] [else #f])]
      [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])]))

  (define-who ax-ea-reg-code
    (lambda (ea)
      (record-case ea
        [(reg) r (reg-mdinfo r)]
        [else (sorry! who "ea=~s" ea)])))

  (define ax-register-list
    (lambda (r*)
      (fold-left
        (lambda (a r) (fx+ a (fxsll 1 (reg-mdinfo r))))
        0 r*)))

  (define ax-reg?
    (lambda (ea)
      (record-case ea
        [(reg) ignore #t]
        [else #f])))

  (define ax-imm?
    (lambda (ea)
      (record-case ea
        [(imm) ignore #t]
        [else #f])))

  (define-who ax-imm-data
    (lambda (ea)
      (record-case ea
        [(imm) (n) n]
        [else (sorry! who "ax-imm-data ea=~s" ea)])))

  ; define-op sets up assembly op macros--
  ; the opcode and all other expressions are passed to the specified handler--
  (define-syntax define-op
    (lambda (x)
      (syntax-case x ()
        [(k op handler e ...)
         (with-syntax ([op (construct-name #'k "asmop-" #'op)])
           #'(define-syntax op
               (syntax-rules ()
                 [(_ mneu arg (... ...))
                  (handler 'mneu e ... arg (... ...))])))])))

  (define-syntax emit
    (lambda (x)
      (syntax-case x ()
        [(k op x ...)
         (with-syntax ([emit-op (construct-name #'k "asmop-" #'op)])
           #'(emit-op op x ...))])))

  ;;; note that the assembler isn't clever--you must be very explicit about
  ;;; which flavor you want, and there are a few new varieties introduced
  ;;; (commented-out opcodes are not currently used by the assembler--
  ;;; spaces are left to indicate possible size extensions)

  (define-op movi1  movi-a1-op  #b00111010)
  (define-op mvni   movi-a1-op  #b00111110)
  (define-op movi2  movi-a2-op  #b00110000) ; ARMv6T, ARMv7
  (define-op movt   movi-a2-op  #b00110100) ; ARMv6T, ARMv7

  (define-op addi  binary-imm-op  #b0010100)
  (define-op addci binary-imm-op  #b0010101)
  (define-op subi  binary-imm-op  #b0010010)
  (define-op rsbi  binary-imm-op  #b0010011)
  (define-op andi  binary-imm-op  #b0010000)
  (define-op orri  binary-imm-op  #b0011100)
  (define-op eori  binary-imm-op  #b0010001)
  (define-op bici  binary-imm-op  #b0011110)

  (define-op add   binary-op      #b0000100)
  (define-op sub   binary-op      #b0000010)
  (define-op rsb   binary-op      #b0000011)
  (define-op and   binary-op      #b0000000)
  (define-op orr   binary-op      #b0001100)
  (define-op eor   binary-op      #b0000001)
  (define-op bic   binary-op      #b0001110)

  (define-op cmp         cmp-op         #b0001010)
  (define-op tst         cmp-op         #b0001000)
  (define-op cmp/shift   cmp-op         #b0001010)
  (define-op cmpi  cmp-imm-op     #b0011010)
  (define-op tsti  cmp-imm-op     #b0011000)

  (define-op mov unary-op        #b0001101 #f) ; note: for mov, bits 5-11 must be zero, corresponding to 00 shift type and 00000 shift count
  (define-op mvn unary-op        #b0001111 #f)

  (define-op shifti shifti-op)
  (define-op shift shift-op)

  (define-op sxtb extend-op      #b01101010)
  (define-op sxth extend-op      #b01101011)
  (define-op uxtb extend-op      #b01101110)
  (define-op uxth extend-op      #b01101111)

  (define-op mul  mul-op         #b0000000)
  (define-op smull  mull-op      #b0000110)

  (define-op ldri    load-imm-op #b1 #b0 #b010 #b0 #b1)
  (define-op ldrbi   load-imm-op #b1 #b0 #b010 #b1 #b1)
  (define-op stri    load-imm-op #b1 #b0 #b010 #b0 #b0)
  (define-op strbi   load-imm-op #b1 #b0 #b010 #b1 #b0)

  (define-op str/preidx load-imm-op #b1 #b1 #b010 #b0 #b0)
  (define-op ldr/postidx load-imm-op #b0 #b0 #b010 #b0 #b1)

  (define-op ldrlit  load-lit-op)

  (define-op ldrshi  load-noshift-imm-op #b1 #b1111)
  (define-op ldrhi   load-noshift-imm-op #b1 #b1011)
  (define-op ldrdi   load-noshift-imm-op #b0 #b1101)
  (define-op ldrsbi  load-noshift-imm-op #b1 #b1101)
  (define-op strhi   load-noshift-imm-op #b0 #b1011)
  (define-op strdi   load-noshift-imm-op #b0 #b1111)

  (define-op ldr     load-op     #b011 #b0 #b1)
  (define-op ldrb    load-op     #b011 #b1 #b1)
  (define-op str     load-op     #b011 #b0 #b0)
  (define-op strb    load-op     #b011 #b1 #b0)

  (define-op ldrsh   load-noshift-op #b0 #b1 #b1111)
  (define-op ldrh    load-noshift-op #b0 #b1 #b1011)
  (define-op ldrd    load-noshift-op #b0 #b0 #b1101)
  (define-op ldrsb   load-noshift-op #b0 #b1 #b1101)
  (define-op strh    load-noshift-op #b0 #b0 #b1011)
  (define-op strd    load-noshift-op #b0 #b0 #b1111)

  (define-op ldrex ldrex-op      #b00011001)
  (define-op strex strex-op      #b00011000)

  (define-op bnei  branch-imm-op       (ax-cond 'ne))
  (define-op brai  branch-imm-op       (ax-cond 'al))

  (define-op bx    branch-reg-op       (ax-cond 'al) #b0001)
  (define-op blx   branch-reg-op       (ax-cond 'al) #b0011)

  (define-op bra   branch-label-op     (ax-cond 'al))
  (define-op beq   branch-label-op     (ax-cond 'eq))
  (define-op bne   branch-label-op     (ax-cond 'ne))
  (define-op blt   branch-label-op     (ax-cond 'lt))
  (define-op ble   branch-label-op     (ax-cond 'le))
  (define-op bgt   branch-label-op     (ax-cond 'gt))
  (define-op bge   branch-label-op     (ax-cond 'ge))
  (define-op bcc   branch-label-op     (ax-cond 'cc))
  (define-op bcs   branch-label-op     (ax-cond 'cs))
  (define-op bvc   branch-label-op     (ax-cond 'vc))
  (define-op bvs   branch-label-op     (ax-cond 'vs))
  (define-op bls   branch-label-op     (ax-cond 'ls))
  (define-op bhi   branch-label-op     (ax-cond 'hi))

  (define-op popm  pm-op #b10001011)
  (define-op pushm pm-op #b10010010)
  (define-op vpushm vpm-op #b11010 #b10)
  (define-op vpopm  vpm-op #b11001 #b11)

  (define-op vldr.sgl vldr/vstr-op #b1010 #b01)
  (define-op vldr.dbl vldr/vstr-op #b1011 #b01)
  (define-op vstr.sgl vldr/vstr-op #b1010 #b00)
  (define-op vstr.dbl vldr/vstr-op #b1011 #b00)

  (define-op vmov.gpr->s32 vmov-op #b0)
  (define-op vmov.s32->gpr vmov-op #b1)

  (define-op vcvt.sgl->dbl vcvt-op #b01 #b110111)
  (define-op vcvt.dbl->sgl vcvt-op #b11 #b110111)
  (define-op vcvt.s32->dbl vcvt-op #b11 #b111000)
  (define-op vcvt.dbl->s32 vcvt-op #b11 #b111101)

  (define-op vcmp vcmp-op)
  (define-op fpscr->apsr fpscr->apsr-op)

  (define-op rev   rev-op #b01101011 #b0011)
  (define-op rev16 rev-op #b01101011 #b1011)
  (define-op revsh rev-op #b01101111 #b1011)

  (define-op mrs mrs-op)
  (define-op msr msr-op)

  (define-op mcr mrc/mcr-op #b0)
  (define-op mrc mrc/mcr-op #b1)

  (define-op vadd vadd-op #b11 #b0 #b11100)
  (define-op vsub vadd-op #b11 #b1 #b11100)
  (define-op vmul vadd-op #b10 #b0 #b11100)
  (define-op vdiv vadd-op #b00 #b0 #b11101)

  (define-op vsqrt vsqrt-op)

  (define-who movi-a1-op
    (lambda (op opcode dest-ea f12 code*)
      (emit-code (op dest-ea f12 code*) ; encoding A1
        [28 (ax-cond 'al)]
        [20 opcode]
        [16 #b0000]
        [12 (ax-ea-reg-code dest-ea)]
        [0  f12])))

  (define-who movi-a2-op ; ARMv6T, ARMv7
    (lambda (op opcode dest-ea u16 code*)
      (emit-code (op dest-ea u16 code*) ; movi encoding A2
        [28 (ax-cond 'al)]
        [20 opcode]
        [16 (fxsrl u16 12)]
        [12 (ax-ea-reg-code dest-ea)]
        [0  (fxlogand u16 #xfff)])))

  (define shift-op
    (lambda (op dest-ea src0-ea src1-ea shift-type code*)
      (emit-code (shift-type dest-ea src0-ea src1-ea code*)
        [28 (ax-cond 'al)]
        [21 #b0001101]
        [20 #b0]
        [16 #b0000]
        [12 (ax-ea-reg-code dest-ea)]
        [8  (ax-ea-reg-code src1-ea)]
        [7  #b0]
        [5  (ax-shift-type shift-type)]
        [4  #b1]
        [0  (ax-ea-reg-code src0-ea)])))

  (define shifti-op
    (lambda (op dest-ea src0-ea n shift-type code*)
      (emit-code (shift-type dest-ea src0-ea n code*)
        [28 (ax-cond 'al)]
        [21 #b0001101]
        [20 #b0] 
        [16 #b0000]
        [12 (ax-ea-reg-code dest-ea)]
        [7  n]
        [5  (ax-shift-type shift-type)]
        [4  #b0]
        [0  (ax-ea-reg-code src0-ea)])))

  (define pm-op
    (lambda (op opcode regs code*)
      (emit-code (op regs code*)
        [28 (ax-cond 'al)]
        [20 opcode]
        [16 #b1101]
        [0  (ax-register-list regs)])))

  (define binary-imm-op ; 12-bit immediate
    (lambda (op opcode set-cc? dest-ea opnd-ea n code*)
      (emit-code (op set-cc? dest-ea opnd-ea n code*)
        [28 (ax-cond 'al)]
        [21 opcode]
        [20 (if set-cc? #b1 #b0)]
        [16 (ax-ea-reg-code opnd-ea)]
        [12 (ax-ea-reg-code dest-ea)]
        [0 (or (funky12 n)
                ($oops 'assembler-internal
                       "binary-imm-op n=~s" n))])))

  (define binary-op
    (lambda (op opcode set-cc? dest-ea opnd0-ea opnd1-ea code*)
      (emit-code (op set-cc? dest-ea opnd0-ea opnd1-ea code*)
        [28 (ax-cond 'al)]
        [21 opcode]
        [20 (if set-cc? #b1 #b0)] 
        [16 (ax-ea-reg-code opnd0-ea)]
        [12 (ax-ea-reg-code dest-ea)]
        [7  #b00000] ; shift value
        [5  #b00]    ; shift type
        [4  #b0]
        [0  (ax-ea-reg-code opnd1-ea)])))

  (define mull-op
    (lambda (op opcode destlo-ea desthi-ea opnd0-ea opnd1-ea code*)
      (emit-code (op destlo-ea desthi-ea opnd0-ea opnd1-ea code*)
        [28 (ax-cond 'al)]
        [21 opcode]
        [20 #b0]  ; don't need no stinking z & n bits
        [16 (ax-ea-reg-code desthi-ea)]
        [12 (ax-ea-reg-code destlo-ea)]
        [8  (ax-ea-reg-code opnd1-ea)]
        [4  #b1001]
        [0  (ax-ea-reg-code opnd0-ea)])))

  (define unary-op
    (lambda (op opcode set-cc? dest-ea opnd-ea code*)
      (emit-code (op set-cc? dest-ea opnd-ea code*)
        [28 (ax-cond 'al)]
        [21 opcode]
        [20 (if set-cc? #b1 #b0)] 
        [16 #b0000]
        [12 (ax-ea-reg-code dest-ea)]
        [7  #b00000] ; shift value
        [5  #b00]    ; shift type
        [4  #b0]
        [0  (ax-ea-reg-code opnd-ea)])))

  (define cmp-op
    (case-lambda
      [(op opcode opnd0-ea opnd1-ea code*)
       (emit-code (op opnd0-ea opnd1-ea code*)
         [28 (ax-cond 'al)]
         [21 opcode]
         [20 #b1]
         [16 (ax-ea-reg-code opnd0-ea)]
         [12 #b0000]
         [7  #b00000] ; shift value
         [5  (ax-shift-type 'sll)]
         [4  #b0]
         [0  (ax-ea-reg-code opnd1-ea)])]
      [(op opcode shift-count shift-type opnd0-ea opnd1-ea code*)
       (emit-code (op opnd0-ea shift-type opnd1-ea shift-count code*)
         [28 (ax-cond 'al)]
         [21 opcode]
         [20 #b1]
         [16 (ax-ea-reg-code opnd0-ea)]
         [12 #b0000]
         [7  shift-count] ; shift value
         [5  (ax-shift-type shift-type)]
         [4  #b0]
         [0  (ax-ea-reg-code opnd1-ea)])]))

  (define cmp-imm-op
    (lambda (op opcode opnd-ea n code*)
      (emit-code (op opnd-ea n code*)
        [28 (ax-cond 'al)]
        [21 opcode]
        [20 #b1] 
        [16 (ax-ea-reg-code opnd-ea)]
        [12 #b0000]
        [0  (funky12 n)])))

  (define extend-op
    (lambda (op opcode dest-ea opnd-ea code*)
      (emit-code (op dest-ea opnd-ea code*)
        [28 (ax-cond 'al)]
        [20 opcode]
        [16 #b1111] 
        [12 (ax-ea-reg-code dest-ea)]
        [10 #b00] ; ROR value (0, 8, 16, 24)
        [4  #b000111]
        [0  (ax-ea-reg-code opnd-ea)])))

  (define mul-op
    (lambda (op opcode set-cc? dest-ea opnd0-ea opnd1-ea code*)
      (emit-code (op set-cc? dest-ea opnd0-ea opnd1-ea code*)
        [28 (ax-cond 'al)]
        [21 opcode]
        [20 (if set-cc? #b1 #b0)] 
        [16 (ax-ea-reg-code dest-ea)]
        [12 #b0000]
        [8  (ax-ea-reg-code opnd1-ea)]
        [4  #b1001]
        [0 (ax-ea-reg-code opnd0-ea)])))

  (define ldrex-op
    (lambda (op opcode dest-ea opnd-ea code*)
      (emit-code (op dest-ea opnd-ea code*)
        [28 (ax-cond 'al)]
        [20 opcode]
        [16 (ax-ea-reg-code opnd-ea)]
        [12 (ax-ea-reg-code dest-ea)]
        [8  #b1111]
        [4  #b1001]
        [0  #b1111])))

  (define strex-op
    (lambda (op opcode dest-ea opnd0-ea opnd1-ea code*)
      (emit-code (op dest-ea opnd0-ea opnd1-ea code*)
        [28 (ax-cond 'al)]
        [20 opcode]
        [16 (ax-ea-reg-code opnd1-ea)]
        [12 (ax-ea-reg-code dest-ea)]
        [8  #b1111]
        [4  #b1001]
        [0  (ax-ea-reg-code opnd0-ea)])))

  (define branch-imm-op
    (lambda (op cond-bits disp code*)
      (emit-code (op disp code*)
        [28 cond-bits]
        [24 #b1010]
        [0  (fxlogand disp #xffffff)])))

  (define-who branch-label-op
    (lambda (op cond-bits dest code*)
      (record-case dest
        [(label) (offset l)
         (emit-code (op dest code*)
           [28 cond-bits]
           [24 #b1010]
           [0  (fxlogand (fxsrl (fx- offset 4) 2) #xffffff)])]
        [else (sorry! who "unexpected dest ~s" dest)])))

  (define-who branch-reg-op
    (lambda (op condition-code opcode dest code*)
      (emit-code (op dest code*)
        [28 condition-code]
        [20 #b00010010]
        [8  #b111111111111]
        [4  opcode]
        [0  (ax-ea-reg-code dest)])))

  (define mrs-op
    (lambda (op dest code*)
      (emit-code (op dest code*)
        [28 (ax-cond 'al)]
        [16 #b000100001111]
        [12 (ax-ea-reg-code dest)]
        [0  #b000000000000])))

  (define msr-op
    (lambda (op mask src code*)
      (emit-code (op mask src code*)
        [28 (ax-cond 'al)]
        [20 #b00010010]
        [18 mask]
        [4  #b00111100000000]
        [0 (ax-ea-reg-code src)])))

  (define-who mrc/mcr-op
    (lambda (op dir cond coproc opc1 dest-ea CRn CRm opc2 code*)
      (emit-code (op cond coproc opc1 dest-ea CRn CRm opc2 code*) ; encoding A1
        [28 (ax-cond cond)]
        [24 #b1110]
        [21 opc1]
        [20 dir]
        [16 CRn]
        [12 (ax-ea-reg-code dest-ea)]
        [8 coproc]
        [5 opc2]
        [4 1]
        [0 CRm])))

  (define vldr/vstr-op
    (lambda (op opc1 opc2 flreg reg offset code*)
      (let-values ([(d vd) (ax-flreg->bits flreg)])
        (emit-code (op flreg reg offset code*)
          [28 (ax-cond 'al)]
          [24 #b1101]
          ; NB: what's the source of the following comment?
          [23 #b1] ; U bit for adding or subtracting offset. using SP requires offset #-0
          [22 d]
          [20 opc2]
          [16 (ax-ea-reg-code reg)]
          [12 vd]
          [8  opc1]
          [0  (fxsrl offset 2)]))))

  (define vmov-op
    (lambda (op dir flreg gpreg code*)
      (let-values ([(n vn) (ax-flreg->bits flreg)])
        (emit-code (op flreg gpreg code*)
          [28 (ax-cond 'al)]
          [21 #b1110000]
          [20 dir]
          [16 vn]
          [12 (ax-ea-reg-code gpreg)]
          [8  #b1010]
          [7  n]
          [0  #b0010000]))))

  (define vcvt-op
    (lambda (op szop opc2 dest src code*)
      (let-values ([(d vd) (ax-flreg->bits dest)]
                   [(m vm) (ax-flreg->bits src)])
        (emit-code (op dest src code*)
          [28 (ax-cond 'al)]
          [23 #b11101]
          [22 d]
          [16 opc2]
          [12 vd]
          [9  #b101]
          [7  szop]
          [6  #b1]
          [5  m]
          [4  #b0]
          [0  vm]))))

  (define vcmp-op
    (lambda (op src1 src2 code*)
      (let-values ([(d vd) (ax-flreg->bits src1)]
                   [(m vm) (ax-flreg->bits src2)])
        (emit-code (op src1 src2 code*)
          [28 (ax-cond 'al)]
          [23 #b11101]
          [22 d]
          [16 #b110100]
          [12 vd]
          [9  #b101]
          [6  #b101]
          [5  m]
          [4  #b0]
          [0  vm]))))

  (define fpscr->apsr-op
    (lambda (op code*)
      (emit-code (op code*)
        [28 (ax-cond 'al)]
        [16 #b111011110001]
        [12 #b1111]
        [0  #b101000010000])))

  (define vpm-op
    (lambda (op opcode opcode2 flreg n code*)
      (let-values ([(d vd) (ax-flreg->bits flreg)])
        (emit-code (op flreg n code*)
          [28 (ax-cond 'al)]
          [23 opcode]
          [22 d]
          [20 opcode2]
          [16 #b1101]
          [12 vd]
          [8  #b1011]
          [0  (fxsll n 1)]))))

  (define rev-op
    (lambda (op opcode1 opcode2 dest-ea src-ea code*)
      (emit-code (op dest-ea src-ea code*)
        [28 (ax-cond 'al)]
        [20 opcode1]
        [16 #b1111]
        [12 (ax-ea-reg-code dest-ea)]
        [8  #b1111]
        [4  opcode2]
        [0  (ax-ea-reg-code src-ea)])))

  (define load-op
    (lambda (op opcode1 opcode2 opcode3 dest-ea base-ea index-ea code*)
      (emit-code (op dest-ea base-ea index-ea code*)
        [28 (ax-cond 'al)]
        [25 opcode1]
        [24 #b1] ; P "Pay attention to index register"
        [23 #b1] ; U "Upward (add index)"
        [22 opcode2]
        [21 #b0] ; W "Write back" (post-increment/decrement)
        [20 opcode3]
        [16 (ax-ea-reg-code base-ea)]
        [12 (ax-ea-reg-code dest-ea)]
        [7  #b00000] ; shift amount
        [5  #b00]    ; shift type
        [4  #b0]
        [0  (ax-ea-reg-code index-ea)])))

  (define load-noshift-op
    (lambda (op opcode1 opcode2 opcode3 dest-ea base-ea index-ea code*)
      (emit-code (op dest-ea base-ea index-ea code*)
        [28 (ax-cond 'al)]
        [25 #b000]
        [24 #b1] ; P "Pay attention to index register"
        [23 #b1] ; U "Upward (add index)"
        [22 opcode1]
        [21 #b0] ; W "Write back" (post-increment/decrement)
        [20 opcode2]
        [16 (ax-ea-reg-code base-ea)]
        [12 (ax-ea-reg-code dest-ea)]
        [8  #b0000]
        [4  opcode3]
        [0  (ax-ea-reg-code index-ea)])))

  (define load-imm-op
    (lambda (op P W opcode1 opcode2 opcode3 dest-ea base-ea orig-n code*)
      (let-values ([(U n) (if (fx< orig-n 0) (values 0 (fx- orig-n)) (values 1 orig-n))])
        (emit-code (op dest-ea base-ea orig-n code*)
          [28 (ax-cond 'al)]
          [25 opcode1]
          [24 P] ; P "Pay attention to index register"
          [23 U]   ; U "Upward (add index)"
          [22 opcode2]
          [21 W] ; W "Write back" (post-increment/decrement)
          [20 opcode3]
          [16 (ax-ea-reg-code base-ea)]
          [12 (ax-ea-reg-code dest-ea)]
          [0  n]))))

  (define load-noshift-imm-op
    (lambda (op opcode1 opcode2 dest-ea base-ea orig-n code*)
      (let-values ([(U n) (if (fx< orig-n 0) (values 0 (fx- orig-n)) (values 1 orig-n))])
        (emit-code (op dest-ea orig-n code*)
          [28 (ax-cond 'al)]
          [25 #b000]
          [24 #b1] ; P "Pay attention to index register"
          [23 U]   ; U "Upward (add index)"
          [22 #b1]
          [21 #b0] ; W "Write back" (post-increment/decrement)
          [20 opcode1]
          [16 (ax-ea-reg-code base-ea)]
          [12 (ax-ea-reg-code dest-ea)]
          [8  (fxsrl n 4)]
          [4  opcode2]
          [0  (fxlogand n #xf)]))))
  
  (define load-lit-op
    (lambda (op dest-ea orig-disp code*)
      (let-values ([(U disp) (if (fx< orig-disp 0) (values 0 (fx- orig-disp)) (values 1 orig-disp))])
        (emit-code (op dest-ea orig-disp code*)
          [28 (ax-cond 'al)]
          [25 #b010]
          [24 #b1]
          [23 U]   ; U "Upward (add index)"
          [22 #b0]
          [21 #b0]
          [20 #b1]
          [16 #b1111]
          [12 (ax-ea-reg-code dest-ea)]
          [0  disp]))))

  (define vadd-op
    (lambda (op opcode1 opcode2 opcode3 dest opnd1 opnd2 code*)
      (let-values ([(d vd) (ax-flreg->bits dest)]
                   [(n vn) (ax-flreg->bits opnd1)]
                   [(m vm) (ax-flreg->bits opnd2)])
        (emit-code (op dest opnd1 opnd2 code*)
          [28 (ax-cond 'al)]
          [23 opcode3]
          [22 d]
          [20 opcode1]
          [16 vn]
          [12 vd]
          [9  #b101]
          [8  #b1]   ;; sz = 1 for double
          [7  n]
          [6  opcode2]
          [5  m]
          [4  #b0]
          [0  vm]))))

  (define vsqrt-op
    (lambda (op dest src code*)
      (let-values ([(d vd) (ax-flreg->bits dest)]
                   [(m vm) (ax-flreg->bits src)])
        (emit-code (op dest src code*)
          [28 (ax-cond 'al)]
          [23 #b11101]
          [22 d]
          [20 #b11]
          [16 #b0001]
          [12 vd]
          [9  #b101]
          [8  #b1]   ;; sz = 1 for double
          [7  #b1]
          [6  #b1]
          [5  m]
          [4  #b0]
          [0  vm]))))

  ; asm helpers

  (define-who ax-cond
    (lambda (x)
      (case x
        [(eq) #b0000] ; fl=
        [(ne) #b0001]
        [(cs) #b0010] ; u<
        [(cc) #b0011] ; u>=, fl< (for fl<, do we need this and mi?)
        [(mi) #b0100] ; fl< (for fl<, do we need this and cc?)
        [(pl) #b0101]
        [(vs) #b0110]
        [(vc) #b0111]
        [(hi) #b1000] ; u>
        [(ls) #b1001] ; u<=, fl<=
        [(ge) #b1010] ; fl>=
        [(lt) #b1011]
        [(gt) #b1100] ; fl>
        [(le) #b1101]
        [(al) #b1110]
        [else (sorry! who "unrecognized cond name ~s" x)])))

  (define-who ax-shift-type
    (lambda (op)
      (case op
        [(sll) #b00]
        [(srl) #b01]
        [(sra) #b10]
        [(ror) #b11]
        [else ($oops who "unsupported op ~s" op)])))

  (define ax-flreg->bits
    (lambda (flreg)
      (let ([n (reg-mdinfo flreg)])
        (if (fx< n 32)
            (values (fxlogand n 1) (fxsrl n 1))
            (values (fxsrl n 4) (fxlogand n #b1111))))))

  (define-syntax emit-code
    (lambda (x)
      ; NB: probably won't need emit-code to weed out #f
      (define build-maybe-cons*
        (lambda (e* e-ls)
          (if (null? e*)
              e-ls
              #`(let ([t #,(car e*)] [ls #,(build-maybe-cons* (cdr e*) e-ls)])
                  (if t (cons t ls) ls)))))
      (syntax-case x ()
        [(_ (op opnd ... ?code*) chunk ...)
         (build-maybe-cons* #'((build long (byte-fields chunk ...)))
           #'(aop-cons* `(asm ,op ,opnd ...) ?code*))])))
  
  #;(define-syntax emit-code
    (lambda (x)
      (syntax-case x ()
        [(_ (op opnd ... ?code*) chunk ...)
         (fold-right cons #'(aop-cons* `(asm ,op ,opnd ...) ?code*)
           #'((build long (byte-fields chunk ...))))])))

  (define-who ax-size-code
    (lambda (x)
      (case x
        [(byte) 0]
        [(word) 1]
        [(long) 1]
        [else (sorry! who "invalid size ~s" x)])))

  (define-syntax build
    (syntax-rules ()
      [(_ x e)
       (and (memq (datum x) '(byte word long)) (integer? (datum e)))
       (quote (x . e))]
      [(_ x e)
       (memq (datum x) '(byte word long))
       (cons 'x e)]))

  (define-syntax byte-fields
    ; NB: make more efficient for fixnums
    (syntax-rules ()
      [(byte-fields (n e) ...)
       (andmap fixnum? (datum (n ...)))
       (+ (bitwise-arithmetic-shift-left e n) ...)]))

  (define ax-byte-size?
    (lambda (n)
      (<= -128 n 127)))

  (define ax-range?
    (lambda (low x high)
      (record-case x
        [(imm) (n) (<= low n high)]
        [else #f])))

  (define ax-ea-branch-disp
    (lambda (dest-ea)
      (record-case dest-ea
        [(literal) stuff (cons 'rel stuff)]
        [else ($oops 'assembler-internal
                "ax-ea-branch-disp dest-ea=~s" dest-ea)])))

  (define funky12
    (lambda (n)
      (define (try limit n)
        (let* ([k (fxlogand (bitwise-first-bit-set n) (fxlognot 1))]
               [n (bitwise-arithmetic-shift-right n k)])
          (and (and (fixnum? n) (#%$fxu< n #x100))
               (fxlogor (fxsll (fx- limit k) 7) n))))
      (if (and (fixnum? n) (#%$fxu< n #x100))
          n
          (and (<= (- (expt 2 31)) n (- (expt 2 32) 1)) ; bounds check lets caller be sloppy about, e.g., NOT-ing or negating input
               (let ([n (if (< n 0) (+ (expt 2 32) n) n)])
                 (or (try 32 n)
                     (try 8
                       (logor
                         (bitwise-arithmetic-shift-left (logand n #xffffff) 8)
                         (bitwise-arithmetic-shift-right n 24)))))))))

  ;; restrict funky12 so that an code offset n will not fit
  ;; if a smaller offset wouldn't fit, which prevents bouncing
  ;; in the loop that computes label offsets
  (define code-offset-funky12
    (lambda (n)
      (safe-assert (and (fixnum? n) (fx= 0 (fxand n 3))))
      (and (fixnum? n)
           (#%$fxu< n #x400)
           (funky12 n))))

  (define shift-count?
    (lambda (imm)
      ; can also allow 0 for lsl and 32 (represented as 0) for lsr, asr
      ; but all three agree on the meaning of [1..31]
      (and (fixnum? imm) (fx<= 1 imm 31))))

  (define unsigned8?
    (lambda (imm)
      (and (fixnum? imm) ($fxu< imm (expt 2 8)))))

  (define unsigned12?
    (lambda (imm)
      (and (fixnum? imm) ($fxu< imm (expt 2 12)))))

  (define branch-disp?
    (lambda (x)
      (and (fixnum? x) 
           ; -4 accounts for fact that pc reads as the instruction after next, not next
           (fx<= (- (expt 2 25)) (fx- x 4) (- (expt 2 25) 1))
           (not (fxlogtest x #b11)))))
  
  (define asm-size
    (lambda (x)
      (case (car x)
        [(asm arm32-abs arm32-jump arm32-call) 0]
        [else 4])))

  (define ax-mov32
    (lambda (dest n code*)
      ; NB: ARMv6T, ARMv7 only
      #;(emit movi dest (logand n #xffff)
          (emit movt dest (fxlogand (bitwise-arithmetic-shift-right n 16) #xffff) code*))
      ; instead place n at pc+8, load from there, and branch around
      (emit ldrlit dest 0
        (emit brai 0
          (cons* `(long . ,n) (aop-cons* `(asm "long:" ,n) code*))))))

  (define-who asm-move
    (lambda (code* dest src)
      ; move pseudo instruction used by set! case in select-instruction
      ; guarantees dest is a reg and src is reg, mem, or imm OR dest is
      ; mem and src is reg.
      (Trivit (dest src)
        (define (bad!) (sorry! who "unexpected combination of src ~s and dest ~s" src dest))
        (cond
          [(ax-reg? dest)
           (record-case src
             [(reg) ignore (emit mov dest src code*)]
             [(imm) (n)
              (cond
                [(funky12 n) =>
                 (lambda (f12)
                   (emit movi1 dest f12 code*))]
                [(funky12 (lognot n)) =>
                 (lambda (f12)
                   (emit mvni dest f12 code*))]
                [else (ax-mov32 dest n code*)])]
             [(literal) stuff
              (ax-mov32 dest 0
                (asm-helper-relocation code* (cons 'arm32-abs stuff)))]
             [(disp) (n breg)
              (safe-assert (or (unsigned12? n) (unsigned12? (- n))))
              (emit ldri dest `(reg . ,breg) n code*)]
             [(index) (n ireg breg)
              (safe-assert (eqv? n 0))
              (emit ldr dest `(reg . ,breg) `(reg . ,ireg) code*)]
             [else (bad!)])]
          [(ax-reg? src)
           (record-case dest
             [(disp) (n breg)
              (safe-assert (or (unsigned12? n) (unsigned12? (- n))))
              (emit stri src `(reg . ,breg) n code*)]
             [(index) (n ireg breg)
              (safe-assert (eqv? n 0))
              (emit str src `(reg . ,breg) `(reg . ,ireg) code*)]
             [else (bad!)])]
          [else (bad!)]))))

  (define-who asm-move/extend
    (lambda (op)
      (lambda (code* dest src)
        (Trivit (dest src)
          (case op
            [(sext8) (emit sxtb dest src code*)]
            [(sext16) (emit sxth dest src code*)]
            [(zext8) (emit uxtb dest src code*)]
            [(zext16) (emit uxth dest src code*)]
            [else (sorry! who "unexpected op ~s" op)])))))

  (module (asm-add asm-sub asm-rsb asm-logand asm-logor asm-logxor asm-bic)
    (define-syntax define-asm-binop
      (syntax-rules ()
        [(_ name opi op)
         (define name
           (lambda (set-cc?)
             (rec name
               (lambda (code* dest src0 src1)
                 (Trivit (dest src0 src1)
                   (record-case src1
                     [(imm) (n) (emit opi set-cc? dest src0 n code*)]
                     [else (emit op set-cc? dest src0 src1 code*)]))))))]))

    (define-asm-binop asm-add addi add)
    (define-asm-binop asm-sub subi sub)
    (define-asm-binop asm-rsb rsbi rsb)
    (define-asm-binop asm-logand andi and)
    (define-asm-binop asm-logor orri orr)
    (define-asm-binop asm-logxor eori eor)
    (define-asm-binop asm-bic bici bic))

  (define asm-mul
    (lambda (code* dest src0 src1)
      (Trivit (dest src0 src1)
        (emit mul #f dest src0 src1 code*))))

  (define asm-smull
    (lambda (code* dest src0 src1 tmp)
      (Trivit (dest src0 src1 tmp)
        (emit smull dest tmp src0 src1 code*))))

  (define asm-cmp/shift
    (lambda (count type)
      (lambda (code* src0 src1)
        (Trivit (src0 src1)
          (emit cmp/shift count type src0 src1 code*)))))

  (define-who asm-fl-load/cvt
    (lambda (op flreg)
      (lambda (code* base offset)
        (Trivit (base offset)
          (case op
            [(load-single->double)
             (emit vldr.sgl %flreg2 base (ax-imm-data offset)
               (emit vcvt.sgl->dbl flreg %flreg2 code*))]
            [(load-double->single)
             (emit vldr.dbl %flreg2 base (ax-imm-data offset)
               (emit vcvt.dbl->sgl flreg %flreg2 code*))]
            [else (sorry! who "unrecognized op ~s" op)])))))

  (define-who asm-fl-store/cvt
    (lambda (op flreg)
      (lambda (code* base offset)
        (Trivit (base offset)
          (case op
            [(store-single->double)
             (emit vcvt.sgl->dbl %flreg2 flreg
               (emit vstr.dbl %flreg2 base (ax-imm-data offset) code*))]
            [else (sorry! who "unrecognized op ~s" op)])))))

  (define-who asm-fl-load/store
    (lambda (op flreg)
      (lambda (code* base offset)
        (Trivit (base offset)
          (let ([offset (ax-imm-data offset)])
            (case op
              [(load-single) (emit vldr.sgl flreg base offset code*)]
              [(load-double) (emit vldr.dbl flreg base offset code*)]
              [(store-single) (emit vstr.sgl flreg base offset code*)]
              [(store-double) (emit vstr.dbl flreg base offset code*)]
              [else (sorry! who "unrecognized op ~s" op)]))))))

  (define-who asm-load
    (lambda (type)
      (rec asm-load-internal
        (lambda (code* dest base index offset)
          (let ([n (nanopass-case (L16 Triv) offset
                     [(immediate ,imm) imm]
                     [else (sorry! who "unexpected non-immediate offset ~s" offset)])])
            (Trivit (dest base)
              (cond
                [(eq? index %zero)
                  (case type
                    [(integer-32 unsigned-32) (emit ldri dest base n code*)]
                    [(integer-16) (emit ldrshi dest base n code*)]
                    [(unsigned-16) (emit ldrhi dest base n code*)]
                    [(integer-8) (emit ldrsbi dest base n code*)]
                    [(unsigned-8) (emit ldrbi dest base n code*)]
                    [else (sorry! who "unexpected mref type ~s" type)])]
                [(eqv? n 0)
                  (Trivit (index)
                    (case type
                      [(integer-32 unsigned-32) (emit ldr dest base index code*)]
                      [(integer-16) (emit ldrsh dest base index code*)]
                      [(unsigned-16) (emit ldrh dest base index code*)]
                      [(integer-8) (emit ldrsb dest base index code*)]
                      [(unsigned-8) (emit ldrb dest base index code*)]
                      [else (sorry! who "unexpected mref type ~s" type)]))]
                [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))

  (define-who asm-store
    (lambda (type)
      (rec asm-store-internal
        (lambda (code* base index offset src)
          (let ([n (nanopass-case (L16 Triv) offset
                     [(immediate ,imm) imm]
                     [else (sorry! who "unexpected non-immediate offset ~s" offset)])])
            (Trivit (src base)
              (cond
                [(eq? index %zero)
                  (case type
                    [(integer-32 unsigned-32) (emit stri src base n code*)]
                    [(integer-16 unsigned-16) (emit strhi src base n code*)]
                    [(integer-8 unsigned-8) (emit strbi src base n code*)]
                    [else (sorry! who "unexpected mref type ~s" type)])]
                [(eqv? n 0)
                  (Trivit (index)
                    (case type
                      [(integer-32 unsigned-32) (emit str src base index code*)]
                      [(integer-16 unsigned-16) (emit strh src base index code*)]
                      [(integer-8 unsigned-8) (emit strb src base index code*)]
                      [else (sorry! who "unexpected mref type ~s" type)]))]
                [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))

  (define-who asm-flop-2
    (lambda (op)
      (lambda (code* src1 src2 dest)
        (Trivit (src1 src2 dest)
          (emit vldr.dbl %flreg1 src1 0
            (emit vldr.dbl %flreg2 src2 0
              (let ([code* (emit vstr.dbl %flreg1 dest 0 code*)])
                (case op
                  [(fl+) (emit vadd %flreg1 %flreg1 %flreg2 code*)]
                  [(fl-) (emit vsub %flreg1 %flreg1 %flreg2 code*)]
                  [(fl*) (emit vmul %flreg1 %flreg1 %flreg2 code*)]
                  [(fl/) (emit vdiv %flreg1 %flreg1 %flreg2 code*)]
                  [else (sorry! who "unrecognized op ~s" op)]))))))))

  (define asm-flsqrt
    (lambda (code* src dest)
      (Trivit (src dest)
        (emit vldr.dbl %flreg1 src 0
          (emit vsqrt %flreg1 %flreg1
            (emit vstr.dbl %flreg1 dest 0 code*))))))

  (define asm-trunc
    (lambda (code* dest flonumreg)
      (Trivit (dest flonumreg)
        (emit vldr.dbl %flreg1 flonumreg 0
          (emit vcvt.dbl->s32 %flreg1 %flreg1
            (emit vmov.s32->gpr %flreg1 dest code*))))))

  (define asm-flt
    (lambda (code* src flonumreg)
      (Trivit (src flonumreg)
        (emit vmov.gpr->s32 %flreg1 src
          (emit vcvt.s32->dbl %flreg1 %flreg1
            (emit vstr.dbl %flreg1 flonumreg 0 code*))))))

  (define-who asm-swap
    (lambda (type)
      (rec asm-swap-internal
        (lambda (code* dest src)
          (Trivit (dest src)
            (case type
              [(integer-16) (emit revsh dest src code*)]
              [(unsigned-16) (emit rev16 dest src code*)]
              [(integer-32 unsigned-32) (emit rev dest src code*)]
              [else (sorry! who "unexpected asm-swap type argument ~s" type)]))))))

  (define asm-lock
    ;  tmp = ldrex src
    ;  cmp tmp, 0
    ;  bne L1 (+2)
    ;  tmp = 1
    ;  tmp = strex tmp, src
    ;L1:
    (lambda (code* src tmp)
      (Trivit (src tmp)
        (emit ldrex tmp src
          (emit cmpi tmp 0
            (emit bnei 1
              (emit movi1 tmp 1
                (emit strex tmp tmp src code*))))))))

  (define-who asm-lock+/-
    ; L:
    ;   tmp1 = ldrex src
    ;   tmp1 = tmp1 +/- 1
    ;   tmp2 = strex tmp1, src
    ;   cmp tmp2, 0
    ;   bne L (-6)
    ;   cmp tmp1, 0
    (lambda (op)
      (lambda (code* src tmp1 tmp2)
        (Trivit (src tmp1 tmp2)
          (emit ldrex tmp1 src
            (let ([code* (emit strex tmp2 tmp1 src
                           (emit cmpi tmp2 0
                             (emit bnei -6
                               (emit cmpi tmp1 0 code*))))])
              (case op
                [(locked-incr!) (emit addi #f tmp1 tmp1 1 code*)]
                [(locked-decr!) (emit subi #f tmp1 tmp1 1 code*)]
                [else (sorry! who "unexpected op ~s" op)])))))))

  (define-who asm-cas
    ;   tmp = ldrex src
    ;   cmp tmp, old
    ;   bne L (+2)
    ;   tmp2 = strex new, src
    ;   cmp tmp2, 0
    ; L:
    (lambda (code* src old new tmp1 tmp2)
      (Trivit (src old new tmp1 tmp2)
        (emit ldrex tmp1 src
          (emit cmp tmp1 old
            (emit bnei 1
              (emit strex tmp2 new src
                (emit cmpi tmp2 0
                   code*))))))))

  (define asm-fl-relop
    (lambda (info)
      (lambda (l1 l2 offset x y)
        (Trivit (x y)
          (values
            (emit vldr.dbl %flreg1 x 0
              (emit vldr.dbl %flreg2 y 0
                (emit vcmp %flreg1 %flreg2
                  (emit fpscr->apsr '()))))
            (asm-conditional-jump info l1 l2 offset))))))

  (define-who asm-relop
    (lambda (info)
      (rec asm-relop-internal
        (lambda (l1 l2 offset x y)
          (Trivit (x y)
            (unless (ax-reg? x) (sorry! who "unexpected first operand ~s" x))
            (values
              (record-case y
                [(imm) (n) (emit cmpi x n '())]
                [(reg) ignore (emit cmp x y '())]
                [else (sorry! who "unexpected second operand ~s" y)])
              (asm-conditional-jump info l1 l2 offset)))))))

  (define asm-condition-code
    (lambda (info)
      (rec asm-check-flag-internal
        (lambda (l1 l2 offset)
          (values '() (asm-conditional-jump info l1 l2 offset))))))

  (define asm-pop-multiple
    (lambda (regs)
      (lambda (code*)
        (emit popm regs code*))))

  (define asm-push-multiple
    (lambda (regs)
      (lambda (code*)
        (emit pushm regs code*))))

  (define asm-vpush-multiple
    (lambda (reg n)
      (lambda (code*)
        (emit vpushm reg n code*))))

  (define asm-vpop-multiple
    (lambda (reg n)
      (lambda (code*)
        (emit vpopm reg n code*))))

  (define asm-save-flrv
    (lambda (code*)
      (let ([sp (cons 'reg %sp)])
        (emit subi #f sp sp 8
          (emit vstr.dbl %Cfpretval sp 0 code*)))))

  (define asm-restore-flrv
    (lambda (code*)
      (let ([sp (cons 'reg %sp)])
        (emit vldr.dbl %Cfpretval sp 0
          (emit addi #f sp sp 8 code*)))))

  (define asm-read-counter
    (case-lambda
      [(k)
       (lambda (code* dest)
         (Trivit (dest)
           (emit mrc 'al 15 0 dest 15 12 k code*)))]
      [()
       (lambda (code* dest src)
         (Trivit (dest src)
           (emit cmpi src 0
             (emit mrc 'eq 15 0 dest 15 12 2
               (emit mrc 'ne 15 0 dest 15 12 3 code*)))))]))

  (define asm-library-jump
    (lambda (l)
      (asm-helper-jump '()
        `(arm32-jump ,(constant code-data-disp) (library-code ,(libspec-label-libspec l))))))

  (define asm-library-call
    (lambda (libspec save-ra?)
      (let ([target `(arm32-call ,(constant code-data-disp) (library-code ,libspec))])
        (rec asm-asm-call-internal
          (lambda (code* dest jmp-tmp . ignore) ; ignore arguments, which must be in fixed locations
            (asm-helper-call code* target save-ra? jmp-tmp))))))

  (define asm-library-call!
    (lambda (libspec save-ra?)
      (let ([target `(arm32-call ,(constant code-data-disp) (library-code ,libspec))])
        (rec asm-asm-call-internal
          (lambda (code* jmp-tmp . ignore) ; ignore arguments, which must be in fixed locations
            (asm-helper-call code* target save-ra? jmp-tmp))))))

  (define asm-c-simple-call
    (lambda (entry save-ra?)
      (let ([target `(arm32-call 0 (entry ,entry))])
        (rec asm-c-simple-call-internal
          (lambda (code* jmp-tmp . ignore)
            (asm-helper-call code* target save-ra? jmp-tmp))))))

  (define-who asm-indirect-call
    (lambda (code* dest lr . ignore)
      (safe-assert (eq? lr %lr))
      (Trivit (dest)
        (unless (ax-reg? dest) (sorry! who "unexpected dest ~s" dest))
        (emit blx dest code*))))

  (define asm-direct-jump
    (lambda (l offset)
      (asm-helper-jump '() (make-funcrel 'arm32-jump l offset))))

  (define asm-literal-jump
    (lambda (info)
      (asm-helper-jump '()
        `(arm32-jump ,(info-literal-offset info) (,(info-literal-type info) ,(info-literal-addr info))))))

  (define-who asm-indirect-jump
    (lambda (src)
      (Trivit (src)
        (record-case src
          [(reg) ignore (emit bx src '())]
          [(disp) (n breg)
           (safe-assert (or (unsigned12? n) (unsigned12? (- n))))
           (emit ldri `(reg . ,%pc) `(reg . ,breg) n '())]
          [(index) (n ireg breg)
           (safe-assert (eqv? n 0))
           (emit ldr `(reg . ,%pc) `(reg . ,breg) `(reg . ,ireg) '())]
          [else (sorry! who "unexpected src ~s" src)]))))

  (define asm-logtest
    (lambda (i? info)
      (lambda (l1 l2 offset x y)
        (Trivit (x y)
          (values
            (record-case y
              [(imm) (n) (emit tsti x n '())]
              [else (emit tst x y '())])
            (let-values ([(l1 l2) (if i? (values l2 l1) (values l1 l2))])
              (asm-conditional-jump info l2 l1 offset)))))))

  (define asm-get-tc
    (let ([target `(arm32-call 0 (entry ,(lookup-c-entry get-thread-context)))])
      (lambda (code* dest jmp-tmp . ignore) ; dest is ignored, since it is always Cretval
        (asm-helper-call code* target #f jmp-tmp))))

  (define-who asm-return-address
    (lambda (dest l incr-offset next-addr)
      (make-rachunk dest l incr-offset next-addr
        (or (cond
              [(local-label-offset l) =>
               (lambda (offset)
                 (let ([disp (fx- next-addr (fx- offset incr-offset) 4)])
                   (cond
                     [(code-offset-funky12 disp)
                      (Trivit (dest)
                        ; aka adr, encoding A1
                        (emit addi #f dest `(reg . ,%pc) disp '()))]
                     [(code-offset-funky12 (- disp))
                      (Trivit (dest)
                        ; aka adr, encoding A2
                        (emit subi #f dest `(reg . ,%pc) (- disp) '()))]
                     [else #f])))]
              [else #f])
            (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))))))

  (define-who asm-jump
    (lambda (l next-addr)
      (make-gchunk l next-addr
        (cond
          [(local-label-offset l) =>
           (lambda (offset)
             (let ([disp (fx- next-addr offset)])
               (cond
                 [(eqv? disp 0) '()]
                 [(branch-disp? disp) (emit bra `(label ,disp ,l) '())]
                 ; will have to deal with this on architectures with smaller displacements.
                 ; problem is we'll need a temp reg, and we discover this way past register
                 ; allocation.  so possibly compute the max possible code-object size at
                 ; instruction selection time.  when max possible size exceeds branch range
                 ; (plus or minus), supply asm-jump and others like it an unspillable.  don't
                 ; want to supply an unspillable for smaller code objects since this
                 ; unnecessarily constrains the register allocator.
                 [else (sorry! who "no support for code objects > 32MB in length")])))]
          [else
            ; label must be somewhere above.  generate something so that a hard loop
            ; doesn't get dropped.  this also has some chance of being the right size
            ; for the final branch instruction.
            (emit bra `(label 0 ,l) '())]))))

  (define-who asm-conditional-jump
    (lambda (info l1 l2 next-addr)
      (define get-disp-opnd
        (lambda (next-addr l)
          (if (local-label? l)
              (cond
                [(local-label-offset l) =>
                 (lambda (offset)
                   (let ([disp (fx- next-addr offset)])
                     (unless (branch-disp? disp) (sorry! who "no support for code objects > 32MB in length"))
                     (values disp `(label ,disp ,l))))]
                [else (values 0 `(label 0 ,l))])
              (sorry! who "unexpected label ~s" l))))
      (let ([type (info-condition-code-type info)]
            [reversed? (info-condition-code-reversed? info)])
        (make-cgchunk info l1 l2 next-addr
          (let ()
            (define-syntax pred-case
              (lambda (x)
                (define build-bop-seq
                  (lambda (bop opnd1 opnd2 l2 body)
                    #`(let ([code* (emit #,bop #,opnd1 code*)])
                        (let-values ([(ignore #,opnd2) (get-disp-opnd (fx+ next-addr (asm-size* code*)) #,l2)])
                          #,body))))
                (define ops->code
                  (lambda (bop opnd)
                    #`(emit #,bop #,opnd code*)))
                (define handle-reverse
                  (lambda (e opnd l)
                    (syntax-case e (r?)
                      [(r? c1 c2) #`(if reversed? #,(ops->code #'c1 opnd) #,(ops->code #'c2 opnd))]
                      [_ (ops->code e opnd)])))
                (define handle-inverse
                  (lambda (e)
                    (syntax-case e (i?)
                      [(i? c1 c2)
                       #`(cond
                           [(fx= disp1 0) #,(handle-reverse #'c1 #'opnd2 #'l2)]
                           [(fx= disp2 0) #,(handle-reverse #'c2 #'opnd1 #'l1)]
                           [else #,(build-bop-seq #'bra #'opnd2 #'opnd1 #'l1
                                     (handle-reverse #'c2 #'opnd1 #'l1))])]
                      [_ #`(cond
                             [(fx= disp1 0) #,(handle-reverse e #'opnd2 #'l2)]
                             [else #,(build-bop-seq #'bra #'opnd1 #'opnd2 #'l2
                                       (handle-reverse e #'opnd2 #'l2))])])))
                (syntax-case x ()
                  [(_ [(pred ...) cl-body] ...)
                   (with-syntax ([(cl-body ...) (map handle-inverse #'(cl-body ...))])
                     #'(let ([code* '()])
                         (let-values ([(disp1 opnd1) (get-disp-opnd next-addr l1)]
                                      [(disp2 opnd2) (get-disp-opnd next-addr l2)])
                           (case type
                             [(pred ...) cl-body] ...
                             [else (sorry! who "~s branch type is currently unsupported" type)]))))])))
            (pred-case
              [(eq?) (i? bne beq)]
              [(u<) (i? (r? bls bcs) (r? bhi bcc))]
              [(<) (i? (r? ble bge) (r? bgt blt))]
              [(<=) (i? (r? blt bgt) (r? bge ble))]
              [(>) (i? (r? bge ble) (r? blt bgt))]
              [(>=) (i? (r? bgt blt) (r? ble bge))]
              [(overflow) (i? bvc bvs)]
              [(multiply-overflow) (i? beq bne)] ; result of comparing sign bit of low word with all bits in high word: eq if no overflow, ne if overflow
              [(carry) (i? bcc bcs)]
              [(fl<) (i? (r? ble bcs) (r? bgt bcc))]
              [(fl<=) (i? (r? blt bhi) (r? bge bls))]
              [(fl=) (i? bne beq)]))))))

  (define asm-data-label
    (lambda (code* l offset func code-size)
      (let ([rel (make-funcrel 'abs l offset)])
        (cons* rel (aop-cons* `(asm "mrv point:" ,rel) code*)))))

  (define asm-helper-jump
    (lambda (code* reloc)
      ; NB: kills %ts, unbeknownst to the instruction scheduler
      ; NB: jmp-tmp should be included in jump syntax, introduced by md-handle-jump, and passed in from code generator
      ; NB: probably works despite this since %ts is never live at the jmp point anyway
      (let ([jmp-tmp (cons 'reg %ts)])
        (ax-mov32 jmp-tmp 0
          (emit bx jmp-tmp
            (asm-helper-relocation code* reloc))))))

  (define asm-kill
    (lambda (code* dest)
      code*))

  (define ax-save/restore
    ; push/pop while maintaining 8-byte alignment
    (lambda (code* reg-ea p)
      (let ([sp (cons 'reg %sp)])
        (emit str/preidx reg-ea sp -8
          (p (emit ldr/postidx reg-ea sp 8 code*))))))

  (define asm-helper-call
    (lambda (code* reloc save-ra? jmp-tmp)
      ; NB: kills %lr
      (let ([jmp-tmp (cons 'reg jmp-tmp)])
        (define maybe-save-ra
          (lambda (code* p)
            (if save-ra?
                (ax-save/restore code* (cons 'reg %lr) p)
                (p code*))))
        (maybe-save-ra code*
          (lambda (code*)
            (ax-mov32 jmp-tmp 0
              (emit blx jmp-tmp
                (asm-helper-relocation code* reloc))))))))

  (define asm-helper-relocation
    (lambda (code* reloc)
      (cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*))))

  (define asm-rp-header
    (let ([mrv-error `(abs ,(constant code-data-disp)
                        (library-code ,(lookup-libspec values-error)))])
      (lambda (code* mrvl fs lpm func code-size)
        (cons*
          (if (target-fixnum? lpm)
              `(long . ,(fix lpm))
              `(abs 0 (object ,lpm)))
          (aop-cons* `(asm livemask: ,(format "~b" lpm))
            '(code-top-link)
            (aop-cons* `(asm code-top-link)
              `(long . ,fs)
              (aop-cons* `(asm "frame size:" ,fs)
                (if mrvl
                    (asm-data-label code* mrvl 0 func code-size)
                    (cons*
                      mrv-error
                      (aop-cons* `(asm "mrv point:" ,mrv-error)
                        code*))))))))))

  ; NB: reads from %lr...should be okay if declare-intrinsics sets up return-live* properly
  (define asm-return (lambda () (emit bx (cons 'reg %lr) '())))

  (define asm-c-return (lambda (info) (emit bx (cons 'reg %lr) '())))

  (define-who asm-shiftop
    (lambda (op)
      (lambda (code* dest src0 src1)
        (Trivit (dest src0 src1)
          (record-case src1
            [(imm) (n) (emit shifti dest src0 n op code*)]
            [else (emit shift dest src0 src1 op code*)])))))

  (define asm-lognot
    (lambda (code* dest src)
      (Trivit (dest src)
        (emit mvn dest src code*))))

  (define asm-enter values)

  (define-who asm-inc-cc-counter
    (lambda (code* addr val tmp)
      (Trivit (addr val tmp)
        (define do-ldr
          (lambda (offset k code*)
            (emit ldri tmp addr offset (k (emit stri tmp addr offset code*)))))
        (define do-add/cc
          (lambda (code*)
            (record-case val
              [(imm) (n) (emit addi #t tmp tmp n code*)]
              [else (emit add #t tmp tmp val code*)])))
        (do-ldr 0
          do-add/cc
          (emit bnei 2
            (do-ldr 4
              (lambda (code*)
                (emit addi #f tmp tmp 1 code*))
              code*))))))

  (module (asm-foreign-call asm-foreign-callable)
    (define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k)))))
    (define (double-member? m) (and (eq? (car m) 'float)
                                    (fx= (cadr m) 8)))
    (define (float-member? m) (and (eq? (car m) 'float)
                                   (fx= (cadr m) 4)))
    (define (indirect-result-that-fits-in-registers? result-type)
      (nanopass-case (Ltype Type) result-type
        [(fp-ftd& ,ftd)
         (let* ([members ($ftd->members ftd)]
                [num-members (length members)])
           (or (fx<= ($ftd-size ftd) 4)
               (and (fx= num-members 1)
                    ;; a struct containing only int64 is not returned in a register
                    (or (not ($ftd-compound? ftd))))
               (and (fx<= num-members 4)
                    (or (andmap double-member? members)
                        (andmap float-member? members)))))]
        [else #f]))
    (define sgl-regs (lambda () (list %Cfparg1 %Cfparg1b %Cfparg2 %Cfparg2b %Cfparg3 %Cfparg3b %Cfparg4 %Cfparg4b
                                      %Cfparg5 %Cfparg5b %Cfparg6 %Cfparg6b %Cfparg7 %Cfparg7b %Cfparg8 %Cfparg8b)))
    (define-who asm-foreign-call
      (with-output-language (L13 Effect)
        (define int-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4)))
        (letrec ([load-double-stack
                  (lambda (offset)
                    (lambda (x) ; requires var
                      (%seq
                       (inline ,(make-info-loadfl %flreg1) ,%load-double ,x ,%zero ,(%constant flonum-data-disp))
                       (inline ,(make-info-loadfl %flreg1) ,%store-double ,%sp ,%zero (immediate ,offset)))))]
                 [load-single-stack
                  (lambda (offset)
                    (lambda (x) ; requires var
                      (%seq
                       (inline ,(make-info-loadfl %flreg1) ,%load-double->single ,x ,%zero ,(%constant flonum-data-disp))
                       (inline ,(make-info-loadfl %flreg1) ,%store-single ,%sp ,%zero (immediate ,offset)))))]
                 [load-int-stack
                  (lambda (offset)
                    (lambda (rhs) ; requires rhs
                      `(set! ,(%mref ,%sp ,offset) ,rhs)))]
                 [load-int64-stack
                  (lambda (offset)
                    (lambda (lorhs hirhs) ; requires rhs
                      (%seq
                       (set! ,(%mref ,%sp ,offset) ,lorhs)
                       (set! ,(%mref ,%sp ,(fx+ offset 4)) ,hirhs))))]
                 [load-int-indirect-stack
                  (lambda (offset from-offset size)
                    (lambda (x) ; requires var
                      (case size
                        [(3)
                         (%seq
                          (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset)))
                          (set! ,(%mref ,%sp ,(fx+ offset 2)) (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))))]
                        [else
                         `(set! ,(%mref ,%sp ,offset) ,(case size
                                                         [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))]
                                                         [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))]
                                                         [(4) (%mref ,x ,from-offset)]))])))]
                 [load-int64-indirect-stack
                  (lambda (offset from-offset)
                    (lambda (x) ; requires var
                      (%seq
                       (set! ,(%mref ,%sp ,offset) ,(%mref ,x ,from-offset))
                       (set! ,(%mref ,%sp ,(fx+ offset 4)) ,(%mref ,x ,(fx+ from-offset 4))))))]
                 [load-double-reg
                  (lambda (fpreg fp-disp)
                    (lambda (x) ; requires var
                      `(inline ,(make-info-loadfl fpreg) ,%load-double ,x ,%zero (immediate ,fp-disp))))]
                 [load-single-reg
                  (lambda (fpreg fp-disp single?)
                    (lambda (x) ; requires var
                      `(inline ,(make-info-loadfl fpreg) ,(if single? %load-single %load-double->single) ,x ,%zero (immediate ,fp-disp))))]
                 [load-int-reg
                  (lambda (ireg)
                    (lambda (x)
                      `(set! ,ireg ,x)))]
                 [load-int64-reg
                  (lambda (loreg hireg)
                    (lambda (lo hi)
                      (%seq
                       (set! ,loreg ,lo)
                       (set! ,hireg ,hi))))]
                 [load-int-indirect-reg
                  (lambda (ireg from-offset size)
                    (lambda (x)
                      (case size
                        [(3)
                         (let ([tmp %lr]) ; ok to use %lr here?
                           (%seq
                            (set! ,ireg (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset)))
                            (set! ,tmp (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2))))
                            (set! ,tmp ,(%inline sll ,tmp (immediate 16)))
                            (set! ,ireg ,(%inline + ,ireg ,tmp))))]
                        [else
                         `(set! ,ireg ,(case size
                                         [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))]
                                         [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))]
                                         [(4) (%mref ,x ,from-offset)]))])))]
                 [load-int64-indirect-reg
                  (lambda (loreg hireg from-offset)
                    (lambda (x)
                      (%seq
                       (set! ,loreg ,(%mref ,x ,from-offset))
                       (set! ,hireg ,(%mref ,x ,(fx+ from-offset 4))))))]
                 [do-args
                  (lambda (types)
                    ; sgl* is always of even-length, i.e., has a sgl/dbl reg first
                    ; bsgl is set to "b" single (second half of double) if we have one to fill
                    (let loop ([types types] [locs '()] [live* '()] [int* (int-regs)] [sgl* (sgl-regs)] [bsgl #f] [isp 0])
                      (if (null? types)
                          (values isp locs live*)
                          (nanopass-case (Ltype Type) (car types)
                            [(fp-double-float)
                             (if (null? sgl*)
                                 (let ([isp (align 8 isp)])
                                   (loop (cdr types)
                                         (cons (load-double-stack isp) locs)
                                         live* int* '() #f (fx+ isp 8)))
                                 (loop (cdr types)
                                       (cons (load-double-reg (car sgl*) (constant flonum-data-disp)) locs)
                                       live* int* (cddr sgl*) bsgl isp))]
                            [(fp-single-float)
                             (if bsgl
                                 (loop (cdr types)
                                       (cons (load-single-reg bsgl (constant flonum-data-disp) #f) locs)
                                       live* int* sgl* #f isp)
                                 (if (null? sgl*)
                                     (loop (cdr types)
                                           (cons (load-single-stack isp) locs)
                                           live* int* '() #f (fx+ isp 4))
                                     (loop (cdr types)
                                           (cons (load-single-reg (car sgl*) (constant flonum-data-disp) #f) locs)
                                           live* int* (cddr sgl*) (cadr sgl*) isp)))]
                            [(fp-ftd& ,ftd)
                             (let ([size ($ftd-size ftd)]
                                   [members ($ftd->members ftd)]
                                   [combine-loc (lambda (loc f)
                                                  (if loc
                                                      (lambda (x) (%seq ,(loc x) ,(f x)))
                                                      f))])
                               (case ($ftd-alignment ftd)
                                 [(8)
                                  (let* ([int* (if (even? (length int*)) int* (cdr int*))]
                                         [num-members (length members)]
                                         [doubles? (and (fx<= num-members 4)
                                                        (andmap double-member? members))])
                                    ;; Sequence of up to 4 doubles that fits in registers?
                                    (cond
                                     [(and doubles?
                                           (fx>= (length sgl*) (fx* 2 num-members)))
                                      ;; Allocate each double to a register
                                      (let dbl-loop ([size size] [offset 0] [sgl* sgl*] [loc #f])
                                        (cond
                                         [(fx= size 0)
                                          (loop (cdr types) (cons loc locs) live* int* sgl* #f isp)]
                                         [else
                                          (dbl-loop (fx- size 8) (fx+ offset 8) (cddr sgl*)
                                                    (combine-loc loc (load-double-reg (car sgl*) offset)))]))]
                                     [else
                                      ;; General case; for non-doubles, use integer registers while available,
                                      ;;  possibly splitting between registers and stack
                                      (let obj-loop ([size size] [offset 0] [loc #f]
                                                     [live* live*] [int* int*] [isp isp])
                                        (cond
                                         [(fx= size 0)
                                          (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
                                         [else
                                          (if (or (null? int*) doubles?)
                                              (let ([isp (align 8 isp)])
                                                (obj-loop (fx- size 8) (fx+ offset 8)
                                                          (combine-loc loc (load-int64-indirect-stack isp offset))
                                                          live* int* (fx+ isp 8)))
                                              (obj-loop (fx- size 8) (fx+ offset 8)
                                                        (combine-loc loc (load-int64-indirect-reg (car int*) (cadr int*) offset))
                                                        (cons* (car int*) (cadr int*) live*) (cddr int*) isp))]))]))]
                                 [else
                                  (let* ([num-members (length members)]
                                         [floats? (and (fx<= num-members 4)
                                                       (andmap float-member? members))])
                                    ;; Sequence of up to 4 floats that fits in registers?
                                    (cond
                                     [(and floats?
                                           (fx>= (fx+ (length sgl*) (if bsgl 1 0)) num-members))
                                      ;; Allocate each float to register
                                      (let flt-loop ([size size] [offset 0] [sgl* sgl*] [bsgl bsgl] [loc #f])
                                        (cond
                                         [(fx= size 0)
                                          (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
                                         [else
                                          (flt-loop (fx- size 4) (fx+ offset 4)
                                                    (if bsgl sgl* (cddr sgl*))
                                                    (if bsgl #f (cadr sgl*))
                                                    (combine-loc loc (load-single-reg (or bsgl (car sgl*)) offset #t)))]))]
                                     [else
                                      ;; General case; use integer registers while available,
                                      ;;  possibly splitting between registers and stack
                                      (let obj-loop ([size size] [offset 0] [loc #f]
                                                     [live* live*] [int* int*] [isp isp])
                                        (cond
                                         [(fx<= size 0)
                                          (loop (cdr types) (cons loc locs) live* int* sgl* bsgl isp)]
                                         [else
                                          (if (or (null? int*) floats?)
                                              (obj-loop (fx- size 4) (fx+ offset 4)
                                                        (combine-loc loc (load-int-indirect-stack isp offset (fxmin size 4)))
                                                        live* int* (fx+ isp 4))
                                              (obj-loop (fx- size 4) (fx+ offset 4)
                                                        (combine-loc loc (load-int-indirect-reg (car int*) offset (fxmin size 4)))
                                                        (cons (car int*) live*) (cdr int*) isp))]))]))]))]
                            [else
                             (if (nanopass-case (Ltype Type) (car types)
                                   [(fp-integer ,bits) (fx= bits 64)]
                                   [(fp-unsigned ,bits) (fx= bits 64)]
                                   [else #f])
                                 (let ([int* (if (even? (length int*)) int* (cdr int*))])
                                   (if (null? int*)
                                       (let ([isp (align 8 isp)])
                                         (loop (cdr types)
                                               (cons (load-int64-stack isp) locs)
                                               live* '() sgl* bsgl (fx+ isp 8)))
                                       (loop (cdr types)
                                             (cons (load-int64-reg (car int*) (cadr int*)) locs)
                                             (cons* (car int*) (cadr int*) live*) (cddr int*) sgl* bsgl isp)))
                                 (if (null? int*)
                                     (loop (cdr types)
                                           (cons (load-int-stack isp) locs)
                                           live* '() sgl* bsgl (fx+ isp 4))
                                     (loop (cdr types)
                                           (cons (load-int-reg (car int*)) locs)
                                           (cons (car int*) live*) (cdr int*) sgl* bsgl isp)))]))))]
                 [add-fill-result
                  (lambda (fill-result-here? result-type args-frame-size e)
                    (cond
                     [fill-result-here?
                      (nanopass-case (Ltype Type) result-type
                        [(fp-ftd& ,ftd)
                         (let* ([members ($ftd->members ftd)]
                                [num-members (length members)]
                                ;; result pointer is stashed on the stack after all arguments:
                                [dest-x %r2]
                                [init-dest-e `(seq ,e (set! ,dest-x ,(%mref ,%sp ,args-frame-size)))])
                           (cond
                            [(and (fx<= num-members 4)
                                  (or (andmap double-member? members)
                                      (andmap float-member? members)))
                             ;; double/float results are in floating-point registers
                             (let ([double? (and (pair? members) (double-member? (car members)))])
                               (let loop ([members members] [sgl* (sgl-regs)] [offset 0] [e init-dest-e])
                                 (cond
                                  [(null? members) e]
                                  [else
                                   (loop (cdr members)
                                         (if double? (cddr sgl*) (cdr sgl*))
                                         (fx+ offset (if double? 8 4))
                                         `(seq
                                           ,e
                                           (inline ,(make-info-loadfl (car sgl*)) ,(if double? %store-double %store-single)
                                                   ,dest-x ,%zero (immediate ,offset))))])))]
                            [else
                             ;; result is in %Cretval and maybe %r1
                             `(seq
                               ,init-dest-e
                               ,(case ($ftd-size ftd)
                                  [(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)]
                                  [(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)]
                                  [(3) (%seq
                                        (inline ,(make-info-load 'integer-16 #f) ,%store ,dest-x ,%zero (immediate 0) ,%Cretval)
                                        (set! ,%Cretval ,(%inline srl ,%Cretval (immediate 16)))
                                        (inline ,(make-info-load 'integer-8 #f) ,%store ,dest-x ,%zero (immediate 2) ,%Cretval))]
                                  [(4) `(set! ,(%mref ,dest-x ,0) ,%Cretval)]
                                  [(8) `(seq
                                         (set! ,(%mref ,dest-x ,0) ,%Cretval)
                                         (set! ,(%mref ,dest-x ,4) ,%r1))]))]))])]
                     [else e]))])
          (lambda (info)
            (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
            (let* ([arg-type* (info-foreign-arg-type* info)]
                   [result-type (info-foreign-result-type info)]
                   [fill-result-here? (indirect-result-that-fits-in-registers? result-type)])
              (with-values (do-args (if fill-result-here? (cdr arg-type*) arg-type*))
                (lambda (args-frame-size locs live*)
                  (let* ([frame-size (align 8 (+ args-frame-size
                                                 (if fill-result-here?
                                                     4
                                                     0)))]
                         [adjust-frame (lambda (op)
                                         (lambda ()
                                           (if (fx= frame-size 0)
                                               `(nop)
                                               `(set! ,%sp (inline ,null-info ,op ,%sp (immediate ,frame-size))))))])
                    (values
                     (adjust-frame %-)
                     (let ([locs (reverse locs)])
                       (cond
                        [fill-result-here?
                         ;; stash extra argument on the stack to be retrieved after call and filled with the result:
                         (cons (load-int-stack args-frame-size) locs)]
                        [else locs]))
                     (lambda (t0)
                       (add-fill-result fill-result-here? result-type args-frame-size
                                        `(inline ,(make-info-kill*-live* (reg-list %r0) live*) ,%c-call ,t0)))
                     (nanopass-case (Ltype Type) result-type
                       [(fp-double-float)
                        (lambda (lvalue)
                          `(inline ,(make-info-loadfl %Cfpretval) ,%store-double ,lvalue ,%zero
                                   ,(%constant flonum-data-disp)))]
                       [(fp-single-float)
                        (lambda (lvalue)
                          `(inline ,(make-info-loadfl %Cfpretval) ,%store-single->double ,lvalue ,%zero
                                   ,(%constant flonum-data-disp)))]
                       [(fp-integer ,bits)
                        (case bits
                          [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%r0)))]
                          [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%r0)))]
                          [(32) (lambda (lvalue) `(set! ,lvalue ,%r0))]
                          [(64) (lambda (lvlow lvhigh)
                                  `(seq
                                    (set! ,lvhigh ,%r1)
                                    (set! ,lvlow ,%r0)))]
                          [else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])]
                       [(fp-unsigned ,bits)
                        (case bits
                          [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%r0)))]
                          [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%r0)))]
                          [(32) (lambda (lvalue) `(set! ,lvalue ,%r0))]
                          [(64) (lambda (lvlow lvhigh)
                                  `(seq
                                    (set! ,lvhigh ,%r1)
                                    (set! ,lvlow ,%r0)))]
                          [else (sorry! who "unexpected asm-foreign-procedures fp-unsigned size ~s" bits)])]
                       [else (lambda (lvalue) `(set! ,lvalue ,%r0))])
                     (adjust-frame %+)))
                  )))))))

    (define-who asm-foreign-callable
      #|
        Frame Layout
                   +---------------------------+
                   |                           |
                   |    incoming stack args    |
  sp+52+R+X+Y+Z+W: |                           |
                   +---------------------------+<- 8-byte boundary
                   |                           |
                   |    saved int reg args     | 0-4 words
    sp+52+R+X+Y+Z: |                           |
                   +---------------------------+
                   |                           |
                   |   pad word if necessary   | 0-1 words
      sp+52+R+X+Y: |                           |
                   +---------------------------+<- 8-byte boundary
                   |                           |
                   |   saved float reg args    | 0-16 words
        sp+52+R+X: |                           |
                   +---------------------------+<- 8-byte boundary
                   |                           |
                   |      &-return space       | up to 8 words
          sp+52+R: |                           |
                   +---------------------------+<- 8-byte boundary
                   |                           |
                   |   pad word if necessary   | 0-1 words
            sp+52: |                           |
                   +---------------------------+
                   |                           |
                   |   callee-save regs + lr   | 13 words
             sp+0: |   callee-save fpregs      |
                   +---------------------------+<- 8-byte boundary

      X = 0 or 4 (depending on whether pad is present)
      Y = int-reg-bytes
      Z = float-reg-bytes
      |#
      (with-output-language (L13 Effect)
        (let ()
          (define load-double-stack
            (lambda (offset)
              (lambda (x) ; requires var
                (%seq
                  (inline ,(make-info-loadfl %flreg1) ,%load-double ,%sp ,%zero (immediate ,offset))
                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
          (define load-single-stack
            (lambda (offset)
              (lambda (x) ; requires var
                (%seq
                  (inline ,(make-info-loadfl %flreg1) ,%load-single->double ,%sp ,%zero (immediate ,offset))
                  (inline ,(make-info-loadfl %flreg1) ,%store-double ,x ,%zero ,(%constant flonum-data-disp))))))
          (define load-int-stack
            (lambda (type offset)
              (lambda (lvalue)
                (nanopass-case (Ltype Type) type
                  [(fp-integer ,bits)
                   (case bits
                     [(8) `(set! ,lvalue (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(16) `(set! ,lvalue (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(32) `(set! ,lvalue ,(%mref ,%sp ,offset))]
                     [else (sorry! who "unexpected load-int-stack fp-integer size ~s" bits)])]
                  [(fp-unsigned ,bits)
                   (case bits
                     [(8) `(set! ,lvalue (inline ,(make-info-load 'unsigned-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(16) `(set! ,lvalue (inline ,(make-info-load 'unsigned-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(32) `(set! ,lvalue ,(%mref ,%sp ,offset))]
                     [else (sorry! who "unexpected load-int-stack fp-unsigned size ~s" bits)])]
                  [else `(set! ,lvalue ,(%mref ,%sp ,offset))]))))
          (define load-int64-stack
            (lambda (offset)
              (lambda (lolvalue hilvalue)
                (%seq
                  (set! ,lolvalue ,(%mref ,%sp ,offset))
                  (set! ,hilvalue ,(%mref ,%sp ,(fx+ offset 4)))))))
          (define load-stack-address
            (lambda (offset)
              (lambda (lvalue)
                `(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
          (define count-reg-args
            (lambda (types synthesize-first?)
              ; bsgl? is #t iff we have a "b" single (second half of double) float reg to fill
              (let f ([types types] [iint (if synthesize-first? -1 0)] [idbl 0] [bsgl? #f])
                (if (null? types)
                    (values iint idbl)
                    (nanopass-case (Ltype Type) (car types)
                      [(fp-double-float)
                       (if (fx< idbl 8)
                           (f (cdr types) iint (fx+ idbl 1) bsgl?)
                           (f (cdr types) iint idbl #f))]
                      [(fp-single-float)
                       (if bsgl?
                           (f (cdr types) iint idbl #f)
                           (if (fx< idbl 8)
                               (f (cdr types) iint (fx+ idbl 1) #t)
                               (f (cdr types) iint idbl #f)))]
                      [(fp-ftd& ,ftd)
                       (let* ([size ($ftd-size ftd)]
                              [members ($ftd->members ftd)]
                              [num-members (length members)])
                         (cond
                          [(and (fx<= num-members 4)
                                (andmap double-member? members))
                           ;; doubles are either in registers or all on stack
                           (if (fx<= (fx+ idbl num-members) 8)
                               (f (cdr types) iint (fx+ idbl num-members) #f)
                               ;; no more floating-point registers should be used, but ok if we count more
                               (f (cdr types) iint idbl #f))]
                          [(and (fx<= num-members 4)
                                (andmap float-member? members))
                           ;; floats are either in registers or all on stack
                           (let ([amt (fxsrl (align 2 (fx- num-members (if bsgl? 1 0))) 1)])
                             (if (fx<= (fx+ idbl amt) 8)
                                 (let ([odd-floats? (fxodd? num-members)])
                                   (if bsgl?
                                       (f (cdr types) iint (+ idbl amt) (not odd-floats?))
                                       (f (cdr types) iint (+ idbl amt) odd-floats?)))
                                 ;; no more floating-point registers should be used, but ok if we count more
                                 (f (cdr types) iint idbl #f)))]
                          [(fx= 8 ($ftd-alignment ftd))
                           (f (cdr types) (fxmin 4 (fx+ (align 2 iint) (fxsrl size 2))) idbl bsgl?)]
                          [else
                           (let ([size (align 4 size)])
                             (f (cdr types) (fxmin 4 (fx+ iint (fxsrl size 2))) idbl bsgl?))]))]
                      [else
                       (if (nanopass-case (Ltype Type) (car types)
                             [(fp-integer ,bits) (fx= bits 64)]
                             [(fp-unsigned ,bits) (fx= bits 64)]
                             [else #f])
                           (let ([iint (align 2 iint)])
                             (f (cdr types) (if (fx< iint 4) (fx+ iint 2) iint) idbl bsgl?))
                           (f (cdr types) (if (fx< iint 4) (fx+ iint 1) iint) idbl bsgl?))])))))
          (define do-stack
            ; all of the args are on the stack at this point, though not contiguous since
            ; we push all of the int reg args with one push instruction and all of the
            ; float reg args with another (v)push instruction; the saved int regs
            ; continue on into the stack variables, which is convenient when a struct
            ; argument is split across registers and the stack
            (lambda (types saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
                     synthesize-first?)
              (let* ([return-space-offset (fx+ saved-reg-bytes pre-pad-bytes)]
                     [float-reg-offset (fx+ return-space-offset return-bytes)]
                     [int-reg-offset (fx+ float-reg-offset float-reg-bytes post-pad-bytes)]
                     [stack-arg-offset (fx+ int-reg-offset int-reg-bytes)])
                (let loop ([types (if synthesize-first? (cdr types) types)]
                           [locs '()]
                           [iint 0]
                           [idbl 0]
                           [bsgl-offset #f]
                           [int-reg-offset int-reg-offset]
                           [float-reg-offset float-reg-offset]
                           [stack-arg-offset stack-arg-offset])
                  (if (null? types)
                      (let ([locs (reverse locs)])
                        (if synthesize-first?
                            (cons (load-stack-address return-space-offset)
                              locs)
                            locs))
                      (nanopass-case (Ltype Type) (car types)
                        [(fp-double-float)
                         (if (< idbl 8)
                             (loop (cdr types)
                                   (cons (load-double-stack float-reg-offset) locs)
                                   iint (fx+ idbl 1) bsgl-offset int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)
                             (let ([stack-arg-offset (align 8 stack-arg-offset)])
                               (loop (cdr types)
                                     (cons (load-double-stack stack-arg-offset) locs)
                                     iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))))]
                        [(fp-single-float)
                         (if bsgl-offset
                             (loop (cdr types)
                                   (cons (load-single-stack bsgl-offset) locs)
                                   iint idbl #f int-reg-offset float-reg-offset stack-arg-offset)
                             (if (< idbl 8)
                                 (loop (cdr types)
                                   ; with big-endian ARM might need to adjust offset +/- 4 since pair of
                                   ; single floats in a pushed double float might be reversed
                                   (cons (load-single-stack float-reg-offset) locs)
                                   iint (fx+ idbl 1) (fx+ float-reg-offset 4) int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)
                                 (loop (cdr types)
                                   (cons (load-single-stack stack-arg-offset) locs)
                                   iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))))]
                        [(fp-ftd& ,ftd)
                         (let* ([size ($ftd-size ftd)]
                                [members ($ftd->members ftd)]
                                [num-members (length members)])
                           (cond
                            [(and (fx<= num-members 4)
                                  (andmap double-member? members))
                             ;; doubles are either in registers or all on stack
                             (if (fx<= (fx+ idbl num-members) 8)
                                 (loop (cdr types)
                                       (cons (load-stack-address float-reg-offset) locs)
                                       iint (fx+ idbl num-members) #f int-reg-offset (fx+ float-reg-offset size) stack-arg-offset)
                                 (let ([stack-arg-offset (align 8 stack-arg-offset)])
                                   (loop (cdr types)
                                         (cons (load-stack-address stack-arg-offset) locs)
                                         iint 8 #f int-reg-offset #f (fx+ stack-arg-offset size))))]
                            [(and (fx<= num-members 4)
                                  (andmap float-member? members))
                             ;; floats are either in registers or all on stack
                             (let ([amt (fxsrl (align 2 (fx- num-members (if bsgl-offset 1 0))) 1)])
                               (if (fx<= (fx+ idbl amt) 8)
                                   (let ([odd-floats? (fxodd? num-members)])
                                     (if bsgl-offset
                                         (let ([dbl-size (align 8 (fx- size 4))])
                                           (loop (cdr types)
                                             (cons (load-stack-address bsgl-offset) locs)
                                             iint (fx+ idbl amt) (if odd-floats? #f (+ bsgl-offset size)) int-reg-offset
                                             (fx+ float-reg-offset dbl-size) stack-arg-offset))
                                         (let ([dbl-size (align 8 size)])
                                           (loop (cdr types)
                                             (cons (load-stack-address float-reg-offset) locs)
                                             iint (fx+ idbl amt) (and odd-floats? (fx+ float-reg-offset size)) int-reg-offset
                                             (fx+ float-reg-offset dbl-size) stack-arg-offset))))
                                   (loop (cdr types)
                                     (cons (load-stack-address stack-arg-offset) locs)
                                     iint 8 #f int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]
                            [(fx= 8 ($ftd-alignment ftd))
                             (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
                                   [iint (align 2 iint)]
                                   [amt (fxsrl size 2)])
                               (if (fx< iint 4) ; argument starts in registers, may continue on stack
                                   (loop (cdr types)
                                     (cons (load-stack-address int-reg-offset) locs)
                                     (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
                                     (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
                                   (let ([stack-arg-offset (align 8 stack-arg-offset)])
                                     (loop (cdr types)
                                       (cons (load-stack-address stack-arg-offset) locs)
                                       iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size)))))]
                            [else
                             (let* ([size (align 4 size)]
                                    [amt (fxsrl size 2)])
                               (if (fx< iint 4) ; argument starts in registers, may continue on stack
                                   (loop (cdr types)
                                     (cons (load-stack-address int-reg-offset) locs)
                                     (fxmin 4 (fx+ iint amt)) idbl bsgl-offset (fx+ int-reg-offset size) float-reg-offset
                                     (fx+ stack-arg-offset (fxmax 0 (fx* 4 (fx- (fx+ iint amt) 4)))))
                                   (loop (cdr types)
                                     (cons (load-stack-address stack-arg-offset) locs)
                                     iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset size))))]))]
                        [else
                         (if (nanopass-case (Ltype Type) (car types)
                               [(fp-integer ,bits) (fx= bits 64)]
                               [(fp-unsigned ,bits) (fx= bits 64)]
                               [else #f])
                             (let ([int-reg-offset (if (fxeven? iint) int-reg-offset (fx+ int-reg-offset 4))]
                                   [iint (align 2 iint)])
                               (if (fx= iint 4)
                                   (let ([stack-arg-offset (align 8 stack-arg-offset)])
                                     (loop (cdr types)
                                       (cons (load-int64-stack stack-arg-offset) locs)
                                       iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset 8)))
                                   (loop (cdr types)
                                     (cons (load-int64-stack int-reg-offset) locs)
                                     (fx+ iint 2) idbl bsgl-offset (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)))
                             (if (fx= iint 4)
                                 (loop (cdr types)
                                   (cons (load-int-stack (car types) stack-arg-offset) locs)
                                   iint idbl bsgl-offset int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))
                                 (loop (cdr types)
                                   (cons (load-int-stack (car types) int-reg-offset) locs)
                                   (fx+ iint 1) idbl bsgl-offset (fx+ int-reg-offset 4) float-reg-offset stack-arg-offset)))]))))))
          (define do-result
            (lambda (result-type synthesize-first? return-stack-offset)
              (nanopass-case (Ltype Type) result-type
                [(fp-ftd& ,ftd)
                 (let* ([members ($ftd->members ftd)]
                        [num-members (length members)])
                   (cond
                    [(and (fx<= 1 num-members 4)
                          (or (andmap double-member? members)
                              (andmap float-member? members)))
                     ;; double/float results returned in floating-point registers
                     (values
                      (lambda ()
                        (let ([double? (and (pair? members) (double-member? (car members)))])
                          (let loop ([members members] [sgl* (sgl-regs)] [offset return-stack-offset] [e #f])
                            (cond
                             [(null? members) e]
                             [else
                              (loop (cdr members)
                                (if double? (cddr sgl*) (cdr sgl*))
                                (fx+ offset (if double? 8 4))
                                (let ([new-e
                                       `(inline ,(make-info-loadfl (car sgl*)) ,(if double? %load-double %load-single)
                                                ,%sp ,%zero (immediate ,offset))])
                                  (if e `(seq ,e ,new-e) new-e)))]))))
                      '()
                      ($ftd-size ftd))]
                    [else
                     (case ($ftd-size ftd)
                       [(8)
                        (values (lambda ()
                                   `(seq
                                      (set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))
                                      (set! ,%r1 ,(%mref ,%sp ,(fx+ 4 return-stack-offset)))))
                                 (list %Cretval %r1)
                                8)]
                       [else
                        (values (lambda ()
                                  (case ($ftd-size ftd)
                                    [(1)
                                     (let ([rep (if ($ftd-unsigned? ftd) 'unsigned-8 'integer-8)])
                                       `(set! ,%Cretval (inline ,(make-info-load rep #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset))))]
                                    [(2)
                                     (let ([rep (if ($ftd-unsigned? ftd) 'unsigned-16 'integer-16)])
                                       `(set! ,%Cretval (inline ,(make-info-load rep #f) ,%load ,%sp ,%zero (immediate ,return-stack-offset))))]
                                    [else `(set! ,%Cretval ,(%mref ,%sp ,return-stack-offset))]))
                                (list %Cretval)
                                4)])]))]
                [(fp-double-float)
                 (values (lambda (rhs)
                           `(inline ,(make-info-loadfl %Cfpretval) ,%load-double
                              ,rhs ,%zero ,(%constant flonum-data-disp)))
                         '()
                         0)]
                [(fp-single-float)
                 (values (lambda (rhs)
                           `(inline ,(make-info-loadfl %Cfpretval) ,%load-double->single
                              ,rhs ,%zero ,(%constant flonum-data-disp)))
                         '()
                         0)]
                [(fp-void)
                 (values (lambda () `(nop))
                         '()
                         0)]
                [else
                 (cond
                  [(nanopass-case (Ltype Type) result-type
                     [(fp-integer ,bits) (fx= bits 64)]
                     [(fp-unsigned ,bits) (fx= bits 64)]
                     [else #f])
                   (values (lambda (lo hi)
                             `(seq
                                (set! ,%Cretval ,lo)
                                (set! ,%r1 ,hi)))
                           (list %Cretval %r1)
                           0)]
                  [else
                   (values (lambda (x)
                             `(set! ,%Cretval ,x))
                           (list %Cretval)
                           0)])])))
          (lambda (info)
            (define callee-save-regs+lr (list %r4 %r5 %r6 %r7 %r8 %r9 %r10 %r11 %lr))
            (define callee-save-fpregs  (list %flreg1 %flreg2)) ; must be consecutive
            (define isaved (length callee-save-regs+lr))
            (define fpsaved (length callee-save-fpregs))
            (let* ([arg-type* (info-foreign-arg-type* info)]
                   [result-type (info-foreign-result-type info)]
                   [synthesize-first? (indirect-result-that-fits-in-registers? result-type)])
              (let-values ([(iint idbl) (count-reg-args arg-type* synthesize-first?)])
                (let ([saved-reg-bytes (fx+ (fx* isaved 4) (fx* fpsaved 8))]
                      [pre-pad-bytes (if (fxeven? isaved) 0 4)]
                      [int-reg-bytes (fx* iint 4)]
                      [post-pad-bytes (if (fxeven? iint) 0 4)]
                      [float-reg-bytes (fx* idbl 8)])
                  (let-values ([(get-result result-regs return-bytes) (do-result result-type synthesize-first?
                                                                        (fx+ saved-reg-bytes pre-pad-bytes))])
                    (let ([return-bytes (align 8 return-bytes)])
                      (values
                        (lambda ()
                          (%seq
                            ; save argument register values to the stack so we don't lose the values
                            ; across possible calls to C while setting up the tc and allocating memory
                            ,(if (fx= iint 0) `(nop) `(inline ,(make-info-kill*-live* '() (list-head (list %Carg1 %Carg2 %Carg3 %Carg4) iint)) ,%push-multiple))
                            ; pad if necessary to force 8-byte boundary, and make room for indirect return:
                            ,(let ([len (+ post-pad-bytes return-bytes)])
                               (if (fx= len 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,len)))))
                            ,(if (fx= idbl 0) `(nop) `(inline ,(make-info-vpush %Cfparg1 idbl) ,%vpush-multiple))
                            ; pad if necessary to force 8-byte boundary after saving callee-save-regs+lr
                            ,(if (fx= pre-pad-bytes 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate 4))))
                            ; save the callee save registers & return address
                            (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple)
                            (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpush-multiple)
                            ; set up tc for benefit of argument-conversion code, which might allocate
                            ,(if-feature pthreads
                               (%seq
                                  (set! ,%r0 ,(%inline get-tc))
                                  (set! ,%tc ,%r0))
                               `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
                        ; list of procedures that marshal arguments from their C stack locations
                        ; to the Scheme argument locations
                        (do-stack arg-type* saved-reg-bytes pre-pad-bytes return-bytes float-reg-bytes post-pad-bytes int-reg-bytes
                                  synthesize-first?)
                        get-result
                        (lambda ()
                          (in-context Tail
                            (%seq
                              ; restore the callee save registers
                              (inline ,(make-info-vpush (car callee-save-fpregs) fpsaved) ,%vpop-multiple)
                              (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple)
                              ; deallocate space for pad & arg reg values
                              (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ pre-pad-bytes int-reg-bytes post-pad-bytes float-reg-bytes return-bytes))))
                              ; done
                              (asm-c-return ,null-info ,callee-save-regs+lr ... ,result-regs ...)))))))))))))))
)