;;; arm64.ss

;;; SECTION 1: registers
;;; ABI:
;;;  Register usage:
;;;   r0-r7: C argument/result registers, caller-save
;;;   r8: indirect-result register, caller-save
;;;   r9-18: caller-save
;;;   r19-28: callee-save
;;;   r29: frame pointer, callee-save
;;;   r30: a.k.a. lr, link register
;;;   sp: stack pointer or (same register number) zero register
;;;   --------
;;;   v0-v7: FP registers used for C arguments/results, caller-save
;;;   v8-v15: callee-save for low 64 bits
;;;   v16-v31: caller-save
;;;  Alignment:
;;;   stack must be 16-byte aligned, essentially always

(define-registers
  (reserved
    [%tc  %r19                  #t 19 uptr]
    [%sfp %r20                  #t 20 uptr]
    [%ap  %r21                  #t 21 uptr]
    [%trap %r22                 #t 22 uptr])
  (allocable
    [%ac0 %r23                  #t 23 uptr]
    [%xp  %r24                  #t 24 uptr]
    [%ts  %r8                   #f  8 uptr]
    [%td  %r25                  #t 25 uptr]
    [%cp  %r26                  #t 26 uptr]
    [     %r0  %Carg1 %Cretval  #f  0 uptr]
    [     %r1  %Carg2           #f  1 uptr]
    [     %r2  %Carg3 %reify1   #f  2 uptr]
    [     %r3  %Carg4 %reify2   #f  3 uptr]
    [     %r4  %Carg5 %save1    #f  4 uptr]
    [     %r5  %Carg6           #f  5 uptr]
    [     %r6  %Carg7           #f  6 uptr]
    [     %r7  %Carg8           #f  7 uptr]
    [     %r9                   #f  9 uptr]
    [     %r12                  #f 12 uptr]
    [     %r13                  #f 13 uptr]
    [     %r14                  #f 14 uptr]
    [     %r15                  #f 15 uptr]
    [     %lr                   #f 30 uptr] ; %lr is trashed by 'c' calls including calls to hand-coded routines like get-room
    [%fp1           %v16        #f 16 fp]
    [%fp2           %v17        #f 17 fp]
    [%fp3           %v18        #f 18 fp]
    [%fp4           %v19        #f 19 fp]
    [%fp5           %v20        #f 20 fp]
    [%fp6           %v21        #f 21 fp]
  )
  (machine-dependent
    [%jmptmp %argtmp            #f 10 uptr]
    [%argtmp2                   #f 11 uptr]
    [%sp %real-zero             #t 31 uptr]
    [%Cfparg1 %Cfpretval      %v0   #f  0 fp]
    [%Cfparg2                 %v1   #f  1 fp]
    [%Cfparg3                 %v2   #f  2 fp]
    [%Cfparg4                 %v3   #f  3 fp]
    [%Cfparg5                 %v4   #f  4 fp]
    [%Cfparg6                 %v5   #f  5 fp]
    [%Cfparg7                 %v6   #f  6 fp]
    [%Cfparg8                 %v7   #f  7 fp]
    ;; etc., but FP registers v8-v15 are preserved
    ))

;;; SECTION 2: instructions
(module (md-handle-jump ; also sets primitive handlers
         mem->mem
         fpmem->fpmem
         coercible?
         coerce-opnd)
  (import asm-module)

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

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

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

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

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

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

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

  (define fpmem->fpmem mem->mem)

  ;; `define-instruction` code takes care of `ur` and `fpur`, to which
  ;; all type-compatible values must convert
  (define-syntax coercible?
    (syntax-rules ()
      [(_ ?a ?aty*)
       (let ([a ?a] [aty* ?aty*])
         (or (and (memq 'unsigned12 aty*) (imm-unsigned12? a))
             (and (memq 'neg-unsigned12 aty*) (imm-neg-unsigned12? a))
             (and (memq 'funkymask aty*) (imm-funkymask? a))
             (and (memq 'imm-constant aty*) (imm-constant? a))
             (and (memq 'mem aty*) (mem? a))
             (and (memq 'fpmem aty*) (fpmem? a))))]))

  ;; `define-instruction` doesn't try to cover `ur` and `fpur`
  (define-syntax coerce-opnd ; passes k something compatible with aty*
    (syntax-rules ()
      [(_ ?a ?aty* ?k)
       (let ([a ?a] [aty* ?aty*] [k ?k])
         (cond
           [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)]
           [(and (memq 'fpmem aty*) (fpmem? a)) (fpmem->fpmem a k)]
           [(and (memq 'unsigned12 aty*) (imm-unsigned12? a)) (k (imm->imm a))]
           [(and (memq 'neg-unsigned12 aty*) (imm-neg-unsigned12? a)) (k (imm->negate-imm a))]
           [(and (memq 'funkymask aty*) (imm-funkymask? a)) (k (imm->imm a))]
           [(and (memq 'imm-constant aty*) (imm-constant? a)) (k (imm->imm a))]
           [(memq 'ur aty*)
            (cond
              [(ur? a) (k a)]
              [(imm? a)
               (let ([u (make-tmp 'u)])
                 (seq
                   (build-set! ,u ,(imm->imm a))
                   (k u)))]
              [(mem? a)
               (mem->mem a
                 (lambda (a)
                   (let ([u (make-tmp 'u)])
                     (seq
                       (build-set! ,u ,a)
                       (k u)))))]
              [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
           [(memq 'fpur aty*)
            (cond
              [(fpur? a) (k a)]
              [(fpmem? a)
               (fpmem->fpmem a
                 (lambda (a)
                   (let ([u (make-tmp 'u 'fp)])
                     (seq
                       (build-set! ,u ,a)
                       (k u)))))]
              [else
               (sorry! 'coerce-opnd "unexpected operand ~s" a)])]
           [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))]))

  (define md-handle-jump
    (lambda (t)
      (with-output-language (L15d Tail)
        (define long-form
          (lambda (e)
            (let ([tmp (make-tmp 'utmp)])
              (values
                (in-context Effect `(set! ,(make-live-info) ,tmp ,e))
                `(jump ,tmp)))))
        (nanopass-case (L15c Triv) t
          [,lvalue
           (if (mem? lvalue)
               (mem->mem lvalue (lambda (e) (values '() `(jump ,e))))
               (values '() `(jump ,lvalue)))]
          [(literal ,info)
           (guard (and (not (info-literal-indirect? info))
                       (memq (info-literal-type info) '(entry library-code))))
           (values '() `(jump (literal ,info)))]
          [(label-ref ,l ,offset)
           (values '() `(jump (label-ref ,l ,offset)))]
          [else (long-form t)]))))

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

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

  (define-instruction value (- -/ovfl -/eq -/pos)
    [(op (z ur) (x ur) (y unsigned12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))]
    [(op (z ur) (x ur) (y neg-unsigned12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '-))) ,x ,y))]
    [(op (z ur) (x ur) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '-))) ,x ,y))])

  (define-instruction value (+ +/ovfl +/carry)
    [(op (z ur) (x ur) (y unsigned12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))]
    [(op (z ur) (x ur) (y neg-unsigned12))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub (not (eq? op '+))) ,x ,y))]
    [(op (z ur) (x unsigned12) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,y ,x))]
    [(op (z ur) (x ur) (y ur))
     `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (not (eq? op '+))) ,x ,y))])

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

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

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

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

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

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

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

  (define-instruction value popcount
    [(op (z ur) (x ur))
     (let ([u (make-tmp 'u)])
       (seq
        `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill))
        `(set! ,(make-live-info) ,z (asm ,info ,asm-popcount ,x ,u))))])

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

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

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

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

  (let ()
    (define imm-zero (with-output-language (L15d Triv) `(immediate 0)))
    (define load/store
      (lambda (x y w type k) ; x ur, y ur, w ur or imm
        (with-output-language (L15d Effect)
          (if (ur? w)
              (if (eq? y %zero)
                  (k x w imm-zero)
                  (let ([u (make-tmp 'u)])
                    (seq
                      `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w))
                      (k x u imm-zero))))
              (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])])
                (cond
                  [(and (eq? y %zero)
                        (aligned-offset? n (case type
                                             [(unsigned-32 integer-32) 2]
                                             [(unsigned-16 integer-16) 1]
                                             [(unsigned-8 integer-8) 0]
                                             [else 3])))
                   (let ([w (in-context Triv `(immediate ,n))])
                     (k x y w))]
                  [(and (eq? y %zero) (signed9? n))
                   (let ([w (in-context Triv `(immediate ,n))])
                     (k x y w))]
                  [(and (not (eq? y %zero)) (unsigned12? n))
                   (let ([w (in-context Triv `(immediate ,n))])
                     (let ([u (make-tmp 'u)])
                       (seq
                        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w))
                        (k x u imm-zero))))]
                  [(and (not (eq? y %zero)) (unsigned12? (- n)))
                   (let ([w (in-context Triv `(immediate ,(- n)))])
                     (let ([u (make-tmp 'u)])
                       (seq
                        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-sub #f) ,y ,w))
                        (k x u imm-zero))))]
                  [else 
                   (let ([u (make-tmp 'u)])
                     (seq
                       `(set! ,(make-live-info) ,u (immediate ,n))
                       (if (eq? y %zero)
                           (k x u imm-zero)
                           (seq
                            `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,u))
                            (k u y imm-zero)))))]))))))
    (define-instruction value (load)
      [(op (z ur) (x ur) (y ur) (w ur imm-constant))
       (let ([type (info-load-type info)])
         (load/store x y w type
           (lambda (x y w)
             (let ([instr `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-load type) ,x ,y ,w))])
               (if (info-load-swapped? info)
                   (seq
                     instr
                     `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-swap type) ,z)))
                   instr)))))])
    (define-instruction effect (store)
      [(op (x ur) (y ur) (w ur imm-constant) (z ur))
       (let ([type (info-load-type info)])
         (load/store x y w type
           (lambda (x y w)
             (if (info-load-swapped? info)
                 (let ([u (make-tmp 'unique-bob)])
                   (seq
                     `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-swap type) ,z))
                     `(asm ,null-info ,(asm-store type) ,x ,y ,w ,u)))
                 `(asm ,null-info ,(asm-store type) ,x ,y ,w ,z)))))]))

  (define-instruction value (load-single->double)
    [(op (x fpur) (y fpmem))
     (let ([u (make-tmp 'u 'fp)])
       (seq
        `(set! ,(make-live-info) ,u (asm ,null-info ,asm-fpmove-single ,y))
        `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt 'single->double) ,u))))])

  (define-instruction effect (store-double->single)
    [(op (x fpmem) (y fpur))
     (let ([u (make-tmp 'u 'fp)])
       (seq
        `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-fl-cvt 'double->single) ,y))
        `(asm ,info ,asm-fpmove-single ,x ,u)))])

  (define-instruction effect (store-single)
    [(op (x fpmem) (y fpur))
     `(asm ,info ,asm-fpmove-single ,x ,y)])

  (define-instruction value (load-single)
    [(op (x fpur) (y fpmem fpur))
     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpmove-single ,y))])

  (define-instruction value (single->double double->single)
    [(op (x fpur) (y fpur))
     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))])

  (define-instruction value (fpt)
    [(op (x fpur) (y ur))
     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))])

  (define-instruction value (fptrunc)
    [(op (x ur) (y fpur))
     `(set! ,(make-live-info) ,x (asm ,info ,asm-fptrunc ,y))])

  (define-instruction value (fpsingle)
    [(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))])

  (define-instruction value (fpmove)
    [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)]
    [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)])

  (let ()
    (define (mem->mem mem new-type)
      (nanopass-case (L15d Triv) mem
        [(mref ,x0 ,x1 ,imm ,type)
         (with-output-language (L15d Lvalue) `(mref ,x0 ,x1 ,imm ,new-type))]))

    (define-instruction value (fpcastto)
      [(op (x mem) (y fpur)) `(set! ,(make-live-info) ,(mem->mem x 'fp) ,y)]
      [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastto ,y))])
    
    (define-instruction value (fpcastfrom)
      [(op (x fpmem) (y ur)) `(set! ,(make-live-info) ,(mem->mem x 'uptr) ,y)]
      [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,y))]))

  (define-instruction value (fp+ fp- fp/ fp*)
    [(op (x fpur) (y fpur) (z fpur))
     `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))])

  (define-instruction value (fpsqrt)
    [(op (x fpur) (y fpur))
     `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))])

  (define-instruction pred (fp= fp< fp<=)
    [(op (x fpur) (y fpur))
     (let ([info (make-info-condition-code op #f #f)])
       (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))])

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

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

  (define-instruction value (read-time-stamp-counter)
    [(op (z ur)) `(set! ,(make-live-info) ,z (asm ,null-info
                                                  ;; CNTPCT_EL0
                                                  ,(asm-read-counter #b11 #b011 #b1110 #b0000 #b001)))])

  (define-instruction value (read-performance-monitoring-counter)
    [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (immediate 0))])

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

  (define-instruction value activate-thread
    [(op (z ur))
     (safe-assert (eq? z %Cretval))
     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
       (seq
         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
         `(set! ,(make-live-info) ,z (asm ,info ,asm-activate-thread ,ulr))))])

  (define-instruction effect deactivate-thread
    [(op)
     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
       (seq
         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
         `(asm ,info ,asm-deactivate-thread ,ulr)))])

  (define-instruction effect unactivate-thread
    [(op (x ur))
     (safe-assert (eq? x %Carg1))
     (let ([ulr (make-precolored-unspillable 'ulr %lr)])
       (seq
         `(set! ,(make-live-info) ,ulr (asm ,null-info ,asm-kill))
         `(asm ,info ,asm-unactivate-thread ,x ,ulr)))])

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

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

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

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

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

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

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

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

  (define-instruction effect (store-store-fence)
    [(op)
     `(asm ,info ,(asm-fence 'store-store))])

  (define-instruction effect (acquire-fence)
    [(op)
     `(asm ,info ,(asm-fence 'acquire))])

  (define-instruction effect (release-fence)
    [(op)
     `(asm ,info ,(asm-fence 'release))])

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

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

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

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

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

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

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

  (define-instruction effect save-flrv
    [(op) `(asm ,info ,(asm-push-fpmultiple (list %Cfpretval)))])

  (define-instruction effect restore-flrv
    [(op) `(asm ,info ,(asm-pop-fpmultiple (list %Cfpretval)))])

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

;;; SECTION 3: assembler
(module asm-module (; required exports
                     asm-move asm-move/extend asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump
                     asm-mul asm-smulh asm-div asm-add asm-sub asm-logand asm-logor asm-logxor
                     asm-pop-multiple asm-shiftop asm-logand asm-lognot asm-cmp/asr63 asm-popcount
                     asm-logtest asm-fp-relop asm-relop asm-push-multiple asm-push-fpmultiple asm-pop-fpmultiple
                     asm-indirect-jump asm-literal-jump
                     asm-direct-jump asm-return-address asm-jump asm-conditional-jump
                     asm-indirect-call asm-condition-code
                     asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom
                     asm-fptrunc asm-fpsingle
                     asm-lock asm-lock+/- asm-cas asm-fence
                     asm-fpop-2 asm-fpsqrt asm-c-simple-call
                     asm-return asm-c-return asm-size
                     asm-enter asm-foreign-call asm-foreign-callable
                     asm-debug
                     asm-read-counter
                     asm-inc-cc-counter
                     signed9? unsigned12? aligned-offset? funkymask shifted16
                     ; threaded version specific
                     asm-get-tc
                     asm-activate-thread asm-deactivate-thread asm-unactivate-thread
                     ; machine dependent exports
                     asm-kill)

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

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

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

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

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

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

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

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

  (define-op movzi   movzi-op #b10) ; 16-bit immediate, shifted
  (define-op movki   movzi-op #b11) ; 16-bit immediate, shifted
  (define-op movi    movi-op)  ; immediate encoded as a mask

  (define-op addi  add-imm-op  #b0) ; selector is at bit 30 (op)
  (define-op subi  add-imm-op  #b1)

  (define-op andi  logical-imm-op  #b00)
  (define-op orri  logical-imm-op  #b01)
  (define-op eori  logical-imm-op  #b10)

  (define-op add   binary-op  #b0)
  (define-op sub   binary-op  #b1)
  
  (define-op and   logical-op  #b00)
  (define-op orr   logical-op  #b01)
  (define-op eor   logical-op  #b10)

  (define-op cmp        cmp-op  #b1101011 #b00 0)
  (define-op tst        cmp-op  #b1101010 #b00 0)
  (define-op cmp/asr63  cmp-op  #b1101011 #b10 63)
  
  (define-op cmpi  cmp-imm-op #b1) ; selector is at bit 30 (op)
  (define-op cmni  cmp-imm-op #b0)
  (define-op tsti  logical-imm-op #b11 #f `(reg . ,%real-zero))

  (define-op mov   mov-op  #b1 #b0) ; selectors are a bit 31 (sf) and 21 (N)
  (define-op movw  mov-op  #b0 #b0)
  (define-op mvn   mov-op  #b1 #b1)

  (define-op lsli  shifti-op #b10 'l) ; selector is at bit 29 (opc)
  (define-op lsri  shifti-op #b10 'r) 
  (define-op asri  shifti-op #b00 'r)

  (define-op lsl  shift-op #b00) ; selector is at bit 10 (op2)
  (define-op lsr  shift-op #b01) 
  (define-op asr  shift-op #b10)

  (define-op sxtb extend-op  #b100 #b1 #b000111) ; selectors are at bits 29 (sfc+opc), 22 (N), and 10 (imms)
  (define-op sxth extend-op  #b100 #b1 #b001111)
  (define-op sxtw extend-op  #b100 #b1 #b011111)
  (define-op uxtb extend-op  #b010 #b0 #b000111)
  (define-op uxth extend-op  #b010 #b0 #b001111)

  (define-op mul   mul-op  #b000) ; selector is at bit 21
  (define-op smulh mul-op  #b010)

  (define-op sdiv  div-op)

  (define-op cnt    cnt-op)
  (define-op addv.b addv.b-op)

  ;; scaled variants (offset must be aligned):
  (define-op ldri    load-imm-op  3 #b11 #b0 #b01) ; selectors are at bits 30 (size), 26, and 22 (opc)
  (define-op ldrbi   load-imm-op  0 #b00 #b0 #b01)
  (define-op ldrhi   load-imm-op  1 #b01 #b0 #b01)
  (define-op ldrwi   load-imm-op  2 #b10 #b0 #b01)
  (define-op ldrfi   load-imm-op  3 #b11 #b1 #b01)
  (define-op ldrfsi  load-imm-op  2 #b10 #b1 #b01) ; single-precision

  (define-op ldrsbi  load-imm-op  0 #b00 #b0 #b10)
  (define-op ldrshi  load-imm-op  1 #b01 #b0 #b10)
  (define-op ldrswi  load-imm-op  2 #b10 #b0 #b10)

  (define-op stri    load-imm-op  3 #b11 #b0 #b00)
  (define-op strbi   load-imm-op  0 #b00 #b0 #b00)
  (define-op strhi   load-imm-op  1 #b01 #b0 #b00)
  (define-op strwi   load-imm-op  2 #b10 #b0 #b00)
  (define-op strfi   load-imm-op  3 #b11 #b1 #b00)
  (define-op strfsi  load-imm-op  2 #b10 #b1 #b00) ; single-precision

  ;; unscaled variants (offset must be signed9):
  (define-op lduri    load-unscaled-imm-op  #b11 #b0 #b01) ; selectors are at bits 30 (size), 26, and 22 (opc)
  (define-op ldurbi   load-unscaled-imm-op  #b00 #b0 #b01)
  (define-op ldurhi   load-unscaled-imm-op  #b01 #b0 #b01)
  (define-op ldurwi   load-unscaled-imm-op  #b10 #b0 #b01)
  (define-op ldurfi   load-unscaled-imm-op  #b11 #b1 #b01)
  (define-op ldurfsi  load-unscaled-imm-op  #b10 #b1 #b01) ; single-precision

  (define-op ldursbi  load-unscaled-imm-op  #b00 #b0 #b10)
  (define-op ldurshi  load-unscaled-imm-op  #b01 #b0 #b10)
  (define-op ldurswi  load-unscaled-imm-op  #b10 #b0 #b10)

  (define-op sturi    load-unscaled-imm-op  #b11 #b0 #b00)
  (define-op sturbi   load-unscaled-imm-op  #b00 #b0 #b00)
  (define-op sturhi   load-unscaled-imm-op  #b01 #b0 #b00)
  (define-op sturwi   load-unscaled-imm-op  #b10 #b0 #b00)
  (define-op sturfi   load-unscaled-imm-op  #b11 #b1 #b00)
  (define-op sturfsi  load-unscaled-imm-op  #b10 #b1 #b00) ; single-precision
  
  (define-op ldr     load-op     #b11 #b0 #b01)  ; selectors are at bits 30 (size), 26, and 22 (opc)
  (define-op ldrw    load-op     #b10 #b0 #b01)
  (define-op ldrh    load-op     #b01 #b0 #b01)
  (define-op ldrb    load-op     #b00 #b0 #b01)
  (define-op ldrf    load-op     #b11 #b1 #b01)
  (define-op ldrfs   load-op     #b10 #b1 #b01)

  (define-op ldrsw   load-op     #b10 #b0 #b10)
  (define-op ldrsh   load-op     #b01 #b0 #b10)
  (define-op ldrsb   load-op     #b00 #b0 #b10)

  (define-op str     load-op     #b11 #b0 #b00)
  (define-op strw    load-op     #b10 #b0 #b00)
  (define-op strh    load-op     #b01 #b0 #b00)
  (define-op strb    load-op     #b00 #b0 #b00)
  (define-op strf    load-op     #b11 #b1 #b00)
  (define-op strfs   load-op     #b10 #b1 #b00)

  (define-op ldr/postidx  load-idx-op  #b01 #b0 #b01) ; selectors are at bits 22 (opc), 26, and 10
  (define-op str/preidx   load-idx-op  #b00 #b0 #b11)

  (define-op ldrf/postidx load-idx-op  #b01 #b1 #b01)
  (define-op strf/preidx  load-idx-op  #b00 #b1 #b11)

  (define-op ldrp/postidx loadp-idx-op  #b10 #b0 #b001 #b1) ; selectors are at bits 30 (opc), 26, 23, and 22 (L)
  (define-op strp/preidx  loadp-idx-op  #b10 #b0 #b011 #b0)

  (define-op ldrpf/postidx loadp-idx-op  #b01 #b1 #b001 #b1)
  (define-op strpf/preidx  loadp-idx-op  #b01 #b1 #b011 #b0)

  (define-op ldxr   ldxr-op      #b1 `(reg . ,%real-zero))
  (define-op stxr   ldxr-op      #b0)

  (define-op dmbst    dmb-op #b1110)
  (define-op dmbish   dmb-op #b1011)
  (define-op dmbishld dmb-op #b1001)
  (define-op dmbishst dmb-op #b1010)

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

  (define-op br    branch-reg-op       #b00)
  (define-op blr   branch-reg-op       #b01)

  (define-op b     branch-always-label-op)

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

  (define-op adr   adr-op)
  (define-op ret   ret-op)

  (define-op fcvt.s->d  fcvt-op  #b00 #b01)
  (define-op fcvt.d->s  fcvt-op  #b01 #b00)

  (define-op fcvtzs  fdcvt-op  #b11 #b000) ; selectors are at bits 19 (mode) and 1 6(opcode)
  (define-op scvtf   fdcvt-op  #b00 #b010)

  (define-op fmov       fmov-op  #b0 #b000 #b1) ; selectors are at bits 31, 16, and 14
  (define-op fmov.f->g  fmov-op  #b1 #b110 #b0)
  (define-op fmov.g->f  fmov-op  #b1 #b111 #b0)

  (define-op fcmp fcmp-op)

  (define-op rev    rev-op  #b11) ; selector is at bit 10 (opc)
  (define-op rev16  rev-op  #b01)
  (define-op rev32  rev-op  #b10)

  (define-op mrs  mrs-op)

  (define-op und  und-op)

  (define-op fadd  f-arith-op  #b0010) ; selector is at bit 12
  (define-op fsub  f-arith-op  #b0011)
  (define-op fmul  f-arith-op  #b0000)
  (define-op fdiv  f-arith-op  #b0001)

  (define-op fsqrt fsqrt-op)

  (define movzi-op
    (lambda (op opc dest imm shift code*)
      (emit-code (op dest imm shift code*)
        [31 #b1]
        [29 opc]
        [23 #b100101]
        [21 shift] ; `shift` is implicitly multiplied by 16
        [5  imm]
        [0  (ax-ea-reg-code dest)])))

  (define movi-op
    (lambda (op dest imm n+immr+imms code*)
      (let ([n (car n+immr+imms)]
            [immr (cadr n+immr+imms)]
            [imms (caddr n+immr+imms)])
        (emit-code (op dest imm n+immr+imms code*)
          [23 #b101100100]
          [22 n]
          [16 immr]
          [10 imms]
          [5  #b11111]
          [0  (ax-ea-reg-code dest)]))))

  (define add-imm-op
    (lambda (op opcode set-cc? dest src imm code*)
      (emit-code (op dest src imm (and set-cc? #t) code*)
        [31 #b1]
        [30 opcode]
        [29 (if set-cc? #b1 #b0)]
        [24 #b10001]
        [22 #b00] ; shift
        [10 imm]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define logical-imm-op
    (lambda (op opcode set-cc? dest src imm code*)
      (safe-assert (not set-cc?)) ; but opcode may imply setting condition codes
      (let ([n+immr+imms (funkymask imm)])
        (let ([n (car n+immr+imms)]
              [immr (cadr n+immr+imms)]
              [imms (caddr n+immr+imms)])
          (emit-code (op dest src imm code*)
            [31 #b1]
            [29 opcode]
            [23 #b100100]
            [22 n]
            [16 immr]
            [10 imms]
            [5  (ax-ea-reg-code src)]
            [0  (ax-ea-reg-code dest)])))))

  (define binary-op
    (lambda (op opcode set-cc? dest src0 src1 code*)
      (emit-code (op dest src0 src1 (and set-cc? #t) code*)
        [31 #b1]
        [30 opcode]
        [29 (if set-cc? #b1 #b0)]
        [24 #b01011]
        [22 #b00] ; shift type (applied to src1)
        [21 #b0]
        [16 (ax-ea-reg-code src1)]
        [10 #b000000] ; shift amount
        [5  (ax-ea-reg-code src0)]
        [0  (ax-ea-reg-code dest)])))

  (define logical-op
    (lambda (op opcode set-cc? dest src0 src1 code*)
      (safe-assert (not set-cc?))
      (emit-code (op dest src0 src1 code*)
        [31 #b1]
        [29 opcode]
        [24 #b01010]
        [22 #b00] ; shift type (applied to src1)
        [21 #b0]
        [16 (ax-ea-reg-code src1)]
        [10 #b000000] ; shift amount
        [5  (ax-ea-reg-code src0)]
        [0  (ax-ea-reg-code dest)])))

  (define cmp-op
    (lambda (op opcode shift-type shift-amt src0 src1 code*)
      (emit-code (op src0 src1 code*)
        [31 #b1]
        [24 opcode]
        [22 shift-type] ; applied to src1
        [21 #b0]
        [16 (ax-ea-reg-code src1)]
        [10 shift-amt]
        [5  (ax-ea-reg-code src0)]
        [0  #b11111])))

  (define cmp-imm-op
    (lambda (op opc src imm code*)
      (safe-assert (unsigned12? imm))
      (emit-code (op src imm code*)
        [31 #b1]
        [30 opc]
        [24 #b110001]
        [22 #b00] ; shift amount (applied to immediate)
        [10 imm]
        [5  (ax-ea-reg-code src)]
        [0  #b11111])))

  (define mov-op
    (lambda (op sz neg dest src code*)
      (emit-code (op dest src code*)
        [31 sz]
        [22 #b010101000]
        [21 neg]
        [16 (ax-ea-reg-code src)]
        [5  #b11111]
        [0  (ax-ea-reg-code dest)])))

  (define shifti-op
    (lambda (op opcode dir dest src imm code*)
      (emit-code (op dest src imm code*)
        [31 #b1]
        [29 opcode]
        [22 #b1001101]
        [16 (if (eq? dir 'l)
                (fx- 64 imm)
                imm)]
        [10 (if (eq? dir 'l)
                (fx- 63 imm)
                63)]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define shift-op
    (lambda (op opcode dest src0 src1 code*)
      (emit-code (op dest src0 src1 code*)
        [29 #b100]
        [21 #b11010110]
        [16 (ax-ea-reg-code src1)]
        [12 #b0010]
        [10 opcode]
        [5  (ax-ea-reg-code src0)]
        [0  (ax-ea-reg-code dest)])))

  (define extend-op
    (lambda (op sf+opc n imms-as-op2 dest src code*)
      (emit-code (op dest src code*)
        [29 sf+opc]
        [23 #b100110]
        [22 n]
        [16 #b000000]
        [10 imms-as-op2]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define mul-op
    (lambda (op opcode dest src0 src1 code*)
      (emit-code (op dest src0 src1 code*)
        [29 #b100]
        [24 #b11011]
        [21 opcode]
        [16 (ax-ea-reg-code src1)]
        [10 #b011111]
        [5  (ax-ea-reg-code src0)]
        [0  (ax-ea-reg-code dest)])))

  (define div-op
    (lambda (op dest src0 src1 code*)
      (emit-code (op dest src0 src1 code*)
        [29 #b100]
        [21 #b11010110]
        [16 (ax-ea-reg-code src1)]
        [10 #b000011]
        [5  (ax-ea-reg-code src0)]
        [0  (ax-ea-reg-code dest)])))

  (define cnt-op
    (lambda (op dest src code*)
      (emit-code (op dest src code*)
        [29 #b000]
        [24 #b01110]
        [22 #b00] ; size
        [17 #b10000]
        [10 #b0010110]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define addv.b-op
    (lambda (op dest src code*)
      (emit-code (op dest src code*)
        [29 #b000]
        [24 #b01110]
        [22 #b00] ; size: 00 => b
        [17 #b11000]
        [10 #b1101110]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define load-imm-op
    (lambda (op scale size kind opc dest src imm code*)
      (emit-code (op dest src imm code*)
        [30 size]
        [27 #b111]
        [26 kind]
        [24 #b01]
        [22 opc]
        [10 (fxsrl imm scale)]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define load-unscaled-imm-op
    (lambda (op size kind opc dest src imm code*)
      (emit-code (op dest src imm code*)
        [30 size]
        [27 #b111]
        [26 kind]
        [24 #b00]
        [22 opc]
        [21 #b0]
        [12 (fxand imm #x1FF)]
        [10 #b00]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define load-op
    (lambda (op size kind opc dest src0 src1 code*)
      (emit-code (op dest src0 src1 code*)
        [30 size]
        [27 #b111]
        [26 kind]
        [24 #b00]
        [22 opc]
        [21 #b1]
        [16 (ax-ea-reg-code src1)]
        [13 #b011] ; option, where #x011 => 64-bit source address
        [12 #b0] ; shift
        [10 #b10]
        [5  (ax-ea-reg-code src0)]
        [0  (ax-ea-reg-code dest)])))

  (define load-idx-op
    (lambda (op opc mode idx dest src imm code*)
      (emit-code (op dest src imm code*)
        [30 #b11]
        [27 #b111]
        [26 mode]
        [24 #b00]
        [22 opc]
        [21 #b0]
        [12 (fxand imm (fx- (fxsll 1 9) 1))]
        [10 idx]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

    (define loadp-idx-op
      (lambda (op opc mode opx l dest0 dest1 src imm code*)
        (emit-code (op dest0 dest1 src imm code*)
          [30 opc]
          [27 #b101]
          [26 mode]
          [23 opx]
          [22 l]
          [15 (fxand (fxsrl imm 3) (fx- (fxsll 1 7) 1))]
          [10 (ax-ea-reg-code dest1)]
          [5  (ax-ea-reg-code src)]
          [0 (ax-ea-reg-code dest0)])))

  (define ldxr-op
    (lambda (op mode dest2 dest src code*)
      (emit-code (op dest2 dest src code*)
        [30 #b11]
        [23 #b0010000]
        [22 mode]
        [21 0]
        [16 (ax-ea-reg-code dest2)]
        [15 #b0]
        [10 #b11111]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define dmb-op
    (lambda (op mode code*)
      (emit-code (op code*)
        [22 #b1101010100]
        [16 #b000011]
        [12 #b0011]
        [8  mode]
        [5  #b101]
        [0  #b11111])))

  (define branch-imm-op
    (lambda (op cond-bits imm code*)
      (safe-assert (branch-disp? imm))
      (emit-code (op imm code*)
        [24 #b01010100]
        [5  (fxand (fxsra imm 2) (fx- (fxsll 1 19) 1))]
        [4  #b0]
        [0  cond-bits])))

  (define branch-reg-op
    (lambda (op opcode reg code*)
      (emit-code (op reg code*)
        [24 #b11010110]
        [23 #b0]
        [21 opcode]
        [16 #b11111]
        [12 #b0000]
        [10 #b00]
        [5  (ax-ea-reg-code reg)]
        [0  #b00000])))

  (define-who branch-always-label-op
    (lambda (op dest code*)
      (record-case dest
        [(label) (offset l)
         (safe-assert (uncond-branch-disp? offset))
         (emit-code (op dest code*)
           [26 #b000101]
           [0  (fxand (fxsra (fx+ offset 4) 2) (fx- (fxsll 1 26) 1))])]
        [else (sorry! who "unexpected dest ~s" dest)])))

  (define-who branch-label-op
    (lambda (op cond-bits dest code*)
      (define (emit-branch offset)
	(safe-assert (branch-disp? (+ offset 4)))
	(emit-code (op dest code*)
          [24 #b01010100]
	  [5  (fxand (fxsra (fx+ offset 4) 2) (fx- (fxsll 1 19) 1))]
	  [4  #b0]
	  [0  cond-bits]))
      (record-case dest
        [(label) (offset l) (emit-branch offset)]
	[(imm) (n) (emit-branch n)] ; generated for long branches
        [else (sorry! who "unexpected dest ~s" dest)])))

  (define adr-op
    (lambda (op dest imm code*)
      (emit-code (op dest imm code*)
        [31 #b0]
        [29 (fxand imm #b11)]
        [24 #b10000]
        [5  (fxand (fxsra imm 2) (fx- (fxsll 1 19) 1))]
        [0  (ax-ea-reg-code dest)])))

  (define ret-op
    (lambda (op src code*)
      (emit-code (op src code*)
        [25 #b1101011]
        [21 #b0010]
        [16 #b11111]
        [12 #b0000]
        [10 #b00]
        [5  (ax-ea-reg-code src)]
        [0  #b00000])))

  (define fcvt-op
    (lambda (op type opc dest src code*)
      (emit-code (op dest src code*)
        [24 #b00011110]
        [22 type]
        [17 #b10001]
        [15 opc]
        [10 #b10000]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define fdcvt-op
    (lambda (op mode opcode dest src code*)
      (emit-code (op dest src code*)
        [29 #b100]
        [24 #b11110]
        [22 #b01] ; type
        [21 #b1]
        [19 mode]
        [16 opcode]
        [10 #b000000]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define fmov-op
    (lambda (op sf opcode opsel dest src code*)
      (emit-code (op dest src code*)
        [31 sf]
        [24 #b0011110]
        [22 #b01] ; type
        [21 #b1]
        [19 #b00]
        [16 opcode]
        [15 #b0]
        [14 opsel]
        [10 #b0000]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define f-arith-op
    (lambda (op opcode dest src0 src1 code*)
      (emit-code (op dest src0 src1 code*)
        [29 #b000]
        [24 #b11110]
        [22 #b01] ; type
        [21 #b1]
        [16 (ax-ea-reg-code src1)]
        [12 opcode]
        [10 #b10]
        [5  (ax-ea-reg-code src0)]
        [0  (ax-ea-reg-code dest)])))

  (define fsqrt-op
    (lambda (op dest src code*)
      (emit-code (op dest src code*)
        [29 #b000]
        [24 #b11110]
        [22 #b01] ; type
        [21 #b1]
        [17 #b0000]
        [15 #b11] ; opc
        [10 #b10000]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define fcmp-op
    (lambda (op src0 src1 code*)
      (emit-code (op src0 src1 code*)
        [24 #b00011110]
        [22 #b01]
        [21 #b1]
        [16 (ax-ea-reg-code src1)]
        [10 #b001000]
        [5  (ax-ea-reg-code src0)]
        [3  #b00] ; opc
        [0  #b000])))

  (define rev-op
    (lambda (op opc dest src code*)
      (emit-code (op dest src code*)
        [29 #b110]
        [21 #b11010110]
        [16 #b00000]
        [12 #b0000]
        [10 opc]
        [5  (ax-ea-reg-code src)]
        [0  (ax-ea-reg-code dest)])))

  (define mrs-op
    (lambda (op op0 op1 crn crm op2 dest code*)
      (emit-code (op dest code*)
        [22 #b1101010100]
        [20 #b11]
        [19 op0]
        [16 op1]
        [12 crn]
        [8  crm]
        [5  op2]
        [0 (ax-ea-reg-code dest)])))

  (define und-op
    (lambda (op code*)
      (emit-code (op code*)
        [0 0])))

  ;; asm helpers

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

  (define-syntax emit-code
    (lambda (x)
      ; NB: probably won't need emit-code to weed out #f
      (define build-maybe-cons*
        (lambda (e* e-ls)
          (if (null? e*)
              e-ls
              #`(let ([t #,(car e*)] [ls #,(build-maybe-cons* (cdr e*) e-ls)])
                  (if t (cons t ls) ls)))))
      (syntax-case x ()
        [(_ (op opnd ... ?code*) chunk ...)
         (let ([safe-check (lambda (e)
                             (if (fx= (debug-level) 0)
                                 e
                                 #`(let ([code #,e])
                                     (unless (<= 0 code (sub1 (expt 2 32)))
                                       (sorry! 'emit-code "bad result ~s for ~s"
                                               code
                                               (list op opnd ...)))
                                     code)))])
           (build-maybe-cons* #`((build long #,(safe-check #`(byte-fields chunk ...))))
             #'(aop-cons* `(asm ,op ,opnd ...) ?code*)))])))

  (define-syntax build
    (syntax-rules ()
      [(_ x e)
       (and (memq (datum x) '(byte word long)) (integer? (datum e)))
       (begin
         (safe-assert (fixnum? (datum e)))
         (quote (x . e)))]
      [(_ x e)
       (memq (datum x) '(byte word long))
       (cons 'x e #;(let ([x e]) (safe-assert (not (eqv? x #x53401c17))) x))]))

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

  (define signed9?
    (lambda (imm)
      (and (fixnum? imm) (fx<= (fx- (expt 2 8)) imm (fx- (expt 2 8) 1)))))

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

  (define aligned-offset?
    (case-lambda
     [(imm) (aligned-offset? imm (constant log2-ptr-bytes))]
     [(imm log2-bytes)
      (and (fixnum? imm)
           (eqv? 0 (fxand imm (fx- (fxsll 1 log2-bytes) 1)))
           ($fxu< imm (expt 2 (fx+ 12 log2-bytes))))]))

  (define funkymask
    (lambda (imm)
      ;; encode as `(list N immr imms)`, based on the LLVM implementation.
      (cond
        [(eqv? imm 0) #f]  ; can't do all 0s
        [(eqv? imm -1) #f] ; can't do all 1s
        [(>= imm (sub1 (expt 2 63))) #f]  ; can't do all 1s or more
        [(<= imm (- (expt 2 63))) #f] ; can't less than most negative
        [else
         ;; Immediate is representable in 64 bits without being 0 or -1.
         ;; First, find the smallest width that can be replicated to match `imm`:
         (let* ([imm (bitwise-and imm (sub1 (expt 2 64)))] ; view as positive
                [width (let loop ([width 32])
                        (let ([mask (sub1 (bitwise-arithmetic-shift-left 1 width))])
                          (if (= (bitwise-and imm mask)
                                 (bitwise-and (bitwise-arithmetic-shift-right imm width) mask))
                              (if (fx= width 2)
                                  2
                                  (loop (fxsrl width 1)))
                              (fx* width 2))))])
           (let ([v (bitwise-and imm (sub1 (bitwise-arithmetic-shift-left 1 width)))])
             ;; The encoding will work if v matches 1*0*1* or 0*1*0*
             (let* ([count-trailing (lambda (val v)
                                      (let loop ([v v])
                                        (if (= val (bitwise-and v 1))
                                            (fx+ 1 (loop (bitwise-arithmetic-shift-right v 1)))
                                            0)))]
                    [0s (count-trailing 0 v)]
                    [1s (count-trailing 1 (bitwise-arithmetic-shift-right v 0s))]
                    [vx (bitwise-arithmetic-shift-right v (fx+ 0s 1s))])
               (let-values ([(rotate total-1s)
                             (cond
                               [(eqv? 0 vx)
                                (if (fx= 0s 0)
                                    ;; No rotation needed
                                    (values 0 1s)
                                    ;; Rotate left to fill in `0s` zeros, and the encoding works
                                    (values (fx- width 0s) 1s))]
                               [(eqv? 0 0s)
                                ;; There could be more 1s at the top that we can rotate around
                                (let* ([0s (count-trailing 0 vx)])
                                  ;; Assert: 0s < width - 1s
                                  (cond
                                    [(= (bitwise-arithmetic-shift vx 0s)
                                        (sub1 (bitwise-arithmetic-shift-left 1 (fx- width 0s 1s))))
                                     ;; All 1s are in lowest bits or highest bits, so rotate
                                     (values (fx- width 0s 1s)
                                             (fx- width 0s))]
                                    [else (values #f #f)]))]
                               [else (values #f #f)])])
                 (and rotate
                      (list (if (fx= width 64) 1 0)
                            rotate
                            (bitwise-ior (case width
                                           [(2)  #b111100]
                                           [(4)  #b111000]
                                           [(8)  #b110000]
                                           [(16) #b100000]
                                           [else 0])
                                         (fx- total-1s 1))))))))])))

  (define shifted16
    (lambda (imm)
      (let loop ([shift 0])
        (and (fx< shift 4)
             (if (= imm (bitwise-and (bitwise-arithmetic-shift-left #xFFFF (fx* shift 16)) imm))
                 (cons (bitwise-arithmetic-shift-right imm (fx* shift 16)) shift)
                 (loop (fx+ shift 1)))))))

  (define branch-disp?
    (lambda (x)
      (and (fixnum? x) 
           (fx<= (- (expt 2 20)) x (- (expt 2 20) 1))
           (not (fxlogtest x #b11)))))

  (define uncond-branch-disp?
    (lambda (x)
      (let ([x (+ x 4)]) ; because `branch-always-label-op` adds 4
        (and (fixnum? x) 
             (fx<= (- (expt 2 27)) x (- (expt 2 27) 1))
             (not (fxlogtest x #b11))))))
  
  (define asm-size
    (lambda (x)
      (case (car x)
        [(asm arm64-abs arm64-jump arm64-call) 0]
        [(long) 4]
        [else 8])))

  (define ax-mov64
    (lambda (dest n code*)
      (emit movzi dest (logand n #xffff) 0
        (emit movki dest (logand (bitwise-arithmetic-shift-right n 16) #xffff) 1
          (emit movki dest (logand (bitwise-arithmetic-shift-right n 32) #xffff) 2
            (emit movki dest (logand (bitwise-arithmetic-shift-right n 48) #xffff) 3
               code*))))))

  (define ax-movi
    (lambda (dest n code*) 
      (cond
        [(shifted16 n) =>
         (lambda (imm+shift)
           (emit movzi dest (car imm+shift) (cdr imm+shift) code*))]
        [(funkymask n) =>
         (lambda (n+immr+imms)
           (emit movi dest n n+immr+imms code*))]
        [(unsigned12? n)
         (emit movzi dest 0 0
           (emit addi #f dest dest n code*))]
        [(unsigned12? (- n))
         (emit movzi dest 0 0
           (emit subi #f dest dest (- n) code*))]
        [else
         (let loop ([n n] [shift 0] [init? #t])
           (cond
             [(or (eqv? n 0) (fx= shift 4)) code*]
             [else
              (let ([m (logand n #xFFFF)])
                (cond
                  [(eqv? m 0)
                   (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) init?)]
                  [else
                   (let ([code* (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) #f)])
                     (if init?
                         (emit movzi dest m shift code*)
                         (emit movki dest m shift code*)))]))]))])))

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

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

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

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

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

  (define asm-div
    (lambda (code* dest src0 src1)
      (Trivit (dest src0 src1)
        (emit sdiv dest src0 src1 code*))))

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

  (define-who asm-cmp/asr63
    (lambda (code* src0 src1)
      (Trivit (src0 src1)
        (emit cmp/asr63 src0 src1 code*))))

  (define-who asm-fl-cvt
    (lambda (op)
      (lambda (code* dest src)
        (Trivit (dest src)
          (case op
            [(single->double)
             (emit fcvt.s->d dest src code*)]
            [(double->single)
             (emit fcvt.d->s dest src code*)]
            [else (sorry! who "unrecognized op ~s" op)])))))

  (define-who asm-load
    (lambda (type)
      (rec asm-load-internal
        (lambda (code* dest base index offset)
          (let ([n (nanopass-case (L16 Triv) offset
                     [(immediate ,imm) imm]
                     [else (sorry! who "unexpected non-immediate offset ~s" offset)])])
            ;; Assuming that `n` is either aligned and in range (fits
            ;; unsigned in 12 bits after shifting by type bits) or unaligned
            ;; and small (fits in 9 bits)
            (Trivit (dest base)
              (cond
                [(eq? index %zero)
                 (cond
                   [(signed9? n)
                    (case type
                      [(integer-64 unsigned-64) (emit lduri dest base n code*)]
                      [(integer-32) (emit ldurswi dest base n code*)]
                      [(unsigned-32) (emit ldurwi dest base n code*)]
                      [(integer-16) (emit ldurshi dest base n code*)]
                      [(unsigned-16) (emit ldurhi dest base n code*)]
                      [(integer-8) (emit ldursbi dest base n code*)]
                      [(unsigned-8) (emit ldurbi dest base n code*)]
                      [else (sorry! who "unexpected mref type ~s" type)])]
                   [else
                    (case type
                      [(integer-64 unsigned-64) (emit ldri dest base n code*)]
                      [(integer-32) (emit ldrswi dest base n code*)]
                      [(unsigned-32) (emit ldrwi dest base n code*)]
                      [(integer-16) (emit ldrshi dest base n code*)]
                      [(unsigned-16) (emit ldrhi dest base n code*)]
                      [(integer-8) (emit ldrsbi dest base n code*)]
                      [(unsigned-8) (emit ldrbi dest base n code*)]
                      [else (sorry! who "unexpected mref type ~s" type)])])]
                [(eqv? n 0)
                  (Trivit (index)
                    (case type
                      [(integer-64 unsigned-64) (emit ldr dest base index code*)]
                      [(integer-32) (emit ldrsw dest base index code*)]
                      [(unsigned-32) (emit ldrw dest base index code*)]
                      [(integer-16) (emit ldrsh dest base index code*)]
                      [(unsigned-16) (emit ldrh dest base index code*)]
                      [(integer-8) (emit ldrsb dest base index code*)]
                      [(unsigned-8) (emit ldrb dest base index code*)]
                      [else (sorry! who "unexpected mref type ~s" type)]))]
                [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))

  (define-who asm-store
    (lambda (type)
      (rec asm-store-internal
        (lambda (code* base index offset src)
          (let ([n (nanopass-case (L16 Triv) offset
                     [(immediate ,imm) imm]
                     [else (sorry! who "unexpected non-immediate offset ~s" offset)])])
            ;; Assuming that `n` is aligned and in range (fits
            ;; unsigned in 12 bits after shifting by type bits)
            (Trivit (src base)
              (cond
                [(eq? index %zero)
                 (cond
                   [(signed9? n)
                    (case type
                      [(integer-64 unsigned-64) (emit sturi src base n code*)]
                      [(integer-32 unsigned-32) (emit sturwi src base n code*)]
                      [(integer-16 unsigned-16) (emit sturhi src base n code*)]
                      [(integer-8 unsigned-8) (emit sturbi src base n code*)]
                      [else (sorry! who "unexpected mref type ~s" type)])]
                   [else
                    (case type
                      [(integer-64 unsigned-64) (emit stri src base n code*)]
                      [(integer-32 unsigned-32) (emit strwi src base n code*)]
                      [(integer-16 unsigned-16) (emit strhi src base n code*)]
                      [(integer-8 unsigned-8) (emit strbi src base n code*)]
                      [else (sorry! who "unexpected mref type ~s" type)])])]
                [(eqv? n 0)
                  (Trivit (index)
                    (case type
                      [(integer-64 unsigned-64) (emit str src base index code*)]
                      [(integer-32 unsigned-32) (emit strw src base index code*)]
                      [(integer-16 unsigned-16) (emit strh src base index code*)]
                      [(integer-8 unsigned-8) (emit strb src base index code*)]
                      [else (sorry! who "unexpected mref type ~s" type)]))]
                [else (sorry! who "expected %zero index or 0 offset, got ~s and ~s" index offset)])))))))

  (define-who asm-fpop-2
    (lambda (op)
      (lambda (code* dest src1 src2)
        (Trivit (dest src1 src2)
          (case op
            [(fp+) (emit fadd dest src1 src2 code*)]
            [(fp-) (emit fsub dest src1 src2 code*)]
            [(fp*) (emit fmul dest src1 src2 code*)]
            [(fp/) (emit fdiv dest src1 src2 code*)]
            [else (sorry! who "unrecognized op ~s" op)])))))

  (define asm-fpsqrt
    (lambda (code* dest src)
      (Trivit (dest src)
        (emit fsqrt dest src code*))))

  (define-who asm-fpsingle
    (lambda (code* dest src)
      (Trivit (dest src)
        (emit fcvt.d->s dest src
          (emit fcvt.s->d dest dest
            code*)))))

  (define asm-fptrunc
    (lambda (code* dest src)
      (Trivit (dest src)
        (emit fcvtzs dest src code*))))

  (define asm-fpt
    (lambda (code* dest src)
      (Trivit (dest src)
        (emit scvtf dest src code*))))

  (define-who asm-fpmove
    ;; fpmove pseudo instruction is used by set! case in
    ;; select-instructions! and generate-code; at most one of src or
    ;; dest can be an mref, and then the offset is double-aligned
    (lambda (code* dest src)
      (gen-fpmove who code* dest src #t)))

  (define-who asm-fpmove-single
    (lambda (code* dest src)
      (gen-fpmove who code* dest src #f)))

  (define gen-fpmove
    (lambda (who code* dest src double?)
      (Trivit (dest src)
        (record-case dest
          [(disp) (imm reg)
           (if double?
               (cond
                 [(aligned-offset? imm)
                  (emit strfi src (cons 'reg reg) imm code*)]
                 [else
                  (safe-assert (signed9? imm))
                  (emit sturfi src (cons 'reg reg) imm code*)])
               (cond
                 [(aligned-offset? imm 2)
                  (emit strfsi src (cons 'reg reg) imm code*)]
                 [else
                  (safe-assert (signed9? imm))
                  (emit sturfsi src (cons 'reg reg) imm code*)]))]
          [(index) (n ireg breg)
           (cond
             [(fx= n 0)
              (if double?
                  (emit strf src (cons 'reg ireg) (cons 'reg breg) code*)
                  (emit strfs src (cons 'reg ireg) (cons 'reg breg) code*))]
             [else
              (sorry! who "cannot handle indexed fp dest ref")])]
          [else
           (record-case src
             [(disp) (imm reg)
              (if double?
                  (cond
                    [(aligned-offset? imm)
                     (emit ldrfi dest (cons 'reg reg) imm code*)]
                    [else
                     (safe-assert (signed9? imm))
                     (emit ldurfi dest (cons 'reg reg) imm code*)])
                  (cond
                    [(aligned-offset? imm 2)
                     (emit ldrfsi dest (cons 'reg reg) imm code*)]
                    [else
                     (safe-assert (signed9? imm))
                     (emit ldurfsi dest (cons 'reg reg) imm code*)]))]
             [(index) (n ireg breg)
              (cond
                [(fx= n 0)
                 (if double?
                     (emit ldrf dest (cons 'reg ireg) (cons 'reg breg) code*)
                     (emit ldrfs dest (cons 'reg ireg) (cons 'reg breg) code*))]
                [else
                 (sorry! who "cannot handle indexed fp src ref")])]
             [else (emit fmov dest src code*)])]))))

  (define asm-fpcastto
    (lambda (code* dest src)
      (Trivit (dest src)
        (emit fmov.f->g dest src code*))))  

  (define asm-fpcastfrom
    (lambda (code* dest src)
      (Trivit (dest src)
        (emit fmov.g->f dest src code*))))

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

  (define asm-lock
    ;  tmp = 1 # in case load result is not 0
    ;  tmp2 = ldxr src
    ;  cmp tmp2, 0
    ;  bne L1
    ;  tmp2 = 1
    ;  tmp = stxr tmp2, src
    ;L1:
    (lambda (code* src tmp tmp2)
      (Trivit (src tmp tmp2)
        (emit movzi tmp 1 0
          (emit ldxr tmp2 src
            (emit cmpi tmp2 0
              (emit bnei 12
                (emit movzi tmp2 1 0
                  (emit stxr tmp tmp2 src code*)))))))))

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

  (define-who asm-cas
    ;   tmp = ldxr src
    ;   cmp tmp, old
    ;   bne L
    ;   tmp2 = stxr new, src
    ;   cmp tmp2, 0
    ; L:
    (lambda (code* src old new tmp1 tmp2)
      (Trivit (src old new tmp1 tmp2)
        (emit ldxr tmp1 src
          (emit cmp tmp1 old
            (emit bnei 12
              (emit stxr tmp2 new src
                (emit cmpi tmp2 0
                   code*))))))))

  ;; Based in part on https://www.cl.cam.ac.uk/~pes20/cpp/cpp0xmappings.html
  (define-who asm-fence
    (lambda (kind)
      (lambda (code*)
        (case kind
          [(store-store) (emit dmbishst code*)]
          [(acquire) (emit dmbishld code*)]
          [(release) (emit dmbish code*)]
          [else (sorry! who "unexpected kind ~s" kind)]))))

  (define asm-fp-relop
    (lambda (info)
      (lambda (l1 l2 offset x y)
        (Trivit (x y)
          (values
           (emit fcmp x y '())
           (asm-conditional-jump info l1 l2 offset))))))

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

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

  (define asm-pop-multiple
    (lambda (regs)
      (lambda (code*)
        (asm-multiple regs #t code*
                      (lambda (sp reg code*)
                        (emit ldr/postidx reg sp 16 code*))
                      (lambda (sp reg1 reg2 code*)
                        (emit ldrp/postidx reg1 reg2 sp 16 code*))))))

  (define asm-push-multiple
    (lambda (regs)
      (lambda (code*)
        (asm-multiple regs #f code*
                      (lambda (sp reg code*)
                        (emit str/preidx reg sp -16 code*))
                      (lambda (sp reg1 reg2 code*)
                        (emit strp/preidx reg1 reg2 sp -16 code*))))))

  (define asm-pop-fpmultiple
    (lambda (regs)
      (lambda (code*)
        (asm-multiple regs #t code*
                      (lambda (sp reg code*)
                        (emit ldrf/postidx reg sp 16 code*))
                      (lambda (sp reg1 reg2 code*)
                        (emit ldrpf/postidx reg1 reg2 sp 16 code*))))))

  (define asm-push-fpmultiple
    (lambda (regs)
      (lambda (code*)
        (asm-multiple regs #f code*
                      (lambda (sp reg code*)
                        (emit strf/preidx reg sp -16 code*))
                      (lambda (sp reg1 reg2 code*)
                        (emit strpf/preidx reg1 reg2 sp -16 code*))))))

  (define (asm-multiple regs rev? code* one two)
    (let ([sp `(reg . ,%sp)])
      (let loop ([regs regs] [code* code*])
        (cond
          [(null? regs) code*]
          [(null? (cdr regs))
           (one sp (cons 'reg (car regs)) code*)]
          [rev?
           (two sp (cons 'reg (car regs)) (cons 'reg (cadr regs)) (loop (cddr regs) code*))]
          [else
           (loop (cddr regs) (two sp (cons 'reg (car regs)) (cons 'reg (cadr regs)) code*))]))))

  (define asm-debug
    (lambda (code*)
      (emit und code*)))

  (define asm-read-counter
    (lambda (op0 op1 crn crm op2)
      (lambda (code* dest)
        (Trivit (dest)
          (emit mrs op0 op1 crn crm op2 dest code*)))))

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

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

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

  (define asm-c-simple-call
    (lambda (entry save-ra?)
      (let ([target `(arm64-call 0 (entry ,entry))])
        (rec asm-c-simple-call-internal
          (lambda (code* . ignore)
            (asm-helper-call code* target save-ra?))))))
    
  (define-who asm-indirect-call
    (lambda (code* dest lr . ignore)
      (safe-assert (eq? lr %lr))
      (Trivit (dest)
        (unless (ax-reg? dest) (sorry! who "unexpected dest ~s" dest))
        (emit blr dest code*))))

  (define asm-direct-jump
    (lambda (l offset)
      (let ([offset (adjust-return-point-offset offset l)])
        (asm-helper-jump '() (make-funcrel 'arm64-jump l offset)))))

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

  (define-who asm-indirect-jump
    (lambda (src)
      (Trivit (src)
        (record-case src
          [(reg) ignore (emit br src '())]
          [(disp) (n breg)
           (cond
             [(signed9? n)
              (emit lduri `(reg . ,%jmptmp) `(reg . ,breg) n
                 (emit br `(reg . ,%jmptmp) '()))]
             [(aligned-offset? n)
              (emit ldri `(reg . ,%jmptmp) `(reg . ,breg) n
                 (emit br `(reg . ,%jmptmp) '()))]
             [else
              (safe-assert (or (unsigned12? n) (unsigned12? (- n))))
              (let ([code* (emit ldri `(reg . ,%jmptmp) `(reg . ,%jmptmp) 0
                             (emit br `(reg . ,%jmptmp) '()))])
                (if (unsigned12? n)
                    (emit addi #f `(reg . ,%jmptmp) `(reg . ,breg) n code*)
                    (emit subi #f `(reg . ,%jmptmp) `(reg . ,breg) (- n) code*)))])]
          [(index) (n ireg breg)
           (safe-assert (eqv? n 0))
           (emit ldr `(reg . ,%jmptmp) `(reg . ,breg) `(reg . ,ireg)
             (emit br `(reg . ,%jmptmp) '()))]
          [else (sorry! who "unexpected src ~s" src)]))))

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

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

  (define asm-activate-thread
    (let ([target `(arm64-call 0 (entry ,(lookup-c-entry activate-thread)))])
      (lambda (code* dest . ignore)
        (asm-helper-call code* target #t))))

  (define asm-deactivate-thread
    (let ([target `(arm64-call 0 (entry ,(lookup-c-entry deactivate-thread)))])
      (lambda (code* . ignore)
        (asm-helper-call code* target #f))))

  (define asm-unactivate-thread
    (let ([target `(arm64-call 0 (entry ,(lookup-c-entry unactivate-thread)))])
      (lambda (code* arg-reg . ignore)
        (asm-helper-call code* target #f))))

  (define-who asm-return-address
    (lambda (dest l incr-offset next-addr)
      (make-rachunk dest l incr-offset next-addr
        (or (cond
              [(local-label-offset l) =>
               (lambda (offset)
                 (let ([incr-offset (adjust-return-point-offset incr-offset l)])
                   (let ([disp (fx+ (fx- next-addr (fx- offset incr-offset)) 4)])
                     (cond
                       [($fxu< disp (expt 2 21))
                        (Trivit (dest)
                          (emit adr dest disp '()))]
                      [else #f]))))]
              [else #f])
            (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))))))

  (define-who asm-jump
    (lambda (l next-addr)
      (make-gchunk l next-addr
        (cond
          [(local-label-offset l) =>
           (lambda (offset)
             (let ([disp (fx- next-addr offset)])
               (cond
                 [(eqv? disp 0) '()]
                 [(uncond-branch-disp? disp) (emit b `(label ,disp ,l) '())]
                 [else (sorry! who "no support for code objects > 256MB in length")])))]
          [else
            ;; label must be somewhere above.  generate something so that a hard loop
            ;; doesn't get dropped.  this also has some chance of being the right size
            ;; for the final branch instruction.
            (emit b `(label 0 ,l) '())]))))

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

  (define asm-helper-jump
    (lambda (code* reloc)
      (let ([jmp-tmp (cons 'reg %jmptmp)])
        (ax-mov64 jmp-tmp 0
          (emit br jmp-tmp
            (asm-helper-relocation code* reloc))))))

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

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

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

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

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

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

  (define-who asm-shiftop
    (lambda (op)
      (lambda (code* dest src0 src1)
        (Trivit (dest src0 src1)
          (record-case src1
            [(imm) (n)
             ;; When `n` fits in a fixnum, the compiler may generate
             ;; a bad shift that is under a guard, so force it to 63 bits
             (let ([n (fxand n 63)])
	       (cond
		[(fx= n 0)
		 ;; shift by 0 is just a move
		 (emit mov dest src0 code*)]
		[else
		 (case op
		   [(sll) (emit lsli dest src0 n code*)]
		   [(srl) (emit lsri dest src0 n code*)]
		   [(sra) (emit asri dest src0 n code*)]
		   [else (sorry! 'shiftop "unrecognized ~s" op)])]))]
            [else
             (case op
               [(sll) (emit lsl dest src0 src1 code*)]
               [(srl) (emit lsr dest src0 src1 code*)]
               [(sra) (emit asr dest src0 src1 code*)]
               [else (sorry! 'shiftop "unrecognized ~s" op)])])))))

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

  (define asm-popcount
    (lambda (code* dest src tmp)
      (Trivit (dest src tmp)
        (emit fmov.g->f tmp src
          (emit cnt tmp tmp
            (emit addv.b tmp tmp
              (emit fmov.f->g dest tmp code*)))))))

  (define asm-enter values)
  
  (define-who asm-inc-cc-counter
    (lambda (code* addr val tmp)
      (Trivit (addr val tmp)
        (define do-ldr
          (lambda (offset k code*)
            (emit ldri tmp addr offset (k (emit stri tmp addr offset code*)))))
        (define do-add/cc
          (lambda (code*)
            (record-case val
              [(imm) (n) (emit addi #t tmp tmp n code*)]
              [else (emit add #t tmp tmp val code*)])))
        (do-ldr 0
          do-add/cc
          (emit bnei 16
            (do-ldr 8
              (lambda (code*)
                (emit addi #f tmp tmp 1 code*))
              code*))))))
  
  (module (asm-foreign-call asm-foreign-callable)
    (define align (lambda (b x) (let ([k (- b 1)]) (fxlogand (fx+ x k) (fxlognot k)))))
    (define (double-member? m) (and (eq? (car m) 'float)
				    (fx= (cadr m) 8)))
    (define (float-member? m) (and (eq? (car m) 'float)
				   (fx= (cadr m) 4)))
    (define (indirect-result-that-fits-in-registers? result-type)
      (nanopass-case (Ltype Type) result-type
        [(fp-ftd& ,ftd)
	 (let* ([members ($ftd->members ftd)]
		[num-members (length members)])
	   (or (fx<= ($ftd-size ftd) 4)
	       (and (fx= num-members 1)
		    ;; a struct containing only int64 is not returned in a register
		    (or (not ($ftd-compound? ftd))))
	       (and (fx<= num-members 4)
		    (or (andmap double-member? members)
			(andmap float-member? members)))))]
	[else #f]))
    (define int-argument-regs (list %Carg1 %Carg2 %Carg3 %Carg4
                                    %Carg5 %Carg6 %Carg7 %Carg8))
    (define fp-argument-regs (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4
                                   %Cfparg5 %Cfparg6 %Cfparg7 %Cfparg8))
    (define save-and-restore
      (lambda (regs e)
        (safe-assert (andmap reg? regs))
	(with-output-language (L13 Effect)
          (let ([save-and-restore-gp
		 (lambda (regs e)
                   (let* ([regs (filter (lambda (r) (not (eq? (reg-type r) 'fp))) regs)])
                     (cond
                      [(null? regs) e]
                      [else
                       (%seq
			(inline ,(make-info-kill*-live* '() regs) ,%push-multiple)
			,e
			(inline ,(make-info-kill*-live* regs '()) ,%pop-multiple))])))]
		[save-and-restore-fp
		 (lambda (regs e)
                   (let ([fp-regs (filter (lambda (r) (eq? (reg-type r) 'fp)) regs)])
                     (cond
                      [(null? fp-regs) e]
                      [else
                       (%seq
			(inline ,(make-info-kill*-live* '() fp-regs) ,%push-fpmultiple)
			,e
			(inline ,(make-info-kill*-live* fp-regs '()) ,%pop-fpmultiple))])))])
            (save-and-restore-gp regs (save-and-restore-fp regs e))))))

    (define (extract-varargs-after-conv conv*)
      (ormap (lambda (conv)
               (and (pair? conv) (eq? (car conv) 'varargs) (cdr conv)))
             conv*))

    (define-record-type cat
      (nongenerative #{cat jqrttgvpydsbdo0l736l43udu-1})
      (sealed #t)
      (fields place            ; 'int, 'fp, or 'stack
              regs             ; list of registers
              size             ; size in bytes
              pad              ; extra trailing size (for 'stack place) in bytes
              indirect-bytes)) ; #f or extra bytes on stack for indirect

    (define alignment-via-lookahead
      (lambda (size types stack-align varargs-after k)
        (constant-case machine-type-name
          [(arm64osx tarm64osx)
           (cond
             [(eqv? 0 varargs-after) (k (align 8 size) 0 0)]
             [else
              ;; On Mac OS, a non-varargs stack argument does not have to use a
              ;; multiple of 8, but we need to work out any padding that
              ;; is needed to get alignment right for the next argument
              ;; (and to end on 8-byte alignment). Currently, we're
              ;; assuming max aignment of 8.
              (let ([end-this-align (fxand #x7 (fx+ stack-align size))]
                    [next-align (cond
                                  [(null? types) 8]
                                  [else (nanopass-case (Ltype Type) (car types)
                                          [(fp-double-float) 8]
                                          [(fp-single-float) 4]
                                          [(fp-ftd& ,ftd) (if (> ($ftd-size ftd) 16)
                                                              8
                                                              ($ftd-alignment ftd))]
                                          [(fp-integer ,bits) (fxquotient bits 8)]
                                          [(fp-unsigned ,bits) (fxquotient bits 8)]
                                          [else 8])])])
                (cond
                  [(fx= 0 (fxand end-this-align (fx- next-align 1)))
                   (k size 0 end-this-align)]
                  [else
                   (k size (- next-align end-this-align) next-align)]))])]
          [else
           (k (align 8 size) 0 0)])))

    (define rest-of
      (lambda (regs n next-varargs-after)
        (constant-case machine-type-name
          [(arm64osx tarm64osx)
           (cond
             [(eqv? next-varargs-after 0)
              ;; All the rest go on the stack
              '()]
             [else
              (list-tail regs n)])]
          [else
           (list-tail regs n)])))

    (define categorize-arguments
      (lambda (types varargs-after)
        (let loop ([types types] [int* int-argument-regs] [fp* fp-argument-regs]
                   [varargs-after varargs-after]
                   ;; accumulate alignment from previous args so we can compute any
                   ;; needed padding and alignment after this next argument
                   [stack-align 0])
          (let ([next-varargs-after (and varargs-after (if (fx> varargs-after 0) (fx- varargs-after 1) 0))])
            (if (null? types)
                '()
                (nanopass-case (Ltype Type) (car types)
                  [(fp-double-float)
                   (cond
                     [(null? fp*)
                      (cons (make-cat 'stack '() 8 0 #f) (loop (cdr types) int* '() next-varargs-after 0))]
                     [else
                      (cons (make-cat 'fp (list (car fp*)) 8 0 #f)
                            (loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* 1 next-varargs-after)
                                  next-varargs-after
                                  stack-align))])]
                  [(fp-single-float)
                   (cond
                     [(null? fp*)
                      (alignment-via-lookahead
                       4 (cdr types) stack-align varargs-after
                       (lambda (bytes pad stack-align)
                         (cons (make-cat 'stack '() bytes pad #f) (loop (cdr types) int* '() next-varargs-after stack-align))))]
                     [else
                      (cons (make-cat 'fp (list (car fp*)) 8 0 #f)
                            (loop (cdr types) (rest-of int* 0 next-varargs-after)(rest-of fp* 1 next-varargs-after)
                                  next-varargs-after
                                  stack-align))])]
                  [(fp-ftd& ,ftd)
                   (let* ([size ($ftd-size ftd)]
                          [members ($ftd->members ftd)]
                          [num-members (length members)]
                          [doubles? (and (fx= 8 ($ftd-alignment ftd))
                                         (fx<= num-members 4)
                                         (andmap double-member? members))]
                          [floats? (and (fx= 4 ($ftd-alignment ftd))
                                        (fx<= num-members 4)
                                        (andmap float-member? members))])
                     (cond
                       [doubles?
                        ;; Sequence of up to 4 doubles that may fit in registers
                        (cond
                          [(fx>= (length fp*) num-members)
                           ;; Allocate each double to a register
                           (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f)
                                 (loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* num-members next-varargs-after)
                                       next-varargs-after
                                       stack-align))]
                          [else
                           ;; Stop using fp registers, put on stack
                           (cons (make-cat 'stack '() size 0 #f)
                                 (loop (cdr types) int* '() next-varargs-after 0))])]
                       [floats?
                        ;; Sequence of up to 4 floats that may fit in registers
                        (cond
                          [(fx>= (length fp*) num-members)
                           ;; Allocate each float to a register
                           (cons (make-cat 'fp (list-head fp* num-members) (fx* 8 num-members) 0 #f)
                                 (loop (cdr types) (rest-of int* 0 next-varargs-after) (rest-of fp* num-members next-varargs-after)
                                       next-varargs-after
                                       stack-align))]
                          [else
                           ;; Stop using fp registers, put on stack
                           (alignment-via-lookahead
                            size (cdr types) stack-align varargs-after
                            (lambda (size pad stack-align)
                              (cons (make-cat 'stack '() size pad #f)
                                    (loop (cdr types) int* '() next-varargs-after stack-align))))])]
                       [(fx> size 16)
                        ;; Indirect; pointer goes in a register or on the stack
                        (cond
                          [(null? int*)
                           ;; Pointer on the stack
                           (cons (make-cat 'stack '() (constant ptr-bytes) 0 (align 8 size))
                                 (loop (cdr types) '() fp* next-varargs-after 0))]
                          [else
                           ;; Pointer in register
                           (cons (make-cat 'int (list (car int*)) 8 0 (align 8 size))
                                 (loop (cdr types) (rest-of int* 1 next-varargs-after) (rest-of fp* 0 next-varargs-after)
                                       next-varargs-after
                                       stack-align))])]
                       [else
                        ;; Maybe put in integer registers
                        (let* ([regs (fxquotient (align 8 size) 8)])
                          (cond
                            [(fx<= regs (length int*))
                             ;; Fits in registers
                             (cons (make-cat 'int (list-head int* regs) (align 8 size) 0 #f)
                                   (loop (cdr types) (rest-of int* regs next-varargs-after) (rest-of fp* 0 next-varargs-after)
                                         next-varargs-after
                                         stack-align))]
                            [else
                             ;; Stop using int registers, put on stack
                             (alignment-via-lookahead
                              size (cdr types) stack-align varargs-after
                              (lambda (size pad stack-align)
                                (cons (make-cat 'stack '() size pad #f)
                                      (loop (cdr types) '() fp* next-varargs-after stack-align))))]))]))]
                  [else
                   ;; integers, scheme-object, etc.
                   (cond
                     [(null? int*) 
                      (let ([size (nanopass-case (Ltype Type) (car types)
                                    [(fp-integer ,bits) (fxquotient bits 8)]
                                    [(fp-unsigned ,bits) (fxquotient bits 8)]
                                    [else 8])])
                        (alignment-via-lookahead
                         size (cdr types) stack-align varargs-after
                         (lambda (size pad stack-align)
                           (cons (make-cat 'stack '() size pad #f) (loop (cdr types) '() fp* next-varargs-after stack-align)))))]
                     [else
                      (cons (make-cat 'int (list (car int*)) 8 0 #f)
                            (loop (cdr types) (rest-of int* 1 next-varargs-after) (rest-of fp* 0 next-varargs-after)
                                  next-varargs-after stack-align))])]))))))

    (define get-registers
      (lambda (cats kind)
        (let loop ([cats cats])
          (cond
            [(null? cats) '()]
            [(or (eq? kind 'all) (eq? kind (cat-place (car cats))))
             (append (cat-regs (car cats))
                     (loop (cdr cats)))]
            [else (loop (cdr cats))]))))

    (define memory-to-reg
      (lambda (ireg x from-offset size unsigned?)
        (safe-assert (not (eq? ireg x)))
        (with-output-language (L13 Effect)
          (let loop ([ireg ireg] [from-offset from-offset] [size size] [unsigned? unsigned?])
            (case size
              [(8) `(set! ,ireg ,(%mref ,x ,from-offset))]
              [(7 6 5)
               (let ([tmp %argtmp])
                 (%seq
                  ,(loop ireg (fx+ from-offset 4) (fx- size 4) #t)
                  ,(loop tmp from-offset 4 #t)
                  (set! ,ireg ,(%inline sll ,ireg (immediate 32)))
                  (set! ,ireg ,(%inline + ,ireg ,tmp))))]
              [(3)
               (let ([tmp %argtmp])
                 (%seq
                  ,(loop ireg from-offset 2 #t)
                  ,(loop tmp (fx+ from-offset 2) 1 #t)
                  (set! ,tmp ,(%inline sll ,tmp (immediate 16)))
                  (set! ,ireg ,(%inline + ,ireg ,tmp))))]
              [else
               `(set! ,ireg ,(case size
                               [(1) `(inline ,(make-info-load (if unsigned? 'unsigned-8 'integer-8) #f) ,%load ,x ,%zero (immediate ,from-offset))]
                               [(2) `(inline ,(make-info-load (if unsigned? 'unsigned-16 'integer-16) #f) ,%load ,x ,%zero (immediate ,from-offset))]
                               [(4) `(inline ,(make-info-load (if unsigned? 'unsigned-32 'integer-32) #f) ,%load ,x ,%zero (immediate ,from-offset))]
                               [else (sorry! 'memory-to-reg "unexpected size ~s" size)]))])))))
    (define reg-to-memory
      (lambda (dest offset size from-reg)
        ;; can trash `from-reg`, cannot use `%argtmp`
        (let loop ([offset offset] [size size])
          (with-output-language (L13 Effect)
            (case size
              [(1) `(inline ,(make-info-load 'integer-8 #f) ,%store ,dest ,%zero (immediate ,offset) ,from-reg)]
              [(2) `(inline ,(make-info-load 'integer-16 #f) ,%store ,dest ,%zero (immediate ,offset) ,from-reg)]
              [(3) (%seq
                    ,(loop offset 2)
                    (set! ,from-reg ,(%inline srl ,from-reg (immediate 16)))
                    ,(loop (fx+ offset 2) 1))]
              [(4) `(inline ,(make-info-load 'integer-32 #f) ,%store ,dest ,%zero (immediate ,offset) ,from-reg)]
              [(8) `(set! ,(%mref ,dest ,offset) ,from-reg)]
              [(7 6 5) (%seq
                        ,(loop offset 4)
                        (set! ,from-reg ,(%inline srl ,from-reg (immediate 32)))
                        ,(loop (fx+ offset 4) (fx- size 4)))])))))

    (define-who asm-foreign-call
      (with-output-language (L13 Effect)
        (letrec ([load-double-stack
                  (lambda (offset)
                    (lambda (x) ; unboxed
                      `(set! ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                 [load-single-stack
                  (lambda (offset)
                    (lambda (x) ; unboxed
                      (%inline store-double->single ,(%mref ,%sp ,%zero ,offset fp) ,x)))]
                 [load-int-stack
                  (lambda (offset size)
                    (lambda (rhs) ; requires rhs
                      (let ([int-type (case size
                                        [(1) 'unsigned-8]
                                        [(2) 'unsigned-16]
                                        [(4) 'unsigned-32]
                                        [else #f])])
                        (cond
                          [(not int-type) `(set! ,(%mref ,%sp ,offset) ,rhs)]
                          [else
                           (let ([tmp %argtmp])
                             (%seq
                              (set! ,tmp ,rhs)
                              (inline ,(make-info-load int-type #f) ,%store ,%sp ,%zero (immediate ,offset) ,tmp)))]))))]
                 [load-indirect-stack
                  ;; used both for arguments passed on stack and argument passed as a pointer to deeper on the stack
                  (lambda (offset from-offset size)
                    (lambda (x) ; requires var
                      (let loop ([size size] [offset offset] [from-offset from-offset])
                        (case size
                          [(8) `(set! ,(%mref ,%sp ,offset) ,(%mref ,x ,from-offset))]
                          [(7 6 5)
                           (%seq
                            ,(loop 4 offset from-offset)
                            ,(loop (fx- size 4) (fx+ offset 4) (fx+ from-offset 4)))]
                          [(3)
                           (%seq
                            (set! ,(%mref ,%sp ,offset) (inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset)))
                            (set! ,(%mref ,%sp ,(fx+ offset 2)) (inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,(fx+ from-offset 2)))))]
                          [(1 2 4)
                           `(set! ,(%mref ,%sp ,offset) ,(case size
                                                           [(1) `(inline ,(make-info-load 'integer-8 #f) ,%load ,x ,%zero (immediate ,from-offset))]
                                                           [(2) `(inline ,(make-info-load 'integer-16 #f) ,%load ,x ,%zero (immediate ,from-offset))]
                                                           [(4) `(inline ,(make-info-load 'integer-32 #f) ,%load ,x ,%zero (immediate ,from-offset))]))]
                          [else
                           (%seq
                            ,(loop 8 offset from-offset)
                            ,(loop (fx- size 8) (fx+ offset 8) (fx+ from-offset 8)))]))))]
                 [load-double-reg
                  (lambda (fpreg)
                    (lambda (x) ; unboxed
                      `(set! ,fpreg ,x)))]
                 [load-single-reg
                  (lambda (fpreg)
                    (lambda (x) ; unboxed
                      `(set! ,fpreg ,(%inline double->single ,x))))]
                 [load-boxed-double-reg
                  (lambda (fpreg fp-disp)
                    (lambda (x) ; address (always a var) of a flonum
                      `(set! ,fpreg ,(%mref ,x ,%zero ,fp-disp fp))))]
                 [load-boxed-single-reg
                  (lambda (fpreg fp-disp)
                    (lambda (x) ; address (always a var) of a float
                      `(set! ,fpreg ,(%inline load-single ,(%mref ,x ,%zero ,fp-disp fp)))))]
                 [load-int-reg
                  (lambda (ireg)
                    (lambda (x)
                      `(set! ,ireg ,x)))]
                 [load-int-indirect-reg
                  (lambda (ireg from-offset size unsigned?)
                    (lambda (x)
                      (memory-to-reg ireg x from-offset size unsigned?)))]
                 [compute-stack-argument-space
                  ;; We'll save indirect arguments on the stack, too, but they have to be beyond any
                  ;; arguments that the callee expects. So, calculate how much the callee shoudl expect.
                  (lambda (cats)
                    (let loop ([cats cats] [isp 0])
                      (if (null? cats)
                          isp
                          (let ([cat (car cats)])
                            (if (eq? (cat-place cat) 'stack)
                                (loop (cdr cats) (fx+ isp (cat-size cat) (cat-pad cat)))
                                (loop (cdr cats) isp))))))]
                 [compute-stack-indirect-space
                  (lambda (cats)
                    (let loop ([cats cats] [isp 0])
                      (if (null? cats)
                          isp
                          (let ([cat (car cats)])
                            (loop (cdr cats) (fx+ isp (or (cat-indirect-bytes cat) 0)))))))]
                 [do-args
                  (lambda (types cats indirect-start)
                    (let loop ([types types] [cats cats] [locs '()] [isp 0] [ind-sp indirect-start])
                      (if (null? types)
                          locs
                          (let ([cat (car cats)]
                                [type (car types)]
                                [cats (cdr cats)]
                                [types (cdr types)])
                            (nanopass-case (Ltype Type) type
                              [(fp-double-float)
                               (cond
                                 [(eq? 'fp (cat-place cat))
                                  (loop types cats 
                                        (cons (load-double-reg (car (cat-regs cat))) locs)
                                        isp ind-sp)]
                                 [else
                                  (loop types cats 
                                        (cons (load-double-stack isp) locs)
                                        (fx+ isp (cat-size cat) (cat-pad cat)) ind-sp)])]
                              [(fp-single-float)
                               (cond
                                 [(eq? 'fp (cat-place cat))
                                  (loop types cats 
                                        (cons (load-single-reg (car (cat-regs cat))) locs)
                                        isp ind-sp)]
                                 [else
                                  (loop types cats 
                                        (cons (load-single-stack isp) locs)
                                        (fx+ isp (cat-size cat) (cat-pad cat)) ind-sp)])]
                              [(fp-ftd& ,ftd)
                               (let ([size ($ftd-size ftd)])
                                 (case (cat-place cat)
                                   [(int)
                                    (let ([indirect-bytes (cat-indirect-bytes cat)])
                                      (cond
                                        [indirect-bytes
                                         ;; pointer to an indirect argument
                                         (safe-assert (fx= 1 (length (cat-regs cat))))
                                         (loop types cats
                                               (cons (let ([ind (load-indirect-stack ind-sp 0 size)])
                                                       (lambda (x)
                                                         (%seq
                                                          ,(ind x)
                                                          (set! ,(car (cat-regs cat)) ,(%inline + ,%sp (immediate ,ind-sp))))))
                                                     locs)
                                               isp (fx+ ind-sp indirect-bytes))]
                                        [else
                                         ;; argument copied to one or more integer registers
                                         (let i-loop ([int* (cat-regs cat)] [size size] [offset 0] [proc #f])
                                           (cond
                                             [(null? int*)
                                              (loop types cats
                                                    (cons proc locs)
                                                    isp ind-sp)]
                                             [else
                                              (i-loop (cdr int*) (fx- size 8) (fx+ offset 8)
                                                      (let ([new-proc (load-int-indirect-reg (car int*) offset (fxmin size 8) ($ftd-unsigned? ftd))])
                                                        (if proc
                                                            (lambda (x) (%seq ,(proc x) ,(new-proc x)))
                                                            new-proc)))]))]))]
                                   [(fp)
                                    (let ([double? (double-member? (car ($ftd->members ftd)))])
                                      ;; argument copied to one or more integer registers
                                      (let f-loop ([fp* (cat-regs cat)] [offset 0] [proc #f])
                                        (cond
                                          [(null? fp*)
                                           (loop types cats
                                                 (cons proc locs)
                                                 isp ind-sp)]
                                          [else
                                           (f-loop (cdr fp*) (fx+ offset (if double? 8 4))
                                                   (let ([new-proc (if double?
                                                                       (load-boxed-double-reg (car fp*) offset)
                                                                       (load-boxed-single-reg (car fp*) offset))])
                                                     (if proc
                                                         (lambda (x) (%seq ,(proc x) ,(new-proc x)))
                                                         new-proc)))])))]
                                   [else
                                    (let ([indirect-bytes (cat-indirect-bytes cat)]
                                          [size-on-stack (cat-size cat)])
                                      (cond
                                        [indirect-bytes
                                         ;; pointer (passed on stack) to an indirect argument (also on stack)
                                         (safe-assert (fx= size-on-stack 8))
                                         (loop types cats
                                               (cons (let ([ind (load-indirect-stack ind-sp 0 size-on-stack)])
                                                       (lambda (x)
                                                         (%seq
                                                          ,(ind x)
                                                          (set! ,(%mref ,%sp ,isp) ,(%inline + ,%sp ,ind)))))
                                                     locs)
                                               (fx+ isp size-on-stack) (fx+ ind-sp indirect-bytes))]
                                        [else
                                         ;; argument copied to stack
                                         (loop types cats
                                               (cons (load-indirect-stack isp 0 size) locs)
                                               (fx+ isp size-on-stack (cat-pad cat)) ind-sp)]))]))]
                              [else
                               ;; integer, scheme-object, etc.
                               (cond
                                 [(eq? 'int (cat-place cat))
                                  (loop types cats
                                        (cons (load-int-reg (car (cat-regs cat))) locs)
                                        isp ind-sp)]
                                 [else
                                  (loop types cats
                                        (cons (load-int-stack isp (cat-size cat)) locs)
                                        (fx+ isp (cat-size cat) (cat-pad cat)) ind-sp)])])))))]
		 [add-fill-result
                  ;; may destroy the values in result registers
		  (lambda (result-cat result-type args-frame-size e)
                    (nanopass-case (Ltype Type) result-type
                      [(fp-ftd& ,ftd)
                       (let* ([size ($ftd-size ftd)]
                              [tmp %argtmp])
                         (case (cat-place result-cat)
                           [(int)
                            ;; result is in integer registers
                            (let loop ([int* (cat-regs result-cat)] [offset 0] [size size])
                              (cond
                                [(null? int*) `(seq ,e (set! ,tmp ,(%mref ,%sp ,args-frame-size)))]
                                [else
                                 (%seq ,(loop (cdr int*) (fx+ offset 8) (fx- size 8))
                                       ,(reg-to-memory tmp offset (fxmin size 8) (car int*)))]))]
                           [(fp)
                            ;; result is in fp registers, so going to either double or float elements
                            (let* ([double? (double-member? (car ($ftd->members ftd)))])
                              (let loop ([fp* (cat-regs result-cat)] [offset 0])
                                (cond
                                  [(null? fp*) `(seq ,e (set! ,tmp ,(%mref ,%sp ,args-frame-size)))]
                                  [double?
                                   (%seq ,(loop (cdr fp*) (fx+ offset 8))
                                         (set! ,(%mref ,tmp ,%zero ,offset fp) ,(car fp*)))]
                                  [else
                                   (%seq ,(loop (cdr fp*) (fx+ offset 4))
                                         ,(%inline store-single ,(%mref ,tmp ,%zero ,offset fp) ,(car fp*)))])))]
                           [else
                            ;; we passed the pointer to be filled, so nothing more to do here
                            e]))]
                      [else
                       ;; anything else
                       e]))]
                 [add-deactivate
                  (lambda (adjust-active? t0 live* result-live* k)
                    (cond
                      [adjust-active?
                       (%seq
			(set! ,%ac0 ,t0)
                        ,(save-and-restore live* (%inline deactivate-thread))
                        ,(k %ac0)
                        ,(save-and-restore result-live* `(set! ,%Cretval ,(%inline activate-thread))))]
                      [else (k t0)]))])
          (lambda (info)
            (safe-assert (reg-callee-save? %tc)) ; no need to save-restore
            (let* ([arg-type* (info-foreign-arg-type* info)]
                   [result-type (info-foreign-result-type info)]
                   [ftd-result? (nanopass-case (Ltype Type) result-type
                                  [(fp-ftd& ,ftd) #t]
                                  [else #f])]
                   [arg-type* (if ftd-result?
                                  (cdr arg-type*)
                                  arg-type*)]
                   [conv* (info-foreign-conv* info)]
                   [arg-cat* (categorize-arguments arg-type* (extract-varargs-after-conv conv*))]
		   [result-cat (car (categorize-arguments (list result-type) #f))]
                   [result-reg* (cat-regs result-cat)]
		   [fill-result-here? (and ftd-result?
                                           (not (cat-indirect-bytes result-cat))
                                           (not (eq? 'stack (cat-place result-cat))))]
                   [arg-stack-bytes (align 16 (compute-stack-argument-space arg-cat*))]
                   [indirect-stack-bytes (align 16 (compute-stack-indirect-space arg-cat*))]
                   [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]
                   [locs (do-args arg-type* arg-cat* arg-stack-bytes)]
                   [live* (get-registers arg-cat* 'all)]
                   [live* (if (and ftd-result? (not fill-result-here?))
                              (cons %r8 live*)
                              live*)]
                   [frame-size (align 16 (fx+ arg-stack-bytes
                                              indirect-stack-bytes
                                              (if fill-result-here?
                                                  8
                                                  0)))]
                   [adjust-frame (lambda (op)
                                   (lambda ()
                                     (if (fx= frame-size 0)
                                         `(nop)
                                         `(set! ,%sp (inline ,null-info ,op ,%sp (immediate ,frame-size))))))])
              (values
               (adjust-frame %-)
               (let ([locs (reverse locs)])
                 (cond
                   [fill-result-here?
                    ;; stash extra argument on the stack to be retrieved after call and filled with the result:
                    (cons (load-int-stack (fx+ arg-stack-bytes indirect-stack-bytes) 8) locs)]
                   [ftd-result?
                    ;; callee expects pointer to fill for return in %r8:
                    (cons (lambda (rhs) `(set! ,%r8 ,rhs)) locs)]
                   [else locs]))
               (lambda (t0 not-varargs?)
                 (add-fill-result result-cat result-type (fx+ arg-stack-bytes indirect-stack-bytes)
                                  (add-deactivate adjust-active? t0 live* result-reg*
                                                  (lambda (t0)
                                                    `(inline ,(make-info-kill*-live* (add-caller-save-registers result-reg*) live*) ,%c-call ,t0)))))
               (nanopass-case (Ltype Type) result-type
                 [(fp-double-float)
                  (lambda (lvalue) ; unboxed
                    `(set! ,lvalue ,%Cfpretval))]
                 [(fp-single-float)
                  (lambda (lvalue) ; unboxed
                    `(set! ,lvalue ,(%inline single->double ,%Cfpretval)))]
                 [(fp-integer ,bits)
                  (case bits
                    [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline sext8 ,%Cretval)))]
                    [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline sext16 ,%Cretval)))]
                    [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline sext32 ,%Cretval)))]
                    [(64) (lambda (lvalue) `(set! ,lvalue ,%Cretval))]
                    [else (sorry! who "unexpected asm-foreign-procedures fp-integer size ~s" bits)])]
                 [(fp-unsigned ,bits)
                  (case bits
                    [(8) (lambda (lvalue) `(set! ,lvalue ,(%inline zext8 ,%Cretval)))]
                    [(16) (lambda (lvalue) `(set! ,lvalue ,(%inline zext16 ,%Cretval)))]
                    [(32) (lambda (lvalue) `(set! ,lvalue ,(%inline zext32 ,%Cretval)))]
                    [(64) (lambda (lvalue) `(set! ,lvalue ,%Cretval))]
                    [else (sorry! who "unexpected asm-foreign-procedures fp-unsigned size ~s" bits)])]
                 [else (lambda (lvalue) `(set! ,lvalue ,%Cretval))])
               (adjust-frame %+)))
            ))))

    (define-who asm-foreign-callable
      #|
        Frame Layout
                   +---------------------------+
                   |                           |
                   |    incoming stack args    |
                   |                           |
                   +---------------------------+<- 16-byte boundary
                   |    saved int reg args     | 
                   |    + %r8 for indirect     |
                   |    + maybe padding        | 
                   +---------------------------+<- 16-byte boundary
                   |                           | 
                   |   saved float reg args    |
                   |    + maybe padding        | 
                   +---------------------------+<- 16-byte boundary
                   |                           | 
                   |     activatation state    | 
                   |       if necessary        |
                   +---------------------------+<- 16-byte boundary
                   |                           | 
                   |      &-return space       |
                   |       if necessary        |
                   +---------------------------+<- 16-byte boundary
                   |                           |
                   |   callee-save regs + lr   | 
                   |   callee-save fpregs      |
                   +---------------------------+<- 16-byte boundary
      |#
      (with-output-language (L13 Effect)
        (let ()
          (define load-double-stack
            (lambda (offset)
              (lambda (x) ; requires var
                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
                       ,(%mref ,%sp ,%zero ,offset fp)))))
          (define load-single-stack
            (lambda (offset)
              (lambda (x) ; requires var
                `(set! ,(%mref ,x ,%zero ,(constant flonum-data-disp) fp)
                       ,(%inline load-single->double ,(%mref ,%sp ,%zero ,offset fp))))))
          (define load-word-stack
            (lambda (offset)
              (lambda (lvalue)
                `(set! ,lvalue ,(%mref ,%sp ,offset)))))
          (define load-int-stack
            (lambda (type offset)
              (lambda (lvalue)
                (nanopass-case (Ltype Type) type
                  [(fp-integer ,bits)
                   (case bits
                     [(8) `(set! ,lvalue (inline ,(make-info-load 'integer-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(16) `(set! ,lvalue (inline ,(make-info-load 'integer-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(32) `(set! ,lvalue (inline ,(make-info-load 'integer-32 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(64) `(set! ,lvalue ,(%mref ,%sp ,offset))]
                     [else (sorry! who "unexpected load-int-stack fp-integer size ~s" bits)])]
                  [(fp-unsigned ,bits)
                   (case bits
                     [(8) `(set! ,lvalue (inline ,(make-info-load 'unsigned-8 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(16) `(set! ,lvalue (inline ,(make-info-load 'unsigned-16 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(32) `(set! ,lvalue (inline ,(make-info-load 'unsigned-32 #f) ,%load ,%sp ,%zero (immediate ,offset)))]
                     [(64) `(set! ,lvalue ,(%mref ,%sp ,offset))]
                     [else (sorry! who "unexpected load-int-stack fp-unsigned size ~s" bits)])]
                  [else `(set! ,lvalue ,(%mref ,%sp ,offset))]))))
	  (define load-stack-address
	    (lambda (offset)
	      (lambda (lvalue)
		`(set! ,lvalue ,(%inline + ,%sp (immediate ,offset))))))
          (define do-args
            ;; all of the args are on the stack at this point, though not contiguous since
            ;; we push all of the int reg args with one set of push instructions and all of the
            ;; float reg args with another set of push instructions
            (lambda (arg-type* arg-cat* init-int-reg-offset float-reg-offset stack-arg-offset return-offset
                               synthesize-first? indirect-result?)
              (let loop ([types arg-type*]
                         [cats arg-cat*]
                         [locs '()]
                         [int-reg-offset (if indirect-result? (fx+ init-int-reg-offset 8) init-int-reg-offset)]
                         [float-reg-offset float-reg-offset]
                         [stack-arg-offset stack-arg-offset])
                  (if (null? types)
                      (let ([locs (reverse locs)])
                        (cond
                          [synthesize-first?
                           (cons (load-stack-address return-offset) locs)]
                          [indirect-result?
                           (cons (load-word-stack init-int-reg-offset) locs)]
                          [else locs]))
                      (let ([cat (car cats)]
                            [type (car types)]
                            [cats (cdr cats)]
                            [types (cdr types)])
                        (nanopass-case (Ltype Type) type
                          [(fp-double-float)
                           (case (cat-place cat)
                             [(fp)
                              (loop types cats
                                    (cons (load-double-stack float-reg-offset) locs)
                                    int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)]
                             [else
                              (loop types cats
                                    (cons (load-double-stack stack-arg-offset) locs)
                                    int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))])]
                          [(fp-single-float)
                           (case (cat-place cat)
                             [(fp)
                              (loop types cats
                                    (cons (load-single-stack float-reg-offset) locs)
                                    int-reg-offset (fx+ float-reg-offset 8) stack-arg-offset)]
                             [else
                              (loop types cats
                                    (cons (load-single-stack stack-arg-offset) locs)
                                    int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))])]
                          
                          [(fp-ftd& ,ftd)
                           (case (cat-place cat)
                             [(int)
                              (let ([indirect-bytes (cat-indirect-bytes cat)])
                                (cond
                                  [indirect-bytes
                                   ;; pointer to an indirect argument
                                   (safe-assert (fx= (length (cat-regs cat)) 1))
                                   (loop types cats
                                         (cons (load-word-stack int-reg-offset) locs)
                                         (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)]
                                  [else
                                   ;; point to argument on stack
                                   (loop types cats
                                         (cons (load-stack-address int-reg-offset) locs)
                                         (fx+ int-reg-offset (cat-size cat) (cat-pad cat)) float-reg-offset stack-arg-offset)]))]
                             [(fp)
                              ;; point to argument, but if they're floats, then we need to
                              ;; shift double-sized registers into float-sized elements
                              (loop types cats
                                    (cons (let ([proc (load-stack-address float-reg-offset)]
                                                [members ($ftd->members ftd)])
                                            (cond
                                              [(or (null? (cdr members))
                                                   (double-member? (car members)))
                                               proc]
                                              [else
                                               ;; instead of compacting here, it might be nicer to
                                               ;; save registers in packed form in the first place
                                               ;; (which means that `(cat-size cat)` would be a multiple of 4)
                                               (lambda (lvalue)
                                                 (let loop ([members (cdr members)]
                                                            [dest-offset (fx+ float-reg-offset 4)]
                                                            [src-offset (fx+ float-reg-offset 8)])
                                                   (if (null? members)
                                                       (proc lvalue)
                                                       (let ([tmp %argtmp])
                                                         (%seq
                                                          (set! ,tmp (inline ,(make-info-load 'unsigned-32 #f) ,%load ,%sp ,%zero (immediate ,src-offset)))
                                                          (inline ,(make-info-load 'unsigned-32 #f) ,%store ,%sp ,%zero (immediate ,dest-offset) ,%argtmp)
                                                          ,(loop (cdr members) (fx+ dest-offset 4) (fx+ src-offset 8)))))))]))
                                          locs)
                                    int-reg-offset (fx+ float-reg-offset (cat-size cat) (cat-pad cat)) stack-arg-offset)]
                             [else
                              (let ([indirect-bytes (cat-indirect-bytes cat)])
                                (cond
                                 [indirect-bytes
                                   ;; pointer (passed on stack) to an indirect argument (also on stack)
                                   (safe-assert (fx= (cat-size cat) 8))
                                   (loop types cats
                                         (cons (load-word-stack stack-arg-offset) locs)
                                         int-reg-offset float-reg-offset (fx+ stack-arg-offset 8))]
                                  [else
                                   ;; point to argument on stack
                                   (loop types cats
                                         (cons (load-stack-address stack-arg-offset) locs)
                                         int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))]))])]
                          [else
                           ;; integer, scheme-object, etc.
                           (case (cat-place cat)
                             [(int)
                              (loop types cats
                                    (cons (load-int-stack type int-reg-offset) locs)
                                    (fx+ int-reg-offset 8) float-reg-offset stack-arg-offset)]
                             [else
                              (loop types cats
                                    (cons (load-int-stack type stack-arg-offset) locs)
                                    int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))])]))))))
          (define do-result
            (lambda (result-type result-cat synthesize-first? return-stack-offset)
	      (nanopass-case (Ltype Type) result-type
                [(fp-double-float)
		 (lambda (rhs)
                   `(set! ,%Cfpretval ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp)))]
		[(fp-single-float)
                 (lambda (rhs)
                   `(set! ,%Cfpretval ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp))))]
                [(fp-void)
                 (lambda () `(nop))]
                [(fp-ftd& ,ftd)
                 (cond
                   [(cat-indirect-bytes result-cat)
                    ;; we passed the pointer to be filled, so nothing more to do here
                    (lambda () `(nop))]
                   [else
                    (case (cat-place result-cat)
                      [(int)
                       (let ([to-regs
                              (lambda (x offset)
                                (let loop ([int* (cat-regs result-cat)] [offset offset] [size ($ftd-size ftd)])
                                  (cond
                                    [(null? int*) `(nop)]
                                    [else
                                     (safe-assert (not (eq? (car int*) x)))
                                     (%seq
                                      ,(loop (cdr int*) (fx+ offset 8) (fx- size 8))
                                      ,(memory-to-reg (car int*) x offset (fxmin size 8) ($ftd-unsigned? ftd)))])))])
                         (if synthesize-first?
                             (lambda ()
                               (to-regs %sp return-stack-offset))
                             (lambda (x)
                               (to-regs x 0))))]
                      [(fp)
                       (let* ([double? (double-member? (car ($ftd->members ftd)))])
                         (let ([to-regs
                                (lambda (x offset)
                                  (let loop ([fp* (cat-regs result-cat)] [offset offset])
                                    (cond
                                      [(null? fp*) `(nop)]
                                      [double?
                                       (%seq ,(loop (cdr fp*) (fx+ offset 8))
                                             (set! ,(car fp*) ,(%mref ,x ,%zero ,offset fp)))]
                                      [else
                                       (%seq ,(loop (cdr fp*) (fx+ offset 4))
                                             (set! ,(car fp*) ,(%inline load-single ,(%mref ,x ,%zero ,offset fp))))])))])
                           (if synthesize-first?
                               (lambda ()
                                 (to-regs %sp return-stack-offset))
                               (lambda (x)
                                 (to-regs x 0)))))]
                      [else
                       ;; we passed the pointer to be filled, so nothing more to do here
                       (lambda () `(nop))])])]
                [else
                 ;; integer, scheme-object, etc.
                 (lambda (x)
                   `(set! ,%Cretval ,x))])))
          (lambda (info)
            (define get-callee-save-regs (lambda (type)
                                           (let loop ([i 0])
                                             (cond
                                               [(fx= i (vector-length regvec)) '()]
                                               [else (let ([reg (vector-ref regvec i)])
                                                       (if (and (reg-callee-save? reg)
                                                                (eq? type (reg-type reg)))
                                                           (cons reg (loop (fx+ i 1)))
                                                           (loop (fx+ i 1))))]))))
            (define callee-save-regs+lr (cons* %lr
					       ;; reserved:
					       %tc %sfp %ap %trap
					       ;; allocable:
					       (get-callee-save-regs 'uptr)))
            (define callee-save-fpregs  (get-callee-save-regs 'fp))
            (define isaved (length callee-save-regs+lr))
            (define fpsaved (length callee-save-fpregs))
            (let* ([arg-type* (info-foreign-arg-type* info)]
                   [result-type (info-foreign-result-type info)]
                   [ftd-result? (nanopass-case (Ltype Type) result-type
                                  [(fp-ftd& ,ftd) #t]
                                  [else #f])]
                   [arg-type* (if ftd-result?
                                  (cdr arg-type*)
                                  arg-type*)]
		   [conv* (info-foreign-conv* info)]
                   [arg-cat* (categorize-arguments arg-type* (extract-varargs-after-conv conv*))]
                   [result-cat (car (categorize-arguments (list result-type) #f))]
                   [synthesize-first? (and ftd-result?
                                           (not (cat-indirect-bytes result-cat))
                                           (not (eq? 'stack (cat-place result-cat))))]
                   [indirect-result? (and ftd-result? (not synthesize-first?))]
                   [adjust-active? (if-feature pthreads (memq 'adjust-active conv*) #f)]

                   [arg-regs (let ([regs (get-registers arg-cat* 'int)])
                               (if indirect-result?
                                   (cons %r8 regs)
                                   regs))]
                   [arg-fp-regs (get-registers arg-cat* 'fp)]
                   [result-regs (get-registers (list result-cat) 'all)])
                (let ([int-reg-bytes (fx* (align 2 (length arg-regs)) 8)]
                      [float-reg-bytes (fx* (align 2 (length arg-fp-regs)) 8)]
                      [active-state-bytes (if adjust-active? 16 0)]
                      [return-bytes (if synthesize-first? (align 16 (cat-size result-cat)) 0)]
                      [callee-save-bytes (fx* 8
                                              (fx+ (align 2 (length callee-save-regs+lr))
                                                   (align 2 (length callee-save-fpregs))))])
                  (let* ([return-offset callee-save-bytes]
                         [active-state-offset (fx+ return-offset return-bytes)]
                         [arg-fpregs-offset (fx+ active-state-offset active-state-bytes)]
                         [arg-regs-offset (fx+ arg-fpregs-offset float-reg-bytes)]
                         [args-offset (fx+ arg-regs-offset int-reg-bytes)])
                    (values
                     (lambda ()
                       (%seq
                        ;; save argument register values to the stack so we don't lose the values
                        ;; across possible calls to C while setting up the tc and allocating memory
                        ,(if (null? arg-regs) `(nop) `(inline ,(make-info-kill*-live* '() arg-regs) ,%push-multiple))
                        ,(if (null? arg-fp-regs) `(nop) `(inline ,(make-info-kill*-live* '() arg-fp-regs) ,%push-fpmultiple))
                        ;; make room for active state and/or return bytes
                        ,(let ([len (+ active-state-bytes return-bytes)])
                           (if (fx= len 0) `(nop) `(set! ,%sp ,(%inline - ,%sp (immediate ,len)))))
                        ;; save the callee save registers & return address
                        (inline ,(make-info-kill*-live* '() callee-save-regs+lr) ,%push-multiple)
                        (inline ,(make-info-kill*-live* '() callee-save-fpregs) ,%push-fpmultiple)
                        ;; maybe activate
                        ,(if adjust-active?
                             `(seq
                               (set! ,%Cretval ,(%inline activate-thread))
                               (set! ,(%mref ,%sp ,active-state-offset) ,%Cretval))
                             `(nop))
                        ;; set up tc for benefit of argument-conversion code, which might allocate
                        ,(if-feature pthreads
                           (%seq 
                            (set! ,%Cretval ,(%inline get-tc))
                            (set! ,%tc ,%Cretval))
                           `(set! ,%tc (literal ,(make-info-literal #f 'entry (lookup-c-entry thread-context) 0))))))
                     ;; list of procedures that marshal arguments from their C stack locations
                     ;; to the Scheme argument locations
                     (do-args arg-type* arg-cat* arg-regs-offset arg-fpregs-offset args-offset return-offset
                              synthesize-first? indirect-result?)
                     (do-result result-type result-cat synthesize-first? return-offset)
                     (lambda ()
                       (in-context Tail
                        (%seq
                         ,(if adjust-active?
                              (%seq
                               ;; We need *(sp+active-state-offset) in %Carg1,
                               ;; but that can also be a return register.
                               ;; Meanwhle, sp may change before we call unactivate.
                               ;; So, move to %r2 for now, then %Carg1 later:
                               (set! ,%argtmp ,(%mref ,%sp ,active-state-offset))
                               ,(save-and-restore
                                 result-regs
                                 `(seq
                                   (set! ,%Carg1 ,%argtmp)
                                   ,(%inline unactivate-thread ,%Carg1))))
                              `(nop))
                         ;; restore the callee save registers
                         (inline ,(make-info-kill* callee-save-fpregs) ,%pop-fpmultiple)
                         (inline ,(make-info-kill* callee-save-regs+lr) ,%pop-multiple)
                         ;; deallocate space for pad & arg reg values
                         (set! ,%sp ,(%inline + ,%sp (immediate ,(fx+ active-state-bytes return-bytes float-reg-bytes int-reg-bytes))))
                         ;; done
                         (asm-c-return ,null-info ,callee-save-regs+lr ... ,callee-save-fpregs ... ,result-regs ...)))))))))))))
)
