;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

; file: "target-m68000-1.scm"

;------------------------------------------------------------------------------
;
; Target machine abstraction (for M68000):

; The virtual machine implementation is a mapping of PVM instructions
; and operands to M68000 instructions and operands.  The mapping of
; operands is fairly simple because M68000 operands form a superset of
; PVM operands.  PVM registers are mapped to M68000 registers, the PVM stack
; is implemented with the M68000's stack and global variables are
; implemented by an array of objects.
;
; The M68000's registers are dedicated as follows:
;
; D0      temporary register (also used as the argument count register)
; D1..D4  PVM registers 1 to 4
; D5      interrupt countdown timer (low 16 bits)
; D6      always = () = 11101111111011111110111111101111 (placeholder mask)
; D7      always = #f = 11110111111101111111011111110111 (pair mask)
;
; A0      PVM register 0 (mostly used to hold the return address)
; A1..A2  temporary registers (to implement PVM instructions)
; A3      heap allocation pointer (grows downwards)
; A4      lazy task queue tail pointer (grows downwards)
; A5      always = pointer to the processor's state (local variables)
; A6      always = pointer to the global variable table and code area
; A7      stack pointer (grows downwards)

;------------------------------------------------------------------------------

(define (begin! info-port targ) ; initialize package

  (set! return-reg (make-reg 0))

  (target-end!-set!         targ end!)
  (target-dump-set!         targ dump)
  (target-nb-regs-set!      targ nb-pvm-regs)
  (target-prim-info-set!    targ prim-info)
  (target-label-info-set!   targ label-info)
  (target-jump-info-set!    targ jump-info)
  (target-proc-result-set!  targ (make-reg 1))
  (target-task-return-set!  targ return-reg)

  (set! *info-port* info-port)

  '())

(define (end!) ; finalize package
  '())

(define *info-port* '())

;------------------------------------------------------------------------------
;
; Usage of registers:

(define nb-pvm-regs 5) ; Number of registers in the virtual machine.

(define nb-arg-regs 3) ; Number of registers used to pass arguments.

;------------------------------------------------------------------------------
;
; Size of an object pointer

(define pointer-size 4)

;------------------------------------------------------------------------------
;
; Primitive procedure database:

(define prim-proc-table
  (map (lambda (x)
         (cons (string->canonical-symbol (car x))
               (apply make-proc-obj (car x) #t #f (cdr x))))
       prim-procs))

(define (prim-info name)
  (let ((x (assq name prim-proc-table)))
    (if x (cdr x) #f)))

(define (get-prim-info name)
  (let ((proc (prim-info (string->canonical-symbol name))))
    (if proc
      proc
      (compiler-internal-error
        "get-prim-info, unknown primitive:" name))))

;------------------------------------------------------------------------------
;
; Procedure calling convention:

(define (label-info min-args nb-parms rest? closed?)

;  * return address is in reg(0)
;
;  * if nb-parms <= nb-arg-regs,
;
;      then, parameter `n' is in reg(n)
;
;      else, the first `m' = nb-parms - nb-arg-regs
;            parameters will be on the stack and parameter `n' is in
;
;            reg(n - m), if n > m
;            or else in stk(frame_size + n - m)
;
;  * if `CLOSED' is present, reg(nb-arg-regs + 1) contains a pointer to the
;    closure object
;
; for example, if we assume that nb-arg-regs = 3, then after the
; instruction LABEL(1,2,PROC,5):
;
;   reg(0) = return address
;   stk(1) = parameter 1
;   stk(2) = parameter 2
;   reg(1) = parameter 3
;   reg(2) = parameter 4
;   reg(3) = parameter 5

  (let ((nb-stacked (max 0 (- nb-parms nb-arg-regs))))

    (define (location-of-parms i)
      (if (> i nb-parms)
        '()
        (cons (cons i
                    (if (> i nb-stacked)
                      (make-reg (- i nb-stacked))
                      (make-stk i)))
              (location-of-parms (+ i 1)))))

    (let ((x (cons (cons 'return 0) (location-of-parms 1))))
      (make-pcontext nb-stacked
        (if closed?
          (cons (cons 'closure-env (make-reg (+ nb-arg-regs 1))) x)
          x)))))

(define (jump-info nb-args)

;  * the return address is passed in reg(0)
;
;  * if nb-args <= nb-arg-regs,
;
;      then, argument `n' is in reg(n)
;
;      else, `m' = nb-args - nb-arg-regs arguments are passed
;            on the stack and argument `n' is in
;
;            reg(n - m), if n > m
;            or else in stk(frame_size + n - m) if n <= m

  (let ((nb-stacked (max 0 (- nb-args nb-arg-regs))))

    (define (location-of-args i)
      (if (> i nb-args)
        '()
        (cons (cons i
                    (if (> i nb-stacked)
                      (make-reg (- i nb-stacked))
                      (make-stk i)))
              (location-of-args (+ i 1)))))

    (make-pcontext nb-stacked
                   (cons (cons 'return (make-reg 0))
                         (location-of-args 1)))))

(define (closed-var-offset i)

; a closure looks like:
;
;      _____________________
;     |__length__|___JSR____|          | high
;     |_____________________| code ptr |
;     |_____________________| var 1    V
;     |_____________________| ...
;     |_____________________| var N
;      <----- 32 bits ----->

  (+ (* i pointer-size) 2))

;------------------------------------------------------------------------------
;
; Translation of PVM instructions into target machine instructions:

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (dump proc filename options)

  (if *info-port*
    (begin
      (display "Dumping:" *info-port*)
      (newline *info-port*)))

  (set! ofile-asm?   (memq 'ASM   options))
  (set! ofile-stats? (memq 'STATS options))
  (set! debug-info?  (memq 'DEBUG options))

  (set! object-queue (queue-empty))
  (set! objects-dumped (queue-empty))

  (ofile.begin! filename add-object)

  (queue-put! object-queue proc)
  (queue-put! objects-dumped proc)

  (let loop ((index 0))
    (if (not (queue-empty? object-queue))
      (let ((obj (queue-get! object-queue)))

        (dump-object obj index)

        (loop (+ index 1)))))

  (ofile.end!)

  (if *info-port*
    (newline *info-port*))

  (set! object-queue '())
  (set! objects-dumped '()))

(define debug-info? '())
(define object-queue '())
(define objects-dumped '())

;------------------------------------------------------------------------------

(define (add-object obj)
  (if (and (proc-obj? obj) (not (proc-obj-code obj)))
    #f
    (let ((n (pos-in-list obj (queue->list objects-dumped))))
      (if n
        n
        (let ((m (length (queue->list objects-dumped))))
          (queue-put! objects-dumped obj)
          (queue-put! object-queue obj)
          m)))))

;------------------------------------------------------------------------------

(define (dump-object obj index)

  (ofile-line "|------------------------------------------------------")

  (case (obj-type obj)
    ((PAIR)        (dump-PAIR obj))
    ((SUBTYPED)    (case (obj-subtype obj)
                     ((VECTOR) (dump-VECTOR obj))
                     ((SYMBOL) (dump-SYMBOL obj))
                     ((RATNUM) (dump-RATNUM obj))
                     ((CPXNUM) (dump-CPXNUM obj))
                     ((STRING) (dump-STRING obj))
                     ((FLONUM) (dump-FLONUM obj))
                     ((BIGNUM) (dump-BIGNUM obj))
                     (else
                      (compiler-internal-error
                        "dump-object, can't dump object 'obj':" obj))))
    ((PROCEDURE)   (dump-PROCEDURE obj))
    (else
     (compiler-internal-error
       "dump-object, can't dump object 'obj':" obj))))

;------------------------------------------------------------------------------

(define (dump-PAIR pair)
  (ofile-long pair-prefix)
  (ofile-ref (cdr pair))
  (ofile-ref (car pair)))

;------------------------------------------------------------------------------

(define (dump-VECTOR v)
  (ofile-long (+ (* (vector-length v) #x400) (* subtype-VECTOR 8)))
  (let ((len (vector-length v)))
    (let loop ((i 0))
      (if (< i len)
        (begin
          (ofile-ref (vector-ref v i))
          (loop (+ i 1)))))))

;------------------------------------------------------------------------------

(define (dump-SYMBOL sym)
  (compiler-internal-error
    "dump-symbol, can't dump SYMBOL type"))

;------------------------------------------------------------------------------

(define (dump-RATNUM x)
  (ofile-long (+ (* 2 #x400) (* subtype-RATNUM 8)))
  (ofile-ref (numerator x))
  (ofile-ref (denominator x)))

;------------------------------------------------------------------------------

(define (dump-CPXNUM x)
  (ofile-long (+ (* 2 #x400) (* subtype-CPXNUM 8)))
  (ofile-ref (real-part x))
  (ofile-ref (imag-part x)))

;------------------------------------------------------------------------------

(define (dump-STRING s)
  (ofile-long (+ (* (string-length s) #x100) (* subtype-STRING 8)))
  (let ((len (string-length s)))
    (define (ref i) (if (>= i len) 0 (character-encoding (string-ref s i))))
    (let loop ((i 0))
      (if (< i len)
        (begin
          (ofile-word (+ (* (ref i) 256) (ref (+ i 1))))
          (loop (+ i 2)))))))

;------------------------------------------------------------------------------

(define (dump-FLONUM x)
  (let ((bits (flonum->bits x)))
    (ofile-long (+ (* 2 #x400) (* subtype-FLONUM 8)))
    (ofile-long (quotient bits #x100000000))
    (ofile-long (modulo   bits #x100000000))))

(define (flonum->inexact-exponential-format x)

  (define (exp-form-pos x y i)
    (let ((i*2 (+ i i)))
      (let ((z (if (and (not (< flonum-e-bias i*2))
                        (not (< x y)))
                 (exp-form-pos x (* y y) i*2)
                 (cons x 0))))
        (let ((a (car z)) (b (cdr z)))
          (let ((i+b (+ i b)))
            (if (and (not (< flonum-e-bias i+b))
                     (not (< a y)))
              (begin
                (set-car! z (/ a y))
                (set-cdr! z i+b)))
            z)))))

  (define (exp-form-neg x y i)
    (let ((i*2 (+ i i)))
      (let ((z (if (and (< i*2 flonum-e-bias-minus-1)
                        (< x y))
                 (exp-form-neg x (* y y) i*2)
                 (cons x 0))))
        (let ((a (car z)) (b (cdr z)))
          (let ((i+b (+ i b)))
            (if (and (< i+b flonum-e-bias-minus-1)
                     (< a y))
              (begin
                (set-car! z (/ a y))
                (set-cdr! z i+b)))
            z)))))

  (define (exp-form x)
    (if (< x inexact-+1)
      (let ((z (exp-form-neg x inexact-+1/2 1)))
        (set-car! z (* inexact-+2 (car z)))
        (set-cdr! z (- -1 (cdr z)))
        z)
      (exp-form-pos x inexact-+2 1)))

  (if (negative? x)
    (let ((z (exp-form (- inexact-0 x))))
      (set-car! z (- inexact-0 (car z)))
      z)
    (exp-form x)))

(define (flonum->exact-exponential-format x)
  (let ((z (flonum->inexact-exponential-format x)))
    (let ((y (car z)))
      (cond ((not (< y inexact-+2))
             (set-car! z flonum-+m-min)
             (set-cdr! z flonum-e-bias-plus-1))
            ((not (< inexact--2 y))
             (set-car! z flonum--m-min)
             (set-cdr! z flonum-e-bias-plus-1))
            (else
             (set-car! z
               (truncate (inexact->exact (* (car z) inexact-m-min))))))
      (set-cdr! z (- (cdr z) flonum-m-bits))
      z)))

(define (flonum->bits x)

  (define (bits a b)
    (if (< a flonum-+m-min)
      a
      (+ (- a flonum-+m-min)
         (* (+ (+ b flonum-m-bits) flonum-e-bias)
            flonum-+m-min))))

  (let ((z (flonum->exact-exponential-format x)))
    (let ((a (car z)) (b (cdr z)))
      (if (negative? a)
        (+ flonum-sign-bit (bits (- 0 a) b))
        (bits a b)))))

(define flonum-m-bits         52)
(define flonum-e-bits         11)
(define flonum-sign-bit       #x8000000000000000) ; (expt 2 (+ flonum-e-bits flonum-m-bits))
(define flonum-+m-min         4503599627370496)   ; (expt 2 flonum-m-bits)
(define flonum--m-min         -4503599627370496)  ; (- flonum-+m-min)
(define flonum-e-bias         1023) ; (- (expt 2 (- flonum-e-bits 1)) 1)
(define flonum-e-bias-plus-1  1024) ; (+ flonum-e-bias 1)
(define flonum-e-bias-minus-1 1022) ; (- flonum-e-bias 1)

(define inexact-m-min         (exact->inexact flonum-+m-min))
(define inexact-+2            (exact->inexact 2))
(define inexact--2            (exact->inexact -2))
(define inexact-+1            (exact->inexact 1))
(define inexact-+1/2          (exact->inexact (/ 1 2)))
(define inexact-0             (exact->inexact 0))

;------------------------------------------------------------------------------

(define (dump-BIGNUM x)

  (define radix 16384)

  (define (integer->digits n)
    (if (= n 0)
      '()
      (cons (remainder n radix)
            (integer->digits (quotient n radix)))))

  (let ((l (integer->digits (abs x))))

    (ofile-long (+ (* (+ (length l) 1) #x200) (* subtype-BIGNUM 8)))

    (if (< x 0)
      (ofile-word 0)
      (ofile-word 1))

    (for-each ofile-word l)))

;------------------------------------------------------------------------------

(define (dump-PROCEDURE proc)
  (let ((bbs (proc-obj-code proc)))

    (set! entry-lbl-num (bbs-entry-lbl-num bbs))
    (set! label-counter (bbs-lbl-counter bbs))
    (set! var-descr-queue (queue-empty))
    (set! first-class-label-queue (queue-empty))
    (set! deferred-code-queue (queue-empty))

    (if *info-port*
      (begin
        (display "  #[" *info-port*)
        (if (proc-obj-primitive? proc)
          (display "primitive " *info-port*)
          (display "procedure " *info-port*))
        (display (proc-obj-name proc) *info-port*)
        (display "]" *info-port*)))

    (if (proc-obj-primitive? proc)
      (ofile-prim-proc (proc-obj-name proc))
      (ofile-user-proc))

    (asm.begin!)

    (let loop ((prev-bb #f)
               (prev-pvm-instr #f)
               (l (bbs->code-list bbs)))
      (if (not (null? l))
        (let ((pres-bb (code-bb (car l)))
              (pres-pvm-instr (code-pvm-instr (car l)))
              (pres-slots-needed (code-slots-needed (car l)))
              (next-pvm-instr (if (null? (cdr l))
                                #f
                                (code-pvm-instr (cadr l)))))

          (if ofile-asm? (asm-comment (car l)))

          (gen-pvm-instr prev-pvm-instr
                         pres-pvm-instr
                         next-pvm-instr
                         pres-slots-needed)

          (loop pres-bb pres-pvm-instr (cdr l)))))

    (asm.end!
      (if debug-info?
        (vector (lst->vector (queue->list first-class-label-queue))
                (lst->vector (queue->list var-descr-queue)))
        #f))

    (if *info-port*
      (newline *info-port*))

    (set! var-descr-queue '())
    (set! first-class-label-queue '())
    (set! deferred-code-queue '())
    (set! instr-source '())
    (set! entry-frame '())
    (set! exit-frame '())))

(define label-counter '())
(define entry-lbl-num '())
(define var-descr-queue '())
(define first-class-label-queue '())
(define deferred-code-queue '())
(define instr-source '())
(define entry-frame '())
(define exit-frame '())

(define (defer-code! thunk)
  (queue-put! deferred-code-queue thunk))

(define (gen-deferred-code!)
  (let loop ()
    (if (not (queue-empty? deferred-code-queue))
      (let ((thunk (queue-get! deferred-code-queue)))
        (thunk)
        (loop)))))

(define (add-var-descr! descr)

  (define (index x l)
    (let loop ((l l) (i 0))
      (cond ((not (pair? l))    #f)
            ((equal? (car l) x) i)
            (else               (loop (cdr l) (+ i 1))))))

  (let ((n (index descr (queue->list var-descr-queue))))
    (if n
      n
      (let ((m (length (queue->list var-descr-queue))))
        (queue-put! var-descr-queue descr)
        m))))

(define (add-first-class-label! source slots frame)
  (let loop ((i 0) (l1 slots) (l2 '()))
    (if (pair? l1)
      (let ((var (car l1)))
        (let ((x (frame-live? var frame)))
          (if (and x (or (pair? x) (not (temp-var? x))))
            (let ((descr-index
                    (add-var-descr!
                     (if (pair? x)
                        (map (lambda (y) (add-var-descr! (var-name y))) x)
                        (var-name x)))))
              (loop (+ i 1) (cdr l1) (cons (+ (* i 16384) descr-index) l2)))
            (loop (+ i 1) (cdr l1) l2))))
      (let ((label-descr (lst->vector (cons 0 (cons source l2)))))
        (queue-put! first-class-label-queue label-descr)
        label-descr))))

(define (gen-pvm-instr prev-pvm-instr pvm-instr next-pvm-instr sn)

  (set! instr-source (comment-get (pvm-instr-comment pvm-instr) 'SOURCE))
  (set! exit-frame   (pvm-instr-frame pvm-instr))
  (set! entry-frame  (and prev-pvm-instr (pvm-instr-frame prev-pvm-instr)))

  (case (pvm-instr-type pvm-instr)

    ((LABEL)
     (set! entry-frame exit-frame)
     (set! current-fs (frame-size exit-frame))
     (case (LABEL-type pvm-instr)
       ((SIMP)
        (gen-LABEL-SIMP (LABEL-lbl-num pvm-instr)
                        sn))
       ((TASK)
        (gen-LABEL-TASK (LABEL-lbl-num pvm-instr)
                        (LABEL-TASK-method pvm-instr)
                        sn))
       ((PROC)
        (gen-LABEL-PROC (LABEL-lbl-num pvm-instr)
                        (LABEL-PROC-nb-parms pvm-instr)
                        (LABEL-PROC-min pvm-instr)
                        (LABEL-PROC-rest? pvm-instr)
                        (LABEL-PROC-closed? pvm-instr)
                        sn))
       ((RETURN)
        (gen-LABEL-RETURN (LABEL-lbl-num pvm-instr)
                          (LABEL-RETURN-task-method pvm-instr)
                          sn))
       (else
        (compiler-internal-error
          "gen-pvm-instr, unknown label type"))))

    ((APPLY)
     (gen-APPLY (APPLY-prim pvm-instr)
                (APPLY-opnds pvm-instr)
                (APPLY-loc pvm-instr)
                sn))

    ((COPY)
     (gen-COPY (COPY-opnd pvm-instr)
               (COPY-loc pvm-instr)
               sn))

    ((MAKE_CLOSURES)
     (gen-MAKE_CLOSURES (MAKE_CLOSURES-parms pvm-instr)
                        sn))

    ((COND)
     (gen-COND (COND-test pvm-instr)
               (COND-opnds pvm-instr)
               (COND-true pvm-instr)
               (COND-false pvm-instr)
               (COND-intr-check? pvm-instr)
               (if (and next-pvm-instr
                        (memq (LABEL-type next-pvm-instr) '(SIMP TASK)))
                 (LABEL-lbl-num next-pvm-instr)
                 #f)))

    ((JUMP)
     (gen-JUMP (JUMP-opnd pvm-instr)
               (JUMP-nb-args pvm-instr)
               (JUMP-intr-check? pvm-instr)
               (if (and next-pvm-instr
                        (memq (LABEL-type next-pvm-instr) '(SIMP TASK)))
                 (LABEL-lbl-num next-pvm-instr)
                 #f)))

    (else
     (compiler-internal-error
       "gen-pvm-instr, unknown 'pvm-instr':"
       pvm-instr))))


;------------------------------------------------------------------------------
;
; Useful tools:

(define (reg-in-opnd68 opnd) ; return the register used in an operand
  (cond ((dreg? opnd) opnd)
        ((areg? opnd) opnd)
        ((ind? opnd)  (ind-areg opnd))
        ((pinc? opnd) (pinc-areg opnd))
        ((pdec? opnd) (pdec-areg opnd))
        ((disp? opnd) (disp-areg opnd))
        ((inx? opnd)  (inx-ireg opnd)) ; disregard address register
        (else         #f)))

(define (temp-in-opnd68 opnd) ; return the temporary reg used in an operand
  (let ((reg (reg-in-opnd68 opnd)))
    (if reg
      (cond ((identical-opnd68? reg dtemp1) reg)
            ((identical-opnd68? reg atemp1) reg)
            ((identical-opnd68? reg atemp2) reg)
            (else                           #f))
      #f)))

(define (pick-atemp keep) ; return a temp address reg different from 'keep'
  (if (and keep (identical-opnd68? keep atemp1))
    atemp2
    atemp1))

(define return-reg '())

; structures:

(define max-nb-args           1024)

(define heap-allocation-fudge (* pointer-size (+ (* 2 max-nb-args) 1024)))

(define intr-flag             0)
(define ltq-tail              1)
(define ltq-head              2)
(define heap-lim              12)
(define closure-lim           17)
(define closure-ptr           18)
(define workq-head            22)

(define intr-flag-slot   (make-disp* pstate-reg (* pointer-size intr-flag)))
(define ltq-tail-slot    (make-disp* pstate-reg (* pointer-size ltq-tail)))
(define ltq-head-slot    (make-disp* pstate-reg (* pointer-size ltq-head)))
(define heap-lim-slot    (make-disp* pstate-reg (* pointer-size heap-lim)))
(define closure-lim-slot (make-disp* pstate-reg (* pointer-size closure-lim)))
(define closure-ptr-slot (make-disp* pstate-reg (* pointer-size closure-ptr)))
(define workq-head-slot  (make-disp* pstate-reg (* pointer-size workq-head)))

(define TOUCH-trap                1)
(define non-proc-jump-trap        6)
(define rest-params-trap          7)
(define rest-params-closed-trap   8)
(define wrong-nb-arg1-trap        9)
(define wrong-nb-arg1-closed-trap 10)
(define wrong-nb-arg2-trap        11)
(define wrong-nb-arg2-closed-trap 12)
(define heap-alloc1-trap          13)
(define heap-alloc2-trap          14)
(define closure-alloc-trap        15)
(define delay-future-trap         16)
(define eager-future-trap         17)
(define steal-conflict-trap       18)
(define intr-trap                 24)

(define cache-line-length         16) ; works on 68020/68030/68040

(define intr-latency '())
(set! intr-latency                10) ; controls interrupt latency

(define lazy-task-kind '())
(set! lazy-task-kind              'MESSAGE-PASSING-LTQ) ; what kind of LTC

;------------------------------------------------------------------------------

(define (stat-clear!)
  (set! *stats* (cons 0 '())))

(define (stat-dump!)
  (emit-stat (cdr *stats*)))

(define (stat-add! bin count)

  (define (add! stats bin count)
    (set-car! stats (+ (car stats) count))
    (if (not (null? bin))
      (let ((x (assoc (car bin) (cdr stats))))
        (if x
          (add! (cdr x) (cdr bin) count)
          (begin
            (set-cdr! stats (cons (list (car bin) 0) (cdr stats)))
            (add! (cdadr stats) (cdr bin) count))))))

  (add! *stats* bin count))

(define (fetch-stat-add! pvm-opnd)
  (opnd-stat-add! 'fetch pvm-opnd))

(define (store-stat-add! pvm-opnd)
  (opnd-stat-add! 'store pvm-opnd))

(define (jump-stat-add! pvm-opnd)
  (opnd-stat-add! 'jump pvm-opnd))

(define (opnd-stat-add! type opnd)
  (cond ((reg? opnd)
         (stat-add! (list 'pvm-opnd 'reg type (reg-num opnd)) 1))
        ((stk? opnd)
         (stat-add! (list 'pvm-opnd 'stk type) 1))
        ((glo? opnd)
         (stat-add! (list 'pvm-opnd 'glo type (glo-name opnd)) 1))
        ((clo? opnd)
         (stat-add! (list 'pvm-opnd 'clo type) 1)
         (fetch-stat-add! (clo-base opnd)))
        ((lbl? opnd)
         (stat-add! (list 'pvm-opnd 'lbl type) 1))
        ((obj? opnd)
         (let ((val (obj-val opnd)))
           (if (number? val)
             (stat-add! (list 'pvm-opnd 'obj type val) 1)
             (stat-add! (list 'pvm-opnd 'obj type (obj-type val)) 1))))
        (else
         (compiler-internal-error
           "opnd-stat-add!, unknown 'opnd':" opnd))))

(define (opnd-stat opnd)
  (cond ((reg? opnd) 'reg)
        ((stk? opnd) 'stk)
        ((glo? opnd) 'glo)
        ((clo? opnd) 'clo)
        ((lbl? opnd) 'lbl)
        ((obj? opnd) 'obj)
        (else
         (compiler-internal-error
           "opnd-stat, unknown 'opnd':" opnd))))

(define *stats* '())

;------------------------------------------------------------------------------

(define (move-opnd68-to-loc68 opnd loc)
  (if (not (identical-opnd68? opnd loc))
    (if (imm? opnd)
      (move-n-to-loc68 (imm-val opnd) loc)
      (emit-move.l opnd loc))))

(define (move-obj-to-loc68 obj loc)
  (let ((n (obj-encoding obj)))
    (if n
      (move-n-to-loc68 n loc)
      (emit-move.l (emit-const obj) loc))))

(define (move-n-to-loc68 n loc)
  (cond ((= n bits-NULL)
         (emit-move.l null-reg loc))
        ((= n bits-FALSE)
         (emit-move.l false-reg loc))
        ((and (dreg? loc) (>= n -128) (<= n 127))
         (emit-moveq n loc))
        ((and (areg? loc) (>= n -32768) (<= n 32767))
         (emit-move.w (make-imm n) loc))
        ((and (areg? loc) (>= n 0) (<= n 65535))
         (emit-lea* n loc))
        ((and (identical-opnd68? loc pdec-sp) (>= n 0) (<= n 65535))
         (emit-pea* n))
        ((= n 0)
         (emit-clr.l loc))
        ((and (not (and (inx? loc) (= (inx-ireg loc) dtemp1))) (>= n -128) (<= n 127))
         (emit-moveq n dtemp1)
         (emit-move.l dtemp1 loc))
        (else
         (emit-move.l (make-imm n) loc))))

(define (add-n-to-loc68 n loc)
  (if (not (= n 0))
    (cond ((and (>= n -8) (<= n 8))
           (if (> n 0) (emit-addq.l n loc) (emit-subq.l (- n) loc)))
          ((and (areg? loc) (>= n -32768) (<= n 32767))
           (emit-lea (make-disp loc n) loc))
          ((and (not (identical-opnd68? loc dtemp1)) (>= n -128) (<= n 128))
           (emit-moveq (- (abs n)) dtemp1)
           (if (> n 0) (emit-sub.l dtemp1 loc) (emit-add.l dtemp1 loc)))
          (else
           (emit-add.l (make-imm n) loc)))))

(define (power-of-2 n)
  (let loop ((i 0) (k 1))
    (cond ((= k n) i)
          ((> k n) #f)
          (else    (loop (+ i 1) (* k 2))))))

(define (mul-n-to-reg68 n reg)
  (if (= n 0)
    (emit-moveq 0 reg)
    (let ((abs-n (abs n)))
      (if (= abs-n 1)
        (if (< n 0) (emit-neg.l reg))
        (let ((shift (power-of-2 abs-n)))
          (if shift
            (let ((m (min shift 32)))
              (if (or (<= m 8) (identical-opnd68? reg dtemp1))
                (let loop ((i m))
                  (if (> i 0)
                    (begin (emit-asl.l (make-imm (min i 8)) reg) (loop (- i 8)))))
                (begin
                  (emit-moveq m dtemp1)
                  (emit-asl.l dtemp1 reg)))
              (if (< n 0) (emit-neg.l reg)))
            (emit-muls.l (make-imm n) reg)))))))

(define (div-n-to-reg68 n reg)
  (let ((abs-n (abs n)))
    (if (= abs-n 1)
      (if (< n 0) (emit-neg.l reg))
      (let ((shift (power-of-2 abs-n)))
        (if shift
          (let ((m (min shift 32))
                (lbl (new-lbl!)))
            (emit-move.l reg reg)
            (emit-bpl lbl)
            (add-n-to-loc68 (* (- abs-n 1) 8) reg)
            (emit-label lbl)
            (if (or (<= m 8) (identical-opnd68? reg dtemp1))
              (let loop ((i m))
                (if (> i 0)
                  (begin (emit-asr.l (make-imm (min i 8)) reg) (loop (- i 8)))))
              (begin
                (emit-moveq m dtemp1)
                (emit-asr.l dtemp1 reg)))
            (if (< n 0) (emit-neg.l reg)))
          (emit-divsl.l (make-imm n) reg reg))))))

(define (cmp-n-to-opnd68 n opnd)
  (cond ((= n bits-NULL)
         (emit-cmp.l opnd null-reg)
         #f)
        ((= n bits-FALSE)
         (emit-cmp.l opnd false-reg)
         #f)
        ((or (pcr? opnd) (imm? opnd))
         (if (= n 0)
           (begin
             (emit-move.l opnd dtemp1)
             #t)
           (begin
             (move-opnd68-to-loc68 opnd atemp1)
             (if (and (>= n -32768) (<= n 32767))
               (emit-cmp.w (make-imm n) atemp1)
               (emit-cmp.l (make-imm n) atemp1))
             #t)))
        ((= n 0)
         (emit-move.l opnd dtemp1)
         #t)
        ((and (>= n -128) (<= n 127) (not (identical-opnd68? opnd dtemp1)))
         (emit-moveq n dtemp1)
         (emit-cmp.l opnd dtemp1)
         #f)
        (else
         (emit-cmp.l (make-imm n) opnd)
         #t)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (might-touch-opnd? opnd)
  (cond ((pot-fut? opnd)
         #t)
        ((clo? opnd)
         (might-touch-opnd? (clo-base opnd)))
        (else
         #f)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; current-fs is the current frame size.

(define current-fs '())

; (adjust-current-fs n) adds 'n' to the current frame size.

(define (adjust-current-fs n)
  (set! current-fs (+ current-fs n)))

; (new-lbl!) returns a new label number different from all others in this
; procedure.

(define (new-lbl!)
  (label-counter))

; (needed? loc sn) is false if we are sure that the location 'loc' is not
; needed (assuming that only 'sn' slots on the stack are needed).

(define (needed? loc sn)
  (and loc (if (stk? loc) (<= (stk-num loc) sn) #t)))

; (sn-opnd opnd sn) returns the number of slots that are needed in the
; stack frame to reference 'opnd'.  'sn' is the number of slots that must be
; preserved in the frame.

(define (sn-opnd opnd sn)
  (cond ((stk? opnd)
         (max (stk-num opnd) sn))
        ((clo? opnd)
         (sn-opnd (clo-base opnd) sn))
        (else
         sn)))

; (sn-opnds opnds sn) returns the number of slots that are needed in the
; stack frame to reference all of the operands in 'opnds'.  'sn' is the number
; of slots that must be preserved in the frame.

(define (sn-opnds opnds sn)
  (if (null? opnds)
    sn
    (sn-opnd (car opnds) (sn-opnds (cdr opnds) sn))))

; (sn-opnd68 opnd sn) is similar to 'sn-opnd' except that it works with
; M68000 operands.

(define (sn-opnd68 opnd sn)
  (cond ((and (disp*? opnd) (identical-opnd68? (disp*-areg opnd) sp-reg))
         (max (disp*-offset opnd) sn))
        ((identical-opnd68? opnd pdec-sp)
         (max (+ current-fs 1) sn))
        ((identical-opnd68? opnd pinc-sp)
         (max current-fs sn))
        (else
         sn)))

; (resize-frame n) generates the code to move the stack pointer to
; frame slot number 'n'.

(define (resize-frame n)
  (let ((x (- n current-fs)))
    (adjust-current-fs x)
    (add-n-to-loc68 (* (- pointer-size) x) sp-reg)))

; (shrink-frame n) generates the code to resize the frame to leave
; only the first 'n' slots on the stack.

(define (shrink-frame n)
  (cond ((< n current-fs)
         (resize-frame n))
        ((> n current-fs)
         (compiler-internal-error "shrink-frame, can't increase frame size"))))

; (make-top-of-frame n sn) generates the code to resize the frame so that
; slot 'n' is on top of the stack while leaving at least 'sn' slots
; in the frame.

(define (make-top-of-frame n sn)
  (if (and (< n current-fs) (>= n sn)) (resize-frame n)))

; (make-top-of-frame-if-stk-opnd68 opnd sn) generates the code to resize the
; frame so that a subsequent reference to 'opnd' (if it is a stack slot) will
; be easier.  'sn' is the number of slots that must be preserved in the
; frame (the stack frame might be shrunk down to that size).

(define (make-top-of-frame-if-stk-opnd68 opnd sn)
  (if (frame-base-rel? opnd)
    (make-top-of-frame (frame-base-rel-slot opnd) sn)))

; (make-top-of-frame-if-stk-opnds68 opnd1 opnd2 sn) generates the code to resize
; the frame so that subsequent references to 'opnd1' and 'opnd2' (if they are
; stack slots) will be easier.  'sn' is the number of slots that must be
; preserved in the frame (the stack frame might be shrunk down to that size).

(define (make-top-of-frame-if-stk-opnds68 opnd1 opnd2 sn)
  (if (frame-base-rel? opnd1)
    (let ((slot1 (frame-base-rel-slot opnd1)))
      (if (frame-base-rel? opnd2)
        (make-top-of-frame (max (frame-base-rel-slot opnd2) slot1) sn)
        (make-top-of-frame slot1 sn)))
    (if (frame-base-rel? opnd2)
      (make-top-of-frame (frame-base-rel-slot opnd2) sn))))

; (opnd68->true-opnd68 opnd sn) transforms 'frame base relative' stack operands
; into 'top of stack relative' stack operands (as they must appear to the
; processor).  'push' or 'pop' operands are returned when possible.  All
; other operands are already correct so they are simply returned unchanged.

(define (opnd68->true-opnd68 opnd sn)
  (if (frame-base-rel? opnd)
    (let ((slot (frame-base-rel-slot opnd)))

      (cond ((> slot current-fs) ; push?
             (adjust-current-fs 1)
             pdec-sp)             

            ((and (= slot current-fs) (< sn current-fs)) ; pop?
             (adjust-current-fs -1)
             pinc-sp)

            (else
             (make-disp* sp-reg (* pointer-size (- current-fs slot))))))

    opnd))

; (move-opnd68-to-any-areg opnd keep sn) generates the code to move the value
; from a M68000 operand to any address register.  'keep' (if not #f) is a
; M68000 register that must not be modified.

(define (move-opnd68-to-any-areg opnd keep sn)
  (if (areg? opnd)
    opnd
    (let ((areg (pick-atemp keep)))
      (make-top-of-frame-if-stk-opnd68 opnd sn)
      (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) areg)
      areg)))

; (clo->opnd68 opnd keep sn) returns the M68000 operand corresponding
; to the PVM closed operand 'opnd'.  'keep' (if not #f) is a M68000
; register that must not be modified.  Code might be generated in the
; process (to load the base in an address register and/or to touch
; the base if it is a touch operand).

(define (clo->opnd68 opnd keep sn)
  (let ((base (clo-base opnd))
        (offs (closed-var-offset (clo-index opnd))))
    (if (lbl? base)
      (make-pcr (lbl-num base) offs)
      (clo->loc68 opnd keep sn))))

; (clo->loc68 opnd keep sn) is similar in function to 'clo->opnd68' except
; that a 'data alterable' addressing mode operand is returned.

(define (clo->loc68 opnd keep sn)
  (let ((base (clo-base opnd))
        (offs (closed-var-offset (clo-index opnd))))

    (cond ((eq? base return-reg)
           (make-disp* (reg->reg68 base) offs))

          ((obj? base)
           (let ((areg (pick-atemp keep)))
             (move-obj-to-loc68 (obj-val base) areg)
             (make-disp* areg offs)))

          ((pot-fut? base)
           (let ((reg (touch-opnd-to-any-reg68 base keep sn)))
             (make-disp* (move-opnd68-to-any-areg reg keep sn) offs)))

          (else
           (let ((areg (pick-atemp keep)))
             (move-opnd-to-loc68 base areg sn)
             (make-disp* areg offs))))))

; (reg->reg68 reg) returns the M68000 register corresponding to the PVM
; register 'reg'.

(define (reg->reg68 reg)
  (reg-num->reg68 (reg-num reg)))

(define (reg-num->reg68 num)
  (if (= num 0) (make-areg pvm-reg0) (make-dreg (+ (- num 1) pvm-reg1))))

; (opnd->opnd68 opnd keep sn) returns the M68000 operand corresponding
; to the PVM operand 'opnd'.  'keep' (if not #f) is a M68000
; register that must not be modified.  Code might be generated in the
; process (to load the base in an address register and/or to touch
; the base if it is a touch operand).

(define (opnd->opnd68 opnd keep sn)
  (cond ((lbl? opnd)
         (let ((areg (pick-atemp keep)))
           (emit-lea (make-pcr (lbl-num opnd) 0) areg)
           areg))

        ((obj? opnd)
         (let ((val (obj-val opnd)))
           (if (proc-obj? val)
             (let ((num (add-object val))
                   (areg (pick-atemp keep)))
               (if num
                 (emit-move-proc num areg)
                 (emit-move-prim val areg))
               areg)
             (let ((n (obj-encoding val)))
               (if n
                 (make-imm n)
                 (emit-const val))))))

        ((clo? opnd)
         (clo->opnd68 opnd keep sn))

        (else
         (loc->loc68 opnd keep sn))))

; (loc->loc68 loc keep sn) returns the M68000 'data alterable' addressing
; mode operand corresponding to the PVM location 'loc'.  'keep' (if not #f)
; is a M68000 register that must not be modified.  Code might be generated
; in the process (to load the base in an address register and/or to touch
; the base if it is a touch operand).

(define (loc->loc68 loc keep sn)

  (cond ((reg? loc)
         (reg->reg68 loc))

        ((stk? loc)
         (make-frame-base-rel (stk-num loc)))
         ; will be converted later by 'opnd68->true-opnd68'

        ((glo? loc)
         (make-glob (glo-name loc)))

        ((clo? loc)
         (clo->loc68 loc keep sn))

        (else
         (compiler-internal-error
           "loc->loc68, unknown 'loc':" loc))))

; (move-opnd68-to-loc opnd loc sn) generates the code to move a
; M68000 operand into a PVM location.  'sn' is the number of slots that
; must be preserved in the frame (the stack frame might be shrunk down
; to that size).

(define (move-opnd68-to-loc opnd loc sn)

  (cond ((reg? loc)
         (make-top-of-frame-if-stk-opnd68 opnd sn)
         (move-opnd68-to-loc68
           (opnd68->true-opnd68 opnd sn)
           (reg->reg68 loc)))

        ((stk? loc)
         (let* ((loc-slot (stk-num loc))
                (sn-after-opnd1 (if (< loc-slot sn) sn (- loc-slot 1))))
           (if (> current-fs loc-slot)
             (make-top-of-frame
               (if (frame-base-rel? opnd)
                 (let ((opnd-slot (frame-base-rel-slot opnd)))
                   (if (>= opnd-slot (- loc-slot 1)) opnd-slot loc-slot))
                 loc-slot)
               sn-after-opnd1))
           (let* ((opnd1 (opnd68->true-opnd68 opnd sn-after-opnd1))
                  (opnd2 (opnd68->true-opnd68 (make-frame-base-rel loc-slot) sn)))
             (move-opnd68-to-loc68 opnd1 opnd2))))

        ((glo? loc)
         (make-top-of-frame-if-stk-opnd68 opnd sn)
         (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn)
                               (make-glob (glo-name loc))))

        ((clo? loc)
         (let ((clo (clo->loc68
                      loc
                      (temp-in-opnd68 opnd)
                      (sn-opnd68 opnd sn))))
           (make-top-of-frame-if-stk-opnd68 opnd sn)
           (move-opnd68-to-loc68
             (opnd68->true-opnd68 opnd sn)
             clo)))

        (else
         (compiler-internal-error
           "move-opnd68-to-loc, unknown 'loc':" loc))))

; (move-opnd-to-loc68 opnd loc68 sn) generates the code to copy the value
; from PVM operand 'opnd' to the M68000 location 'loc68'.

(define (move-opnd-to-loc68 opnd loc68 sn)
  (if (and (lbl? opnd) (areg? loc68))

    (emit-lea (make-pcr (lbl-num opnd) 0) loc68)

    (let* ((sn-after-opnd68 (sn-opnd68 loc68 sn))
           (opnd68 (opnd->opnd68 opnd (temp-in-opnd68 loc68) sn-after-opnd68)))
      (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn)
      (let* ((opnd68* (opnd68->true-opnd68 opnd68 sn-after-opnd68))
             (loc68* (opnd68->true-opnd68 loc68 sn)))
        (move-opnd68-to-loc68 opnd68* loc68*)))))

; (touch-reg68-to-reg68 src dst keep) generates the code to touch the
; M68000 register 'src' and put the result in the M68000 register 'dst'.
; 'keep' (if not #f) is a M68000 register that must not be modified.

(define (touch-reg68-to-reg68 src dst keep)

  (define (trap-to-touch-handler dreg keep lbl)
    (if ofile-stats?
      (emit-stat '((touch 0 (determined-placeholder -1)
                            (undetermined-placeholder 1)))))
    (if keep (begin (emit-move.l keep pdec-sp) (adjust-current-fs 1)))
    (gen-trap instr-source entry-frame #t dreg (+ TOUCH-trap (dreg-num dreg)) lbl)
    (if keep (begin (emit-move.l pinc-sp keep) (adjust-current-fs -1))))

  (define (touch-dreg-to-reg src dst keep)
    (let ((lbl1 (new-lbl!))
;          (lbl2 (new-lbl!))
          (areg (pick-atemp keep)))
      (emit-btst   src placeholder-reg)
      (emit-bne    lbl1)
      (if ofile-stats?
        (emit-stat '((touch 0 (non-placeholder -1)
                              (determined-placeholder 1)))))
;      (emit-move.l src areg)
;      (emit-move.l (make-disp* areg (- type-PLACEHOLDER)) dst)
;      (emit-cmp.l  dst (if (dreg? dst) areg src))
;      (emit-bne    lbl2)
      (trap-to-touch-handler src keep lbl1)
      (move-opnd68-to-loc68 src dst)
;      (emit-label  lbl2)
))

  (define (touch-areg-to-dreg src dst keep)
    (let ((lbl1 (new-lbl!)))
      (emit-move.l src dst)
      (emit-btst   dst placeholder-reg)
      (emit-bne    lbl1)
      (if ofile-stats?
        (emit-stat '((touch 0 (non-placeholder -1)
                              (determined-placeholder 1)))))
;      (emit-move.l (make-disp* src (- type-PLACEHOLDER)) dst)
;      (emit-cmp.l  src dst)
;      (emit-bne    lbl1)
      (trap-to-touch-handler dst keep lbl1)))

  (if ofile-stats? (emit-stat '((touch 1 (non-placeholder 1)))))

  (cond ((dreg? src)
         (touch-dreg-to-reg src dst keep))

        ((dreg? dst)
         (touch-areg-to-dreg src dst keep))

        ((and keep (identical-opnd68? dtemp1 keep))
         (emit-exg src dtemp1)
         (touch-dreg-to-reg dtemp1 dst src)
         (emit-exg src dtemp1))

        (else
         (emit-move.l src dtemp1)
         (touch-dreg-to-reg dtemp1 dst keep))))

; (touch-opnd-to-any-reg68 touch-opnd keep sn) generates the code to touch a
; PVM 'potentially future' operand and put the result in any M68000 register.

(define (touch-opnd-to-any-reg68 touch-opnd keep sn)
  (let ((loc touch-opnd))
    (if (reg? loc)

      (let ((reg (reg->reg68 loc)))
        (touch-reg68-to-reg68 reg reg keep)
        reg)

      (let ((reg (if (and keep (identical-opnd68? keep dtemp1)) atemp1 dtemp1))
            (opnd (opnd->opnd68 loc keep sn)))
        (make-top-of-frame-if-stk-opnd68 opnd sn)
        (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd sn) reg)
        (touch-reg68-to-reg68 reg reg keep)
        reg))))

; (copy-opnd-to-loc opnd loc sn) generates the code to copy the value
; from PVM operand 'opnd' to PVM location 'loc'.

(define (copy-opnd-to-loc opnd loc sn)
  (if (and (lbl? opnd) (eq? loc return-reg))

    (emit-lea (make-pcr (lbl-num opnd) 0) (reg->reg68 loc))

    (move-opnd68-to-loc
      (opnd->opnd68 opnd #f (sn-opnd loc sn))
      loc
      sn)))

; (touch-opnd-to-loc opnd loc sn) generates the code to copy the actual
; value from PVM operand 'opnd' to PVM location 'loc', touching 'opnd'
; if needed.

(define (touch-opnd-to-loc opnd loc sn)
  (if (pot-fut? opnd)
    (touch-opnd-to-loc* (strip-pot-fut opnd) loc sn)
    (copy-opnd-to-loc opnd loc sn)))

(define (touch-opnd-to-loc* opnd loc sn)
  (if (reg? opnd)

    (let ((reg68 (reg->reg68 opnd)))
      (if (reg? loc)

        (touch-reg68-to-reg68 reg68 (reg->reg68 loc) #f)

        (begin
          (touch-reg68-to-reg68 reg68 reg68 #f)
          (move-opnd68-to-loc reg68 loc sn))))

    (if (reg? loc)

      (let ((reg68 (reg->reg68 loc)))
        (move-opnd-to-loc68 opnd reg68 sn)
        (touch-reg68-to-reg68 reg68 reg68 #f))

      (let ((reg68 (touch-opnd-to-any-reg68 opnd #f sn)))
        (move-opnd68-to-loc reg68 loc sn)))))

; (touch-operands opnds touching-pattern sn) transforms all the 'touch
; operands' in 'opnds' into plain (non-touching) operands.  Only the
; operands specified in 'touching-pattern' will be touched.

(define (touch-operands opnds touching-pattern sn)

  (define (touch-operands* opnds i sn)
    (if (null? opnds)
      '()
      (let ((rest (touch-operands* (cdr opnds) (+ i 1) sn))
            (opnd (car opnds)))
        (if (pattern-member? i touching-pattern)
          (cons (touch-operand opnd (sn-opnds rest sn)) rest)
          (cons (remove-touching opnd (sn-opnds rest sn)) rest)))))

  (touch-operands* opnds 1 (sn-opnds opnds sn)))

(define (remove-touching opnd sn)
  (cond ((clo? opnd)
         (make-clo (touch-operand (clo-base opnd) sn)
                   (clo-index opnd)))
        (else
         (strip-pot-fut opnd))))

(define (touch-operand opnd sn)
  (if (pot-fut? opnd)
    (let* ((loc (strip-pot-fut opnd))
           (x (if (or (reg? loc) (stk? loc)) loc (make-stk (+ sn 1)))))
      (touch-opnd-to-loc* loc x (sn-opnd x sn))
      x)
    (remove-touching opnd sn)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-trap source frame save-live? not-save-reg num lbl)

  (define (adjust-slots l n)
    (cond ((= n 0) (append l '()))
          ((< n 0) (adjust-slots (cdr l) (+ n 1)))
          (else    (adjust-slots (cons empty-var l) (- n 1)))))

  (define (set-slot! slots i x)
    (let loop ((l slots) (n (- (length slots) i)))
      (if (> n 0)
        (loop (cdr l) (- n 1))
        (set-car! l x))))

  (let ((ret-slot (frame-first-empty-slot frame)))
    (let loop1 ((save1 '())
                (save2 #f)
                (regs (frame-regs frame))
                (i 0))
      (if (pair? regs)
        (let ((var (car regs)))
          (if (eq? var ret-var) ; make sure return address is on stack
            (let ((x (cons (reg->reg68 (make-reg i)) var)))
              (if (> ret-slot current-fs)
                (loop1 (cons x save1) save2 (cdr regs) (+ i 1))
                (loop1 save1 x (cdr regs) (+ i 1))))
            (if (and save-live?
                     (frame-live? var frame)
                     (not (eqv? not-save-reg (reg->reg68 (make-reg i)))))
              (loop1 (cons (cons (reg->reg68 (make-reg i)) var) save1)
                     save2
                     (cdr regs)
                     (+ i 1))
              (loop1 save1
                     save2
                     (cdr regs)
                     (+ i 1)))))
        (let ((order (sort-list save1 (lambda (x y) (< (car x) (car y))))))
          (let ((slots (append (map cdr order)
                               (adjust-slots (frame-slots frame)
                                             (- current-fs
                                                (frame-size frame)))))
                (reg-list (map car order))
                (nb-regs (length order)))

            (define (trap)
              (emit-trap2 num '())
              (gen-label-return* (new-lbl!)
                                 (add-first-class-label! source slots frame)
                                 slots
                                 0))

            (if save2
              (begin
                (emit-move.l
                  (car save2)
                  (make-disp* sp-reg (* pointer-size (- current-fs ret-slot))))
                (set-slot! slots ret-slot (cdr save2))))

            (if (> (length order) 2)
              (begin
                (emit-movem.l reg-list pdec-sp)
                (trap)
                (emit-movem.l pinc-sp reg-list))
              (let loop2 ((l (reverse reg-list)))
                (if (pair? l)
                  (let ((reg (car l)))
                    (emit-move.l reg pdec-sp)
                    (loop2 (cdr l))
                    (emit-move.l pinc-sp reg))
                  (trap))))

            (if save2
              (emit-move.l
                (make-disp* sp-reg (* pointer-size (- current-fs ret-slot)))
                (car save2)))

            (emit-label lbl)))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-LABEL-SIMP lbl sn)

  (if ofile-stats?
    (begin
      (stat-clear!)
      (stat-add! '(pvm-instr label simp) 1)))

  (set! pointers-allocated 0)

  (emit-label lbl))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-LABEL-PROC lbl nb-parms min rest? closed? sn)

  (if ofile-stats?
    (begin
      (stat-clear!)
      (stat-add! (list 'pvm-instr
                       'label
                       'proc
                       nb-parms
                       min
                       (if rest? 'rest 'not-rest)
                       (if closed? 'closed 'not-closed))
                 1)))

  (set! pointers-allocated 0)

  (let ((label-descr (add-first-class-label! instr-source '() exit-frame)))
    (if (= lbl entry-lbl-num)
      (emit-label lbl)
      (emit-label-subproc lbl entry-lbl-num label-descr)))

  (let* ((nb-parms* (if rest? (- nb-parms 1) nb-parms))
         (dispatch-lbls (make-vector (+ (- nb-parms min) 1)))
         (optional-lbls (make-vector (+ (- nb-parms min) 1))))

    (let loop ((i min))
      (if (<= i nb-parms)
        (let ((lbl (new-lbl!)))
          (vector-set! optional-lbls (- nb-parms i) lbl)
          (vector-set! dispatch-lbls (- nb-parms i)
            (if (or (>= i nb-parms) (<= nb-parms nb-arg-regs)) lbl (new-lbl!)))
          (loop (+ i 1)))))

    ; get closure pointer into the correct PVM register

    (if closed?
      (let ((closure-reg (reg-num->reg68 (+ nb-arg-regs 1))))
        (emit-move.l pinc-sp closure-reg)
        (emit-subq.l 6 closure-reg)
        (if (or (and (<= min 1) (<= 1 nb-parms*))
                (and (<= min 2) (<= 2 nb-parms*)))
          (emit-move.w dtemp1 dtemp1))))

    ; dispatch on number of arguments passed

    (if (and (<= min 2) (<= 2 nb-parms*))
      (emit-beq (vector-ref dispatch-lbls (- nb-parms 2))))

    (if (and (<= min 1) (<= 1 nb-parms*))
      (emit-bmi (vector-ref dispatch-lbls (- nb-parms 1))))

    (let loop ((i min))
      (if (<= i nb-parms*)
        (begin
          (if (not (or (= i 1) (= i 2)))
            (begin
              (emit-cmp.w (make-imm (encode-arg-count i)) arg-count-reg)
              (emit-beq (vector-ref dispatch-lbls (- nb-parms i)))))
          (loop (+ i 1)))))

    ; trap to a handler if wrong number of args (or rest param not null)

    (cond (rest?
           (emit-trap1
             (if closed? rest-params-closed-trap rest-params-trap)
             (list min nb-parms*))
           (if (not closed?) (emit-lbl-ptr lbl))
           (set! pointers-allocated 1)
           (gen-guarantee-fudge)
           (emit-bra (vector-ref optional-lbls 0)))
          ((= min nb-parms*)
           (emit-trap1
             (if closed? wrong-nb-arg1-closed-trap wrong-nb-arg1-trap)
             (list nb-parms*))
           (if (not closed?) (emit-lbl-ptr lbl)))
          (else
           (emit-trap1
             (if closed? wrong-nb-arg2-closed-trap wrong-nb-arg2-trap)
             (list min nb-parms*))
           (if (not closed?) (emit-lbl-ptr lbl))))

    ; for each valid argument count with at least one optional, move
    ; arguments to correct parameter location (only needed if some of
    ; the parameters end up on the stack)

    (if (> nb-parms nb-arg-regs)
      (let loop1 ((i (- nb-parms 1)))
        (if (>= i min)
          (let ((nb-stacked (if (<= i nb-arg-regs) 0 (- i nb-arg-regs))))
            (emit-label (vector-ref dispatch-lbls (- nb-parms i)))

            (let loop2 ((j 1))
              (if (and (<= j nb-arg-regs)
                       (<= j i)
                       (<= j (- (- nb-parms nb-arg-regs) nb-stacked)))
                (begin
                  (emit-move.l (reg-num->reg68 j) pdec-sp)
                  (loop2 (+ j 1)))
                (let loop3 ((k j))
                  (if (and (<= k nb-arg-regs) (<= k i))
                    (begin
                      (emit-move.l (reg-num->reg68 k)
                                   (reg-num->reg68 (+ (- k j) 1)))
                      (loop3 (+ k 1)))))))

            (if (> i min)
              (emit-bra (vector-ref optional-lbls (- nb-parms i))))
            (loop1 (- i 1))))))

    ; for each valid argument count with at least one optional, set
    ; that parameter to an unassigned value (or the empty list for the
    ; rest parameter)

    (let loop ((i min))
      (if (<= i nb-parms)
        (let ((val (if (= i nb-parms*) bits-NULL bits-UNASS)))
          (emit-label (vector-ref optional-lbls (- nb-parms i)))
          (cond ((> (- nb-parms i) nb-arg-regs)
                 (move-n-to-loc68 val pdec-sp))
                ((< i nb-parms)
                 (move-n-to-loc68
                   val
                   (reg-num->reg68 (parm->reg-num (+ i 1) nb-parms)))))
          (loop (+ i 1)))))))

(define (encode-arg-count n)
  (cond ((= n 1) -1)
        ((= n 2) 0)
        (else    (+ n 1))))

(define (parm->reg-num i nb-parms)
  (if (<= nb-parms nb-arg-regs) i (+ i (- nb-arg-regs nb-parms))))

(define (no-arg-check-entry-offset proc nb-args)
  (let ((x (proc-obj-call-pat proc)))
    (if (and (pair? x) (null? (cdr x))) ; proc accepts a fixed nb of args?
      (let ((arg-count (car x)))
        (if (= arg-count nb-args)
          (if (or (= arg-count 1) (= arg-count 2)) 10 14)
          0))
      0)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-LABEL-RETURN lbl method sn)

  (if ofile-stats?
    (begin
      (stat-clear!)
      (stat-add! (list 'pvm-instr 'label 'return method) 1)))

  (set! pointers-allocated 0)

  (let ((slots (frame-slots exit-frame)))

    (if (eq? method 'LAZY) ; return of a lazy future

      (case lazy-task-kind

        ((MESSAGE-PASSING-LTQ)
         (set! current-fs (+ current-fs 1))
         (let ((dummy-lbl (new-lbl!))
               (skip-lbl (new-lbl!)))
           (gen-label-return*
             dummy-lbl
             (add-first-class-label! instr-source slots exit-frame)
             slots
             1)
           (emit-bra skip-lbl)
           (gen-label-return-lazy*
             lbl
             (add-first-class-label! instr-source slots exit-frame)
             slots
             1)
           (emit-subq.l pointer-size ltq-tail-reg)
           (emit-label skip-lbl)))

        ((MESSAGE-PASSING-MIN)
         (let ((dummy-lbl (new-lbl!)))
           (gen-label-return*
             dummy-lbl
             (add-first-class-label! instr-source slots exit-frame)
             slots
             0)
           (emit-bra lbl)
           (gen-label-return-lazy*
             lbl
             (add-first-class-label! instr-source slots exit-frame)
             slots
             0)))

        ((SHARED-MEMORY)
         (set! current-fs (+ current-fs 1))
         (let ((conflict-lbl (new-lbl!))
               (dummy-lbl (new-lbl!))
               (skip-lbl (new-lbl!)))
           (emit-label conflict-lbl)
           (emit-trap1 steal-conflict-trap '())
           (gen-label-return*
             dummy-lbl
             (add-first-class-label! instr-source slots exit-frame)
             slots
             1)
           (emit-bra skip-lbl)
           (gen-label-return-lazy*
             lbl
             (add-first-class-label! instr-source slots exit-frame)
             slots
             1)
           (emit-clr.l (make-pdec ltq-tail-reg))
           (emit-cmp.l ltq-head-slot ltq-tail-reg)
           (emit-bcs   conflict-lbl)
           (emit-label skip-lbl)
;           (emit-move.w false-reg (make-pdec ltq-tail-reg))
;           (emit-move.w (make-pdec ltq-tail-reg) dtemp1)
;           (emit-beq conflict-lbl)
))

        (else
         (compiler-internal-error
           "gen-label-return, unknown 'lazy-task-kind':" lazy-task-kind)))

      (gen-label-return*
        lbl
        (add-first-class-label! instr-source slots exit-frame)
        slots
        0))))

(define (gen-label-return* lbl label-descr slots extra)
  (let ((i (pos-in-list ret-var slots)))
    (if i
      (let* ((fs (length slots))
             (link (- fs i)))
        (emit-label-return lbl entry-lbl-num (+ fs extra) link label-descr))
      (compiler-internal-error
        "gen-label-return*, no return address in frame"))))

(define (gen-label-return-lazy* lbl label-descr slots extra)
  (let ((i (pos-in-list ret-var slots)))
    (if i
      (let* ((fs (length slots))
             (link (- fs i)))
        (emit-label-return-lazy lbl entry-lbl-num (+ fs extra) link label-descr))
      (compiler-internal-error
        "gen-label-return-lazy*, no return address in frame"))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-LABEL-TASK lbl method sn)

  (define (build-delay ret-lbl)
    (gen-trap instr-source exit-frame #t #f delay-future-trap ret-lbl))

  (define (build-eager ret-lbl)
    (gen-trap instr-source exit-frame #t #f eager-future-trap ret-lbl))

  (define (build-lazy)
    (case lazy-task-kind

      ((MESSAGE-PASSING-LTQ SHARED-MEMORY)
       (if (= current-fs 0)

         (begin
           (emit-move.l (reg->reg68 return-reg) pdec-sp)
           (emit-move.l sp-reg (make-pinc ltq-tail-reg)))

         (begin
           (emit-move.l sp-reg atemp1)
           (emit-move.l (make-pinc atemp1) pdec-sp)
           (let loop ((i (- current-fs 1)))
             (if (> i 0)
               (begin
                 (emit-move.l (make-pinc atemp1) (make-disp atemp1 -8))
                 (loop (- i 1)))))
           (emit-move.l (reg->reg68 return-reg) (make-pdec atemp1))
           (emit-move.l atemp1 (make-pinc ltq-tail-reg)))))

      ((MESSAGE-PASSING-MIN)
       (emit-move.l false-reg ltq-tail-reg))

      (else
       (compiler-internal-error
         "gen-label-task, unknown 'lazy-task-kind':" lazy-task-kind))))

  (if ofile-stats?
    (begin
      (stat-clear!)
      (stat-add! (list 'pvm-instr 'label 'task method) 1)))

  (set! pointers-allocated 0)

  (emit-label lbl)

  (case method
    ((DELAY)
     (build-delay (new-lbl!)))
    ((EAGER)
     (build-eager (new-lbl!)))
    ((EAGER-INLINE)
     (let ((ret-lbl (new-lbl!)))
       (emit-cmp.l workq-head-slot null-reg)
       (emit-bne ret-lbl)
       (build-eager ret-lbl)))
    ((LAZY)
     (build-lazy))
    (else
     (compiler-internal-error
       "gen-LABEL-TASK, unknown task 'method':"
       method))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-APPLY prim opnds loc sn)

  (if ofile-stats?
    (begin
      (stat-add! (list 'pvm-instr
                       'apply
                       (string->canonical-symbol (proc-obj-name prim))
                       (map opnd-stat opnds)
                       (if loc (opnd-stat loc) #f))
                 1)
      (for-each fetch-stat-add! opnds)
      (if loc (store-stat-add! loc))))

  (let ((x (proc-obj-inlinable prim)))
    (if (not x)
      (compiler-internal-error "gen-APPLY, unknown 'prim':" prim)
      (if (or (needed? loc sn) (car x)) ; only inline primitive if result
        ((cdr x) opnds loc sn)))))      ; needed or prim. causes side effects?

(define (define-APPLY name side-effects? proc)
  (let ((prim (get-prim-info name)))
    (proc-obj-inlinable-set! prim (cons side-effects? proc))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-COPY opnd loc sn)

  (if ofile-stats?
    (begin
      (stat-add! (list 'pvm-instr 'copy (opnd-stat opnd) (opnd-stat loc)) 1)
      (fetch-stat-add! opnd)
      (store-stat-add! loc)))

  (if (needed? loc sn)
    (copy-opnd-to-loc opnd loc sn)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-MAKE_CLOSURES parms sn)

  (define (remove-touching-on-parms parms sn)
    (if (null? parms)
      '()
      (let* ((parm (car parms))
             (rest (remove-touching-on-parms (cdr parms) sn))
             (opnds (apply append (map (lambda (parm)
                                         (cons (closure-parms-loc parm)
                                               (closure-parms-opnds parm)))
                                       rest))))
        (cons (make-closure-parms
                (remove-touching (closure-parms-loc parm)
                                 (sn-opnds opnds sn))
                (closure-parms-lbl parm)
                (closure-parms-opnds parm))
              rest))))

  (define (size->bytes size) ; must round to a cache line
    (* (quotient (+ (* (+ size 2) pointer-size)
                    (- cache-line-length 1))
                 cache-line-length)
       cache-line-length))

  (define (parms->bytes parms)
    (if (null? parms)
      0
      (+ (size->bytes (length (closure-parms-opnds (car parms))))
         (parms->bytes (cdr parms)))))

  (if ofile-stats?
    (begin
      (for-each (lambda (x)
                  (stat-add! (list 'pvm-instr
                                   'make_closure
                                   (opnd-stat (closure-parms-loc x))
                                   (map opnd-stat (closure-parms-opnds x)))
                             1)
                  (store-stat-add! (closure-parms-loc x))
                  (fetch-stat-add! (make-lbl (closure-parms-lbl x)))
                  (for-each fetch-stat-add! (closure-parms-opnds x)))
                parms)))

  (let ((total-space-needed (parms->bytes parms))
        (lbl1 (new-lbl!)))

    (emit-move.l closure-ptr-slot atemp2)
    (move-n-to-loc68 total-space-needed dtemp1)
    (emit-sub.l dtemp1 atemp2)
    (emit-cmp.l closure-lim-slot atemp2)
    (emit-bcc   lbl1)
    (gen-trap instr-source entry-frame #f #f closure-alloc-trap lbl1)
    (emit-move.l atemp2 closure-ptr-slot)

    (let* ((parms* (remove-touching-on-parms parms sn))
           (opnds* (apply append (map closure-parms-opnds parms*)))
           (sn* (sn-opnds opnds* sn)))

      (let loop1 ((parms parms*))
        (let ((loc  (closure-parms-loc (car parms)))
              (size (length (closure-parms-opnds (car parms))))
              (rest (cdr parms)))
          (if (= size 1)
            (emit-addq.l type-PROCEDURE atemp2)
            (emit-move.w (make-imm (+ #x8000 (* (+ size 1) 4)))
                         (make-pinc atemp2)))
          (move-opnd68-to-loc atemp2 loc (sn-opnds (map closure-parms-loc rest) sn*))
          (if (null? rest)
            (add-n-to-loc68 (+ (- (size->bytes size) total-space-needed) 2) atemp2)
            (begin
              (add-n-to-loc68 (- (size->bytes size) type-PROCEDURE) atemp2)
              (loop1 rest)))))

      (let loop2 ((parms parms*))
        (let* ((opnds (closure-parms-opnds (car parms)))
               (lbl   (closure-parms-lbl (car parms)))
               (size  (length opnds))
               (rest  (cdr parms)))

          (emit-lea (make-pcr lbl 0) atemp1)
          (emit-move.l atemp1 (make-pinc atemp2))

          (let loop3 ((opnds opnds))
            (if (not (null? opnds))
              (let ((sn** (sn-opnds (apply append (map closure-parms-opnds rest)) sn)))
                (move-opnd-to-loc68 (car opnds)
                                    (make-pinc atemp2)
                                    (sn-opnds (cdr opnds) sn**))
                (loop3 (cdr opnds)))))

          (if (not (null? rest))
            (begin
              (add-n-to-loc68 (- (size->bytes size) (* (+ size 1) pointer-size)) atemp2)
              (loop2 rest))))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-COND test opnds true-lbl false-lbl intr-check? next-lbl)

  (if ofile-stats?
    (begin
      (stat-add! (list 'pvm-instr
                       'cond
                       (string->canonical-symbol (proc-obj-name test))
                       (map opnd-stat opnds)
                       (if intr-check? 'intr-check 'not-intr-check))
                 1)
      (for-each fetch-stat-add! opnds)
      (stat-dump!)))

  (let ((proc (proc-obj-test test)))
    (if proc
      (gen-COND* proc opnds true-lbl false-lbl intr-check? next-lbl)
      (compiler-internal-error "gen-COND, unknown 'test':" test))))

(define (gen-COND* proc opnds true-lbl false-lbl intr-check? next-lbl)
  (let ((fs (frame-size exit-frame)))

    (define (double-branch)
      (proc #t opnds false-lbl fs)
      (if ofile-stats?
        (emit-stat '((pvm-instr.cond.fall-through 1)
                     (pvm-instr.cond.double-branch 1))))
      (emit-bra true-lbl)
      (gen-deferred-code!))

    (gen-guarantee-fudge)

    (if intr-check?
      (gen-intr-check))

    (if next-lbl
      (cond ((= true-lbl next-lbl)
             (proc #t opnds false-lbl fs)
             (if ofile-stats?
               (emit-stat '((pvm-instr.cond.fall-through 1)))))
            ((= false-lbl next-lbl)
             (proc #f opnds true-lbl fs)
             (if ofile-stats?
               (emit-stat '((pvm-instr.cond.fall-through 1)))))
            (else
             (double-branch)))
      (double-branch))))

(define (define-COND name proc)

  (define-APPLY name #f (lambda (opnds loc sn)
    (let ((true-lbl (new-lbl!))
          (cont-lbl (new-lbl!))
          (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                   (reg->reg68 loc)
                   dtemp1)))

      (proc #f opnds true-lbl current-fs)
      (move-n-to-loc68 bits-FALSE reg68)
      (emit-bra cont-lbl)
      (emit-label true-lbl)
      (move-n-to-loc68 bits-TRUE reg68)
      (emit-label cont-lbl)

      (move-opnd68-to-loc reg68 loc sn))))

  (proc-obj-test-set! (get-prim-info name) proc))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (gen-JUMP opnd nb-args intr-check? next-lbl)
  (let ((fs (frame-size exit-frame)))

    (if ofile-stats?
      (begin
        (stat-add! (list 'pvm-instr
                         'jump
                         (opnd-stat opnd)
                         nb-args
                         (if intr-check? 'intr-check 'not-intr-check))
                   1)
        (jump-stat-add! opnd)
        (if (and (lbl? opnd) next-lbl (= next-lbl (lbl-num opnd)))
          (stat-add! '(pvm-instr.jump.fall-through) 1))
        (stat-dump!)))

    (gen-guarantee-fudge)
    (cond ((glo? opnd)
           (if intr-check? (gen-intr-check))
           (setup-jump fs nb-args)
           (emit-jmp-glob (make-glob (glo-name opnd)))
           (gen-deferred-code!))
          ((and (stk? opnd) (= (stk-num opnd) (+ fs 1)) (not nb-args))
           (if intr-check? (gen-intr-check))
           (setup-jump (+ fs 1) nb-args)
           (emit-rts)
           (gen-deferred-code!))
          ((lbl? opnd)
           (if (and intr-check?
                    (= fs current-fs)
                    (not nb-args)
                    (not (and next-lbl (= next-lbl (lbl-num opnd)))))
             (gen-intr-check-branch (lbl-num opnd))
             (begin
               (if intr-check? (gen-intr-check))
               (setup-jump fs nb-args)
               (if (not (and next-lbl (= next-lbl (lbl-num opnd))))
                 (emit-bra (lbl-num opnd))))))
          ((obj? opnd)
           (if intr-check? (gen-intr-check))
           (let ((val (obj-val opnd)))
             (if (proc-obj? val)
               (let ((num (add-object val))
                     (offset (no-arg-check-entry-offset val nb-args)))
                 (setup-jump fs (if (<= offset 0) nb-args #f))
                 (if num
                   (emit-jmp-proc num offset)
                   (emit-jmp-prim val offset))
                 (gen-deferred-code!))
               (gen-JUMP* (opnd->opnd68 opnd #f fs) fs nb-args))))
          (else
           (if intr-check? (gen-intr-check))
           (gen-JUMP* (opnd->opnd68 opnd #f fs) fs nb-args)))))

(define (gen-JUMP* opnd fs nb-args)
  (if nb-args
    (let ((lbl (new-lbl!)))
      (make-top-of-frame-if-stk-opnd68 opnd fs)
      (move-opnd68-to-loc68 (opnd68->true-opnd68 opnd fs) atemp1)
      (shrink-frame fs)
      (emit-move.l atemp1 dtemp1)
      (emit-addq.w (modulo (- type-PAIR type-PROCEDURE) 8) dtemp1)
      (emit-btst   dtemp1 pair-reg)
      (emit-beq    lbl)
      (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)
      (emit-trap3 non-proc-jump-trap)
      (emit-label lbl)
      (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)
      (emit-jmp (make-ind atemp1)))
    (let ((areg (move-opnd68-to-any-areg opnd #f fs)))
      (setup-jump fs nb-args)
      (emit-jmp (make-ind areg))))
  (gen-deferred-code!))

(define (setup-jump fs nb-args)
  (shrink-frame fs)
  (if nb-args
    (move-n-to-loc68 (encode-arg-count nb-args) arg-count-reg)))

(define (gen-intr-check)
  (let ((lbl (new-lbl!)))
    (emit-dbra  intr-timer-reg lbl)
    (if (not (eq? lazy-task-kind 'SHARED-MEMORY))
      (emit-move.l ltq-tail-reg ltq-tail-slot))
    (emit-moveq (- intr-latency 1) intr-timer-reg)
    (emit-cmp.l intr-flag-slot sp-reg)
    (emit-bcc   lbl)
    (gen-trap instr-source entry-frame #f #f intr-trap lbl)))

(define (gen-intr-check-branch lbl)
  (emit-dbra  intr-timer-reg lbl)
  (if (not (eq? lazy-task-kind 'SHARED-MEMORY))
    (emit-move.l ltq-tail-reg ltq-tail-slot))
  (emit-moveq (- intr-latency 1) intr-timer-reg)
  (emit-cmp.l intr-flag-slot sp-reg)
  (emit-bcc   lbl)
  (gen-trap instr-source entry-frame #f #f intr-trap (new-lbl!))
  (emit-bra   lbl))

;------------------------------------------------------------------------------

; Definitions used for APPLY and COND instructions:

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for inlining reference and assignment to slot of an object

(define (make-gen-slot-ref slot type)
  (lambda (opnds loc sn)
    (let* ((sn-loc (sn-opnd loc sn))
           (opnd (touch-operand (car opnds) sn-loc)))
      (move-opnd-to-loc68 opnd atemp1 sn-loc)
      (move-opnd68-to-loc (make-disp* atemp1 (- (* slot pointer-size) type))
                          loc
                          sn))))

(define (make-gen-slot-set! slot type)
  (lambda (opnds loc sn)
    (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
           (opnds (touch-operands opnds '(1) sn-loc)))
      (let* ((first-opnd (car opnds))
             (second-opnd (cadr opnds))
             (sn-second-opnd (sn-opnd second-opnd sn-loc)))
        (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)
        (move-opnd-to-loc68 second-opnd
                            (make-disp* atemp1 (- (* slot pointer-size) type))
                            sn-loc)
        (if loc
          (if (not (eq? first-opnd loc))
            (move-opnd68-to-loc atemp1 loc sn)))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for inlining CONS

(define (gen-cons weak? opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '() sn-loc)))
    (let ((first-opnd (car opnds))
          (second-opnd (cadr opnds)))

      (gen-guarantee-space 2)

      (if (or (contains-opnd? loc second-opnd) (might-touch-opnd? loc) weak?)

        (let ((sn-second-opnd (sn-opnd second-opnd sn-loc)))
          (move-opnd-to-loc68 first-opnd (make-pdec heap-reg) sn-second-opnd)
          (move-opnd68-to-loc68 heap-reg atemp2) ; *** atemp2 should be safe
          (move-opnd-to-loc68 second-opnd (make-pdec heap-reg) sn-loc)
          (if weak? (emit-subq.l (modulo (- type-PAIR type-WEAK-PAIR) 8) atemp2))
          (move-opnd68-to-loc atemp2 loc sn))

        (let* ((sn-second-opnd (sn-opnd second-opnd sn))
               (sn-loc (sn-opnd loc sn-second-opnd)))
          (move-opnd-to-loc68 first-opnd (make-pdec heap-reg) sn-loc)
          (move-opnd68-to-loc heap-reg loc sn-second-opnd)
          (move-opnd-to-loc68 second-opnd (make-pdec heap-reg) sn))))))

; for inlining of CAR/CDR chains

(define (make-gen-APPLY-C...R weak? pattern)
  (lambda (opnds loc sn)
    (let* ((sn-loc (sn-opnd loc sn))
           (opnd (touch-operand (car opnds) sn-loc)))

      (move-opnd-to-loc68 opnd atemp1 sn-loc)

      (let loop ((pattern pattern))
        (if (<= pattern 3)
          (if (= pattern 3)
            (if weak?
              (move-opnd68-to-loc (make-disp* atemp1 (- type-WEAK-PAIR)) loc sn)
              (move-opnd68-to-loc (make-pdec atemp1) loc sn)) ; cdr
            (if weak?
              (move-opnd68-to-loc (make-disp* atemp1 (- type-PAIR type-WEAK-PAIR)) loc sn)
              (move-opnd68-to-loc (make-ind atemp1) loc sn))) ; car
          (begin
            (if (odd? pattern)
              (if weak?
                (emit-move.l (make-disp* atemp1 (- type-WEAK-PAIR)) atemp1)
                (emit-move.l (make-pdec atemp1) atemp1)) ; cdr
              (if weak?
                (emit-move.l (make-disp* atemp1 (- type-PAIR type-WEAK-PAIR)) atemp1)
                (emit-move.l (make-ind atemp1) atemp1))) ; car
            (if touch-C...R?
              (touch-reg68-to-reg68 atemp1 atemp1 #f))
            (loop (quotient pattern 2))))))))

(define touch-C...R? #t)

; for inlining assignments to CAR/CDR

(define (gen-set-car! weak? opnds loc sn)
  (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
         (opnds (touch-operands opnds '(1) sn-loc)))
    (let* ((first-opnd (car opnds))
           (second-opnd (cadr opnds))
           (sn-second-opnd (sn-opnd second-opnd sn-loc)))
      (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)
      (if weak?
        (move-opnd-to-loc68 second-opnd (make-disp* atemp1 (- type-PAIR type-WEAK-PAIR)) sn-loc)
        (move-opnd-to-loc68 second-opnd (make-ind atemp1) sn-loc))
      (if (and loc (not (eq? first-opnd loc)))
        (move-opnd68-to-loc atemp1 loc sn)))))

(define (gen-set-cdr! weak? opnds loc sn)
  (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
         (opnds (touch-operands opnds '(1) sn-loc)))
    (let* ((first-opnd (car opnds))
           (second-opnd (cadr opnds))
           (sn-second-opnd (sn-opnd second-opnd sn-loc)))
      (move-opnd-to-loc68 first-opnd atemp1 sn-second-opnd)
      (if weak?
        (move-opnd-to-loc68 second-opnd (make-disp* atemp1 (- type-WEAK-PAIR)) sn-loc)
        (if (and loc (not (eq? first-opnd loc)))
          (move-opnd-to-loc68 second-opnd (make-disp atemp1 (- pointer-size)) sn-loc)
          (move-opnd-to-loc68 second-opnd (make-pdec atemp1) sn-loc)))
      (if (and loc (not (eq? first-opnd loc)))
        (move-opnd68-to-loc atemp1 loc sn)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for inlining of fixnum arithmetic

(define (commut-oper gen opnds loc sn self? accum-self accum-other)
  (if (null? opnds)
    (gen (reverse accum-self) (reverse accum-other) loc sn self?)
    (let ((opnd (car opnds))
          (rest (cdr opnds)))
      (cond ((and (not self?) (eq? opnd loc))
             (commut-oper gen rest loc sn #t accum-self accum-other))
            ((contains-opnd? loc opnd)
             (commut-oper gen rest loc sn self? (cons opnd accum-self) accum-other))
            (else
             (commut-oper gen rest loc sn self? accum-self (cons opnd accum-other)))))))

(define (gen-add-in-place opnds loc68 sn)
  (if (not (null? opnds))
    (let* ((first-opnd (car opnds))
           (other-opnds (cdr opnds))
           (sn-other-opnds (sn-opnds other-opnds sn))
           (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
           (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 loc68) (sn-opnd68 loc68 sn))))
      (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)
      (if (imm? opnd68)
        (add-n-to-loc68 (imm-val opnd68) (opnd68->true-opnd68 loc68 sn-other-opnds))
        (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
          (if (or (dreg? opnd68) (reg68? loc68))
            (emit-add.l opnd68* (opnd68->true-opnd68 loc68 sn-other-opnds))
            (begin
              (move-opnd68-to-loc68 opnd68* dtemp1)
              (emit-add.l dtemp1 (opnd68->true-opnd68 loc68 sn-other-opnds))))))
      (gen-add-in-place other-opnds loc68 sn))))

(define (gen-add self-opnds other-opnds loc sn self?)
  (let* ((opnds (append self-opnds other-opnds))
         (first-opnd (car opnds))
         (other-opnds (cdr opnds))
         (sn-other-opnds (sn-opnds other-opnds sn))
         (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
    (if (<= (length self-opnds) 1) ; loc must be reg or stk

      (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
        (if self?
          (gen-add-in-place opnds loc68 sn)
          (begin
            (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)
            (gen-add-in-place other-opnds loc68 sn))))

      (begin
        (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
        (gen-add-in-place other-opnds dtemp1 (sn-opnd loc sn))
        (if self?
          (let ((loc68 (loc->loc68 loc dtemp1 sn)))
            (make-top-of-frame-if-stk-opnd68 loc68 sn)
            (emit-add.l dtemp1 (opnd68->true-opnd68 loc68 sn)))
          (move-opnd68-to-loc dtemp1 loc sn))))))

(define (gen-sub-in-place opnds loc68 sn)
  (if (not (null? opnds))
    (let* ((first-opnd (car opnds))
           (other-opnds (cdr opnds))
           (sn-other-opnds (sn-opnds other-opnds sn))
           (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
           (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 loc68) (sn-opnd68 loc68 sn))))
      (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)
      (if (imm? opnd68)
        (add-n-to-loc68 (- (imm-val opnd68)) (opnd68->true-opnd68 loc68 sn-other-opnds))
        (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
          (if (or (dreg? opnd68) (reg68? loc68))
            (emit-sub.l opnd68* (opnd68->true-opnd68 loc68 sn-other-opnds))
            (begin
              (move-opnd68-to-loc68 opnd68* dtemp1)
              (emit-sub.l dtemp1 (opnd68->true-opnd68 loc68 sn-other-opnds))))))
      (gen-sub-in-place other-opnds loc68 sn))))

(define (gen-sub first-opnd other-opnds loc sn self-opnds?)
  (if (null? other-opnds) ; we are negating a location

    (if (and (or (reg? loc) (stk? loc))
             (not (eq? loc return-reg)))

      (begin
        (copy-opnd-to-loc first-opnd loc (sn-opnd loc sn))
        (let ((loc68 (loc->loc68 loc #f sn)))
          (make-top-of-frame-if-stk-opnd68 loc68 sn)
          (emit-neg.l (opnd68->true-opnd68 loc68 sn))))

      (begin
        (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn))
        (emit-neg.l dtemp1)
        (move-opnd68-to-loc dtemp1 loc sn)))

    (let* ((sn-other-opnds (sn-opnds other-opnds sn))
           (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))

      (if (and (not self-opnds?)
               (or (reg? loc) (stk? loc)))

        (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
          (if (not (eq? first-opnd loc))
            (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds))
          (gen-sub-in-place other-opnds loc68 sn))

        (begin
          (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
          (gen-sub-in-place other-opnds dtemp1 (sn-opnd loc sn))
          (move-opnd68-to-loc dtemp1 loc sn))))))

(define (gen-mul-in-place opnds reg68 sn)
  (if (not (null? opnds))
    (let* ((first-opnd (car opnds))
           (other-opnds (cdr opnds))
           (sn-other-opnds (sn-opnds other-opnds sn))
           (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 reg68) sn)))
      (make-top-of-frame-if-stk-opnd68 opnd68 sn-other-opnds)
      (if (imm? opnd68)
        (mul-n-to-reg68 (quotient (imm-val opnd68) 8) reg68)
        (begin
          (emit-asr.l (make-imm 3) reg68)
          (emit-muls.l (opnd68->true-opnd68 opnd68 sn-other-opnds) reg68)))
      (gen-mul-in-place other-opnds reg68 sn))))

(define (gen-mul self-opnds other-opnds loc sn self?)
  (let* ((opnds (append self-opnds other-opnds))
         (first-opnd (car opnds))
         (other-opnds (cdr opnds))
         (sn-other-opnds (sn-opnds other-opnds sn))
         (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
    (if (null? self-opnds) ; loc must be reg

      (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
        (if self?
          (gen-mul-in-place opnds loc68 sn)
          (begin
            (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)
            (gen-mul-in-place other-opnds loc68 sn))))

      (begin
        (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
        (gen-mul-in-place other-opnds dtemp1 (sn-opnd loc sn))
        (if self?
          (let ((loc68 (loc->loc68 loc dtemp1 sn)))
            (make-top-of-frame-if-stk-opnd68 loc68 sn)
            (emit-asr.l (make-imm 3) dtemp1)
            (emit-muls.l dtemp1 (opnd68->true-opnd68 loc68 sn)))
          (move-opnd68-to-loc dtemp1 loc sn))))))

(define (gen-div-in-place opnds reg68 sn)
  (if (not (null? opnds))
    (let* ((first-opnd (car opnds))
           (other-opnds (cdr opnds))
           (sn-other-opnds (sn-opnds other-opnds sn))
           (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
           (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 reg68) sn)))
      (make-top-of-frame-if-stk-opnd68 opnd68 sn-other-opnds)
      (if (imm? opnd68)
        (let ((n (quotient (imm-val opnd68) 8)))
          (div-n-to-reg68 n reg68)
          (if (> (abs n) 1)
            (emit-and.w (make-imm -8) reg68)))
        (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
          (emit-divsl.l opnd68* reg68 reg68)
          (emit-asl.l (make-imm 3) reg68)))
      (gen-div-in-place other-opnds reg68 sn))))

(define (gen-div first-opnd other-opnds loc sn self-opnds?)
  (if (null? other-opnds) ; we are inverting a location

    (begin
      (move-opnd-to-loc68 first-opnd pdec-sp (sn-opnd loc sn))
      (emit-moveq 8 dtemp1)
      (emit-divsl.l pinc-sp dtemp1 dtemp1)
      (emit-asl.l (make-imm 3) dtemp1)
      (emit-and.w (make-imm -8) dtemp1)
      (move-opnd68-to-loc dtemp1 loc sn))

    (let* ((sn-other-opnds (sn-opnds other-opnds sn))
           (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))

      (if (and (reg? loc)
               (not self-opnds?)
               (not (eq? loc return-reg)))

        (let ((reg68 (reg->reg68 loc)))
          (if (not (eq? first-opnd loc))
            (move-opnd-to-loc68 first-opnd reg68 sn-other-opnds))
          (gen-div-in-place other-opnds reg68 sn))

        (begin
          (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
          (gen-div-in-place other-opnds dtemp1 (sn-opnd loc sn))
          (move-opnd68-to-loc dtemp1 loc sn))))))

(define (gen-rem first-opnd second-opnd loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (sn-second-opnd (sn-opnd second-opnd sn-loc)))
    (move-opnd-to-loc68 first-opnd dtemp1 sn-second-opnd)
    (let ((opnd68 (opnd->opnd68 second-opnd #f sn-loc))
          (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                   (reg->reg68 loc)
                   false-reg)))
      (make-top-of-frame-if-stk-opnd68 opnd68 sn-loc)
      (let ((opnd68* (if (areg? opnd68)
                       (begin (emit-move.l opnd68 reg68) reg68)
                       (opnd68->true-opnd68 opnd68 sn-loc))))
        (emit-divsl.l opnd68* reg68 dtemp1))
      (move-opnd68-to-loc reg68 loc sn)
      (if (not (and (reg? loc) (not (eq? loc return-reg))))
        (emit-move.l (make-imm bits-FALSE) false-reg)))))

(define (gen-mod first-opnd second-opnd loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (sn-first-opnd (sn-opnd first-opnd sn-loc))
         (sn-second-opnd (sn-opnd second-opnd sn-first-opnd))
         (opnd68 (opnd->opnd68 second-opnd #f sn-second-opnd)))

    (define (general-case)
      (let ((lbl1 (new-lbl!))
            (lbl2 (new-lbl!))
            (lbl3 (new-lbl!))
            (opnd68** (opnd68->true-opnd68 opnd68 sn-second-opnd))
            (opnd68* (opnd68->true-opnd68
                       (opnd->opnd68 first-opnd #f sn-second-opnd)
                       sn-second-opnd)))
        (move-opnd68-to-loc68 opnd68* dtemp1)
        (move-opnd68-to-loc68 opnd68** false-reg)
        (emit-divsl.l false-reg false-reg dtemp1) ; false-reg <-- remainder
        (emit-move.l false-reg false-reg)
        (emit-beq lbl3) ; done if remainder = 0
        (move-opnd68-to-loc68 opnd68* dtemp1)
        (emit-bmi lbl1)
        (move-opnd68-to-loc68 opnd68** dtemp1)
        (emit-bpl lbl3)
        (emit-bra lbl2)
        (emit-label lbl1)
        (move-opnd68-to-loc68 opnd68** dtemp1)
        (emit-bmi lbl3)
        (emit-label lbl2) ; first and second operand have different signs
        (emit-add.l dtemp1 false-reg)
        (emit-label lbl3)
        (move-opnd68-to-loc false-reg loc sn)
        (emit-move.l (make-imm bits-FALSE) false-reg)))

    (make-top-of-frame-if-stk-opnd68 opnd68 sn-first-opnd)
    (if (imm? opnd68)
      (let ((n (quotient (imm-val opnd68) 8)))
        (if (> n 0)
          (let ((shift (power-of-2 n)))
            (if shift
              (let ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                             (reg->reg68 loc)
                             dtemp1)))
                (move-opnd-to-loc68 first-opnd reg68 sn-loc)
                (emit-and.l (make-imm (* (- n 1) 8)) reg68)
                (move-opnd68-to-loc reg68 loc sn))
              (general-case)))
          (general-case)))
      (general-case))))

(define (gen-op emit-op dst-ok?)

  (define (gen-op-in-place opnds loc68 sn)
    (if (not (null? opnds))
      (let* ((first-opnd (car opnds))
             (other-opnds (cdr opnds))
             (sn-other-opnds (sn-opnds other-opnds sn))
             (sn-first-opnd (sn-opnd first-opnd sn-other-opnds))
             (opnd68 (opnd->opnd68 first-opnd (temp-in-opnd68 loc68) (sn-opnd68 loc68 sn))))
        (make-top-of-frame-if-stk-opnds68 opnd68 loc68 sn-other-opnds)
        (if (imm? opnd68)
          (emit-op opnd68 (opnd68->true-opnd68 loc68 sn-other-opnds))
          (let ((opnd68* (opnd68->true-opnd68 opnd68 sn-other-opnds)))
            (if (or (dreg? opnd68) (dst-ok? loc68))
              (emit-op opnd68* (opnd68->true-opnd68 loc68 sn-other-opnds))
              (begin
                (move-opnd68-to-loc68 opnd68* dtemp1)
                (emit-op dtemp1 (opnd68->true-opnd68 loc68 sn-other-opnds))))))
        (gen-op-in-place other-opnds loc68 sn))))

  (lambda (self-opnds other-opnds loc sn self?)
    (let* ((opnds (append self-opnds other-opnds))
           (first-opnd (car opnds))
           (other-opnds (cdr opnds))
           (sn-other-opnds (sn-opnds other-opnds sn))
           (sn-first-opnd (sn-opnd first-opnd sn-other-opnds)))
      (if (<= (length self-opnds) 1) ; loc must be reg or stk

        (let ((loc68 (loc->loc68 loc #f sn-first-opnd)))
          (if self?
            (gen-op-in-place opnds loc68 sn)
            (begin
              (move-opnd-to-loc68 first-opnd loc68 sn-other-opnds)
              (gen-op-in-place other-opnds loc68 sn))))

        (begin
          (move-opnd-to-loc68 first-opnd dtemp1 (sn-opnd loc sn-other-opnds))
          (gen-op-in-place other-opnds dtemp1 (sn-opnd loc sn))
          (if self?
            (let ((loc68 (loc->loc68 loc dtemp1 sn)))
              (make-top-of-frame-if-stk-opnd68 loc68 sn)
              (emit-op dtemp1 (opnd68->true-opnd68 loc68 sn)))
            (move-opnd68-to-loc dtemp1 loc sn)))))))

(define gen-logior (gen-op emit-or.l dreg?))
(define gen-logxor (gen-op emit-eor.l (lambda (x) #f)))
(define gen-logand (gen-op emit-and.l dreg?))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; FLONUM operation

(define (flo-oper oper1 oper2 opnds loc sn)
  (gen-guarantee-space 4) ; make sure there is enough space for flonum
  (move-opnd-to-loc68 (car opnds) atemp1 (sn-opnds (cdr opnds) (sn-opnd loc sn)))
  (oper1 (make-disp* atemp1 (- pointer-size type-SUBTYPED)) ftemp1)
  (let loop ((opnds (cdr opnds)))
    (if (not (null? opnds))
      (let* ((opnd (car opnds))
             (other-opnds (cdr opnds))
             (sn-other-opnds (sn-opnds other-opnds sn)))
        (move-opnd-to-loc68 opnd atemp1 sn-other-opnds)
        (oper2 (make-disp* atemp1 (- pointer-size type-SUBTYPED)) ftemp1)
        (loop (cdr opnds)))))
  (add-n-to-loc68 (* -4 pointer-size) heap-reg) ; allocate flonum
  (emit-move.l (make-imm (+ (* 2 1024) (* subtype-FLONUM 8)))
               (make-ind heap-reg))
  (let ((reg68 (if (reg? loc) (reg->reg68 loc) atemp1)))
    (emit-move.l heap-reg reg68)
    (emit-addq.l type-SUBTYPED reg68))
  (emit-fmov.d ftemp1 (make-disp* heap-reg pointer-size))
  (if (not (reg? loc))
    (move-opnd68-to-loc atemp1 loc sn)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for checking for heap overflow after an allocation

(define (gen-guarantee-space n) ; n must be <= heap-allocation-fudge
  (set! pointers-allocated (+ pointers-allocated n))
  (if (> pointers-allocated heap-allocation-fudge)
    (begin
      (gen-guarantee-fudge)
      (set! pointers-allocated n))))

(define (gen-guarantee-fudge)
  (if (> pointers-allocated 0)
    (let ((lbl (new-lbl!)))
      (emit-cmp.l heap-lim-slot heap-reg)
      (emit-bcc   lbl)
      (gen-trap instr-source entry-frame #f #f heap-alloc1-trap lbl)
      (set! pointers-allocated 0))))

(define pointers-allocated '())

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for type and subtype manipulation:

(define (gen-type opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnd (car opnds))
         (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                  (reg->reg68 loc)
                  dtemp1)))

    (move-opnd-to-loc68 opnd reg68 sn-loc)
    (emit-and.l (make-imm 7) reg68)
    (emit-asl.l (make-imm 3) reg68)
    (move-opnd68-to-loc reg68 loc sn)))

(define (gen-type-cast opnds loc sn)
  (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
         (opnds (touch-operands opnds '(2) sn-loc)))
    (let ((first-opnd (car opnds))
          (second-opnd (cadr opnds)))
      (let* ((sn-loc (if (and loc (not (eq? first-opnd loc))) sn-loc sn))
             (o1 (opnd->opnd68 first-opnd #f (sn-opnd second-opnd sn-loc)))
             (o2 (opnd->opnd68 second-opnd (temp-in-opnd68 o1) sn-loc))
             (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                      (reg->reg68 loc)
                      dtemp1)))
        (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
        (move-opnd68-to-loc68 (opnd68->true-opnd68 o1 (sn-opnd68 o2 sn-loc)) reg68)
        (emit-and.w (make-imm -8) reg68)
        (if (imm? o2)
          (let ((n (quotient (imm-val o2) 8)))
            (if (> n 0)
              (emit-addq.w n reg68)))
          (begin
            (move-opnd68-to-loc68 (opnd68->true-opnd68 o2 sn-loc) atemp1)
            (emit-exg atemp1 reg68)
            (emit-asr.l (make-imm 3) reg68)
            (emit-add.l atemp1 reg68)))
        (move-opnd68-to-loc reg68 loc sn)))))

(define (gen-subtype opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnd (touch-operand (car opnds) sn-loc))
         (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                  (reg->reg68 loc)
                  dtemp1)))

    (move-opnd-to-loc68 opnd atemp1 sn-loc)
    (emit-moveq 0 reg68)
    (emit-move.b (make-ind atemp1) reg68)
    (move-opnd68-to-loc reg68 loc sn)))

(define (gen-subtype-set! opnds loc sn)
  (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (let ((first-opnd (car opnds))
          (second-opnd (cadr opnds)))
      (let* ((sn-loc (if (and loc (not (eq? first-opnd loc))) sn-loc sn))
             (o1 (opnd->opnd68 first-opnd #f (sn-opnd second-opnd sn-loc)))
             (o2 (opnd->opnd68 second-opnd (temp-in-opnd68 o1) sn-loc)))
        (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
        (move-opnd68-to-loc68 (opnd68->true-opnd68 o1 (sn-opnd68 o2 sn-loc)) atemp1)
        (if (imm? o2)
          (emit-move.b (make-imm (imm-val o2)) (make-ind atemp1))
          (begin
            (move-opnd68-to-loc68 (opnd68->true-opnd68 o2 sn-loc) dtemp1)
            (emit-move.b dtemp1 (make-ind atemp1))))
        (if (and loc (not (eq? first-opnd loc)))
          (move-opnd68-to-loc atemp1 loc sn))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for vector manipulation:

(define (vector-select kind vector string vector8 vector16)
  (case kind
    ((STRING)   string)
    ((VECTOR8)  vector8)
    ((VECTOR16) vector16)
    (else       vector)))

(define (gen-vector kind)
  (lambda (opnds loc sn)
    (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
           (opnds (touch-operands opnds '0 sn-loc)))
      (let* ((n (length opnds))
             (bytes (+ pointer-size (* (vector-select kind 4 1 1 2) n)))
             (pointers (* (quotient (+ bytes (- pointer-size 1)) pointer-size)
                          pointer-size))
             (adjust (modulo (- bytes) 8)))

        (gen-guarantee-space pointers)

        (if (not (= adjust 0)) (emit-subq.l adjust heap-reg))

        (let loop ((opnds (reverse opnds)))
          (if (pair? opnds)
            (let* ((o (car opnds))
                   (sn-o (sn-opnds (cdr opnds) sn-loc)))
              (if (eq? kind 'VECTOR)
                (move-opnd-to-loc68 o (make-pdec heap-reg) sn-o)
                (begin
                  (move-opnd-to-loc68 o dtemp1 sn-o)
                  (emit-asr.l (make-imm 3) dtemp1)
                  (if (eq? kind 'VECTOR16)
                    (emit-move.w dtemp1 (make-pdec heap-reg))
                    (emit-move.b dtemp1 (make-pdec heap-reg)))))
              (loop (cdr opnds)))))

        (emit-move.l (make-imm (+ (* 256 (- bytes pointer-size))
                                  (* 8 (if (eq? kind 'VECTOR)
                                         subtype-VECTOR
                                         subtype-STRING))))
                     (make-pdec heap-reg))

        (if loc
          (begin
            (emit-lea (make-disp* heap-reg type-SUBTYPED) atemp2)
            (move-opnd68-to-loc atemp2 loc sn)))))))

(define (gen-vector-length kind)
  (lambda (opnds loc sn)
    (let* ((sn-loc (sn-opnd loc sn))
           (opnd (touch-operand (car opnds) sn))
           (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                    (reg->reg68 loc)
                    dtemp1)))
  
      (move-opnd-to-loc68 opnd atemp1 sn-loc)
      (move-opnd68-to-loc68 (make-disp* atemp1 (- type-SUBTYPED)) reg68)
      (emit-lsr.l (make-imm (vector-select kind 7 5 5 6)) reg68)
      (if (not (eq? kind 'VECTOR))
        (emit-and.w (make-imm -8) reg68))
      (move-opnd68-to-loc reg68 loc sn))))

(define (gen-vector-ref kind)
  (lambda (opnds loc sn)
    (let* ((sn-loc (sn-opnd loc sn))
           (opnds (touch-operands opnds '0 sn-loc)))
      (let ((first-opnd (car opnds))
            (second-opnd (cadr opnds))
            (reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                     (reg->reg68 loc)
                     dtemp1)))

        (let* ((o2 (opnd->opnd68 second-opnd #f (sn-opnd first-opnd sn-loc)))
               (o1 (opnd->opnd68 first-opnd (temp-in-opnd68 o2) sn-loc)))
          (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
          (let* ((offset
                  (if (eq? kind 'SLOT) 0 (- pointer-size type-SUBTYPED)))
                 (loc68
                  (if (imm? o2)

                    (begin
                      (move-opnd68-to-loc68
                        (opnd68->true-opnd68 o1 sn-loc)
                        atemp1)
                      (make-disp* atemp1
                                  (+ (quotient (imm-val o2)
                                               (vector-select kind 2 8 8 4))
                                     offset)))

                      (begin
                        (move-opnd68-to-loc68
                          (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))
                          dtemp1)
                        (emit-lsr.l (make-imm (vector-select kind 1 3 3 2))
                                    dtemp1)
                        (move-opnd68-to-loc68
                          (opnd68->true-opnd68 o1 sn-loc)
                          atemp1)
                        (if (and (identical-opnd68? reg68 dtemp1)
                                 (not (memq kind '(VECTOR SLOT))))
                          (begin
                            (emit-move.l dtemp1 atemp2)
                            (make-inx atemp1 atemp2 offset))
                          (make-inx atemp1 dtemp1 offset))))))

            (if (not (memq kind '(VECTOR SLOT)))
              (emit-moveq 0 reg68))

            (case kind
              ((STRING VECTOR8) (emit-move.b loc68 reg68))
              ((VECTOR16)       (emit-move.w loc68 reg68))
              (else             (emit-move.l loc68 reg68)))

            (if (not (memq kind '(VECTOR SLOT)))
              (begin
                (emit-asl.l (make-imm 3) reg68)
                (if (eq? kind 'STRING)
                  (emit-addq.w type-SPECIAL reg68))))

          (move-opnd68-to-loc reg68 loc sn)))))))

(define (gen-vector-set! kind)
  (lambda (opnds loc sn)
    (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
           (opnds (touch-operands opnds '0 sn-loc)))
      (let ((first-opnd (car opnds))
            (second-opnd (cadr opnds))
            (third-opnd (caddr opnds)))
        (let* ((sn-loc (if (and loc (not (eq? first-opnd loc)))
                         (sn-opnd first-opnd loc)
                         sn))
               (sn-third-opnd (sn-opnd third-opnd sn-loc))
               (o2 (opnd->opnd68 second-opnd #f (sn-opnd first-opnd sn-third-opnd)))
               (o1 (opnd->opnd68 first-opnd (temp-in-opnd68 o2) sn-third-opnd)))
          (make-top-of-frame-if-stk-opnds68 o1 o2 sn-third-opnd)
          (let* ((offset
                  (if (eq? kind 'SLOT) 0 (- pointer-size type-SUBTYPED)))
                 (loc68
                  (if (imm? o2)

                    (begin
                      (move-opnd68-to-loc68
                        (opnd68->true-opnd68 o1 sn-third-opnd)
                        atemp1)
                      (make-disp* atemp1
                                  (+ (quotient (imm-val o2)
                                               (vector-select kind 2 8 8 4))
                                     offset)))

                      (begin
                        (move-opnd68-to-loc68
                          (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))
                          dtemp1)
                        (emit-lsr.l (make-imm (vector-select kind 1 3 3 2))
                                    dtemp1)
                        (move-opnd68-to-loc68
                          (opnd68->true-opnd68 o1 sn-loc)
                          atemp1)
                        (if (not (memq kind '(VECTOR SLOT)))
                          (begin
                            (emit-move.l dtemp1 atemp2)
                            (make-inx atemp1 atemp2 offset))
                          (make-inx atemp1 dtemp1 offset))))))

            (if (memq kind '(VECTOR SLOT))
              (move-opnd-to-loc68 third-opnd loc68 sn-loc)
              (begin
                (move-opnd-to-loc68 third-opnd dtemp1 sn-loc)
                (emit-asr.l (make-imm 3) dtemp1)
                (if (eq? kind 'VECTOR16)
                  (emit-move.w dtemp1 loc68)
                  (emit-move.b dtemp1 loc68))))

            (if (and loc (not (eq? first-opnd loc)))
              (copy-opnd-to-loc first-opnd loc sn))))))))

(define (gen-vector-shrink! kind)
  (lambda (opnds loc sn)
    (let* ((sn-loc (if loc (sn-opnd loc sn) sn))
           (opnds (touch-operands opnds '0 sn-loc)))
      (let ((first-opnd (car opnds))
            (second-opnd (cadr opnds)))
        (let* ((sn-loc (if (and loc (not (eq? first-opnd loc)))
                         (sn-opnd first-opnd loc)
                         sn))
               (o2 (opnd->opnd68 second-opnd #f (sn-opnd first-opnd sn-loc)))
               (o1 (opnd->opnd68 first-opnd (temp-in-opnd68 o2) sn-loc)))
          (make-top-of-frame-if-stk-opnds68 o1 o2 sn-loc)
          (move-opnd68-to-loc68
            (opnd68->true-opnd68 o2 (sn-opnd68 o1 sn-loc))
            dtemp1)
          (emit-asl.l (make-imm (vector-select kind 7 5 5 6)) dtemp1)
          (emit-move.l (opnd68->true-opnd68 o1 sn-loc) atemp1)
          (emit-move.b (make-ind atemp1) dtemp1)
          (emit-move.l dtemp1 (make-disp* atemp1 (- type-SUBTYPED)))
          (if (and loc (not (eq? first-opnd loc)))
            (move-opnd68-to-loc atemp1 loc sn)))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for CONDs that perform equality tests to constants

(define (gen-eq-test bits not? opnds lbl fs)
  (gen-compare* (opnd->opnd68 (touch-operand (car opnds) fs) #f fs)
                (make-imm bits)
                fs)
  (if not? (emit-bne lbl) (emit-beq lbl)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for CONDs that perform comparisons

(define (gen-compare opnd1 opnd2 fs)
  (let* ((o1 (opnd->opnd68 opnd1 #f (sn-opnd opnd2 fs)))
         (o2 (opnd->opnd68 opnd2 (temp-in-opnd68 o1) fs)))
    (gen-compare* o1 o2 fs)))

(define (gen-compare* o1 o2 fs)
  (make-top-of-frame-if-stk-opnds68 o1 o2 fs)
  (let ((order-1-2
          (cond ((imm? o1)
                 (cmp-n-to-opnd68 (imm-val o1)
                                  (opnd68->true-opnd68 o2 fs)))
                ((imm? o2)
                 (not (cmp-n-to-opnd68 (imm-val o2)
                                       (opnd68->true-opnd68 o1 fs))))
                ((reg68? o1)
                 (emit-cmp.l (opnd68->true-opnd68 o2 fs) o1)
                 #f)
                ((reg68? o2)
                 (emit-cmp.l (opnd68->true-opnd68 o1 fs) o2)
                 #t)
                (else
                 (emit-move.l (opnd68->true-opnd68 o1 (sn-opnd68 o2 fs)) dtemp1)
                 (emit-cmp.l (opnd68->true-opnd68 o2 fs) dtemp1)
                 #f))))
    (shrink-frame fs)
    order-1-2))

(define (gen-compares branch< branch>= branch> branch<= not? opnds lbl fs)
  (gen-compares* gen-compare branch< branch>= branch> branch<= not? opnds lbl fs))

(define (gen-compares* gen-comp branch< branch>= branch> branch<= not? opnds lbl fs)

  (define (gen-compare-sequence opnd1 opnd2 rest)
    (if (null? rest)

      (if (gen-comp opnd1 opnd2 fs)
        (if not? (branch<= lbl) (branch> lbl))
        (if not? (branch>= lbl) (branch< lbl)))
                   
      (let ((order-1-2 (gen-comp opnd1 opnd2 (sn-opnd opnd2 (sn-opnds rest fs)))))
        (if (= current-fs fs) ; no need to adjust size of frame further...

          (if not?
            (begin
              (if order-1-2 (branch<= lbl) (branch>= lbl))
              (gen-compare-sequence opnd2 (car rest) (cdr rest)))
            (let ((exit-lbl (new-lbl!)))
              (if order-1-2 (branch<= exit-lbl) (branch>= exit-lbl))
              (gen-compare-sequence opnd2 (car rest) (cdr rest))
              (emit-label exit-lbl)))

          (if not?
            (let ((next-lbl (new-lbl!)))
              (if order-1-2 (branch> next-lbl) (branch< next-lbl))
              (shrink-frame fs)
              (emit-bra lbl)
              (emit-label next-lbl)
              (gen-compare-sequence opnd2 (car rest) (cdr rest)))
            (let* ((next-lbl (new-lbl!))
                   (exit-lbl (new-lbl!)))
              (if order-1-2 (branch> next-lbl) (branch< next-lbl))
              (shrink-frame fs)
              (emit-bra exit-lbl)
              (emit-label next-lbl)
              (gen-compare-sequence opnd2 (car rest) (cdr rest))
              (emit-label exit-lbl)))))))

  (if (or (null? opnds) (null? (cdr opnds)))
    (begin
      (shrink-frame fs)
      (if (not not?) (emit-bra lbl)))
    (gen-compare-sequence (car opnds) (cadr opnds) (cddr opnds))))

(define (gen-compare-flo opnd1 opnd2 fs)
  (let* ((o1 (opnd->opnd68 opnd1 #f (sn-opnd opnd2 fs)))
         (o2 (opnd->opnd68 opnd2 (temp-in-opnd68 o1) fs)))
    (make-top-of-frame-if-stk-opnds68 o1 o2 fs)
    (emit-move.l (opnd68->true-opnd68 o1 (sn-opnd68 o2 fs)) atemp1)
    (emit-move.l (opnd68->true-opnd68 o2 fs) atemp2)
    (emit-fmov.d (make-disp* atemp2 (- pointer-size type-SUBTYPED)) ftemp1)
    (emit-fcmp.d (make-disp* atemp1 (- pointer-size type-SUBTYPED)) ftemp1)
    #t))

(define (gen-compares-flo branch< branch>= branch> branch<= not? opnds lbl fs)
  (gen-compares* gen-compare-flo branch< branch>= branch> branch<= not? opnds lbl fs))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for CONDs that just have to test the value's type tag

(define (gen-type-test tag not? opnds lbl fs)
  (let ((opnd (touch-operand (car opnds) fs)))
    (let ((o (opnd->opnd68 opnd #f fs)))

      (define (mask-test set-reg correction)
        (emit-btst
          (if (= correction 0)
            (if (dreg? o)
              o
              (begin
                (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)
                dtemp1))
            (begin
              (if (not (eq? o dtemp1))
                (emit-move.l (opnd68->true-opnd68 o fs) dtemp1))
              (emit-addq.w correction dtemp1)
              dtemp1))
          set-reg))

      (make-top-of-frame-if-stk-opnd68 o fs)

      (cond ((= tag 0)
             (if (eq? o dtemp1)
               (emit-and.w (make-imm 7) dtemp1)
               (begin
                 (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)
                 (emit-and.w (make-imm 7) dtemp1))))
            ((= tag type-PLACEHOLDER)
             (mask-test placeholder-reg 0))
            (else
             (mask-test pair-reg (modulo (- type-PAIR tag) 8))))

      (shrink-frame fs)
      (if not?
        (emit-bne lbl)
        (emit-beq lbl)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for CONDs that have to test the type tag of a hunk

(define (gen-subtype-test type not? opnds lbl fs)
  (let ((opnd (touch-operand (car opnds) fs)))
    (let ((o (opnd->opnd68 opnd #f fs))
          (cont-lbl (new-lbl!)))
      (make-top-of-frame-if-stk-opnd68 o fs)
      (if (not (eq? o dtemp1))
        (emit-move.l (opnd68->true-opnd68 o fs) dtemp1))
      (emit-move.l dtemp1 atemp1)
      (emit-addq.w (modulo (- type-PAIR type-SUBTYPED) 8) dtemp1)
      (emit-btst dtemp1 pair-reg)
      (shrink-frame fs)
      (if not?
        (emit-bne lbl)
        (emit-bne cont-lbl))
      (emit-cmp.b (make-imm (* type 8)) (make-ind atemp1))
      (if not?
        (emit-bne lbl)
        (emit-beq lbl))
      (emit-label cont-lbl))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; for CONDs that have to test for parity (even/odd)

(define (gen-even-test not? opnds lbl fs)
  (move-opnd-to-loc68 (touch-operand (car opnds) fs) dtemp1 fs)
  (emit-and.w (make-imm 8) dtemp1)
  (shrink-frame fs)
  (if not? (emit-bne lbl) (emit-beq lbl)))

;------------------------------------------------------------------------------

; Operation database:

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; some common specializations:

(define (def-spec name specializer-maker)
  (let ((proc-name (string->canonical-symbol name)))
    (let ((proc (prim-info proc-name)))
      (if proc
        (proc-obj-specialize-set! proc (specializer-maker proc proc-name))
        (compiler-internal-error
          "def-spec, unknown primitive:" name)))))

(define (safe name)
  (lambda (proc proc-name)
    (let ((spec (get-prim-info name)))
      (lambda (decls) spec))))

(define (unsafe name)
  (lambda (proc proc-name)
    (let ((spec (get-prim-info name)))
      (lambda (decls) (if (not (safe? decls)) spec proc)))))

(define (safe-arith fix-name flo-name)
  (arith #t fix-name flo-name))

(define (unsafe-arith fix-name flo-name)
  (arith #f fix-name flo-name))

(define (arith fix-safe? fix-name flo-name)
  (lambda (proc proc-name)
    (let ((fix-spec (if fix-name (get-prim-info fix-name) proc))
          (flo-spec (if flo-name (get-prim-info flo-name) proc)))
      (lambda (decls)
        (let ((arith (arith-implementation proc-name decls)))
          (cond ((eq? arith FIXNUM-sym)
                 (if (or fix-safe? (not (safe? decls))) fix-spec proc))
                ((eq? arith FLONUM-sym)
                 (if (not (safe? decls)) flo-spec proc))
                (else
                 proc)))))))

;------------------------------------------------------------------------------

; Operations:

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##TYPE" #f (lambda (opnds loc sn)
  (gen-type opnds loc sn)))

(define-APPLY "##TYPE-CAST" #f (lambda (opnds loc sn)
  (gen-type-cast opnds loc sn)))

(define-APPLY "##SUBTYPE" #f (lambda (opnds loc sn)
  (gen-subtype opnds loc sn)))

(define-APPLY "##SUBTYPE-SET!" #t (lambda (opnds loc sn)
  (gen-subtype-set! opnds loc sn)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-COND "##NOT" (lambda (not? opnds lbl fs)
  (gen-eq-test bits-FALSE not? opnds lbl fs)))

(define-COND "##NULL?" (lambda (not? opnds lbl fs)
  (gen-eq-test bits-NULL not? opnds lbl fs)))

(define-COND "##UNASSIGNED?" (lambda (not? opnds lbl fs)
  (gen-eq-test bits-UNASS not? opnds lbl fs)))

(define-COND "##UNBOUND?" (lambda (not? opnds lbl fs)
  (gen-eq-test bits-UNBOUND not? opnds lbl fs)))

(define-COND "##EQ?" (lambda (not? opnds lbl fs)
  (gen-compares emit-beq emit-bne emit-beq emit-bne
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##FIXNUM?" (lambda (not? opnds lbl fs)
  (gen-type-test type-FIXNUM not? opnds lbl fs)))

(define-COND "##SPECIAL?" (lambda (not? opnds lbl fs)
  (gen-type-test type-SPECIAL not? opnds lbl fs)))

(define-COND "##PAIR?" (lambda (not? opnds lbl fs)
  (gen-type-test type-PAIR not? opnds lbl fs)))

(define-COND "##WEAK-PAIR?" (lambda (not? opnds lbl fs)
  (gen-type-test type-WEAK-PAIR not? opnds lbl fs)))

(define-COND "##SUBTYPED?" (lambda (not? opnds lbl fs)
  (gen-type-test type-SUBTYPED not? opnds lbl fs)))

(define-COND "##PROCEDURE?" (lambda (not? opnds lbl fs)
  (gen-type-test type-PROCEDURE not? opnds lbl fs)))

(define-COND "##PLACEHOLDER?" (lambda (not? opnds lbl fs)
  (gen-type-test type-PLACEHOLDER not? opnds lbl fs)))

(define-COND "##VECTOR?" (lambda (not? opnds lbl fs)
  (gen-subtype-test subtype-VECTOR not? opnds lbl fs)))

(define-COND "##SYMBOL?" (lambda (not? opnds lbl fs)
  (gen-subtype-test subtype-SYMBOL not? opnds lbl fs)))

(define-COND "##RATNUM?" (lambda (not? opnds lbl fs)
  (gen-subtype-test subtype-RATNUM not? opnds lbl fs)))

(define-COND "##CPXNUM?" (lambda (not? opnds lbl fs)
  (gen-subtype-test subtype-CPXNUM not? opnds lbl fs)))

(define-COND "##STRING?" (lambda (not? opnds lbl fs)
  (gen-subtype-test subtype-STRING not? opnds lbl fs)))

(define-COND "##BIGNUM?" (lambda (not? opnds lbl fs)
  (gen-subtype-test subtype-BIGNUM not? opnds lbl fs)))

(define-COND "##FLONUM?" (lambda (not? opnds lbl fs)
  (gen-subtype-test subtype-FLONUM not? opnds lbl fs)))

(define-COND "##CHAR?" (lambda (not? opnds lbl fs)
  (let ((opnd (touch-operand (car opnds) fs)))
    (let ((o (opnd->opnd68 opnd #f fs))
          (cont-lbl (new-lbl!)))
      (make-top-of-frame-if-stk-opnd68 o fs)
      (emit-move.l (opnd68->true-opnd68 o fs) dtemp1)
      (if not?
        (emit-bmi lbl)
        (emit-bmi cont-lbl))
      (emit-addq.w (modulo (- type-PAIR type-SPECIAL) 8) dtemp1)
      (emit-btst dtemp1 pair-reg)
      (shrink-frame fs)
      (if not?
        (emit-bne lbl)
        (emit-beq lbl))
      (emit-label cont-lbl)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##FIXNUM.+" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (cond ((null? opnds)
           (copy-opnd-to-loc (make-obj '0) loc sn))
          ((null? (cdr opnds))
           (copy-opnd-to-loc (car opnds) loc sn))
          ((or (reg? loc) (stk? loc))
           (commut-oper gen-add opnds loc sn #f '() '()))
          (else
           (gen-add opnds '() loc sn #f))))))

(define-APPLY "##FIXNUM.-" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (gen-sub (car opnds) (cdr opnds) loc sn (any-contains-opnd? loc (cdr opnds))))))

(define-APPLY "##FIXNUM.*" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (cond ((null? opnds)
           (copy-opnd-to-loc (make-obj '1) loc sn))
          ((null? (cdr opnds))
           (copy-opnd-to-loc (car opnds) loc sn))
          ((and (reg? loc) (not (eq? loc return-reg)))
           (commut-oper gen-mul opnds loc sn #f '() '()))
          (else
           (gen-mul opnds '() loc sn #f))))))

(define-APPLY "##FIXNUM.QUOTIENT" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (gen-div (car opnds) (cdr opnds) loc sn (any-contains-opnd? loc (cdr opnds))))))

(define-APPLY "##FIXNUM.REMAINDER" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (gen-rem (car opnds) (cadr opnds) loc sn))))

(define-APPLY "##FIXNUM.MODULO" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (gen-mod (car opnds) (cadr opnds) loc sn))))

(define-APPLY "##FIXNUM.LOGIOR" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (cond ((null? opnds)
           (copy-opnd-to-loc (make-obj '0) loc sn))
          ((null? (cdr opnds))
           (copy-opnd-to-loc (car opnds) loc sn))
          ((or (reg? loc) (stk? loc))
           (commut-oper gen-logior opnds loc sn #f '() '()))
          (else
           (gen-logior opnds '() loc sn #f))))))

(define-APPLY "##FIXNUM.LOGXOR" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (cond ((null? opnds)
           (copy-opnd-to-loc (make-obj '0) loc sn))
          ((null? (cdr opnds))
           (copy-opnd-to-loc (car opnds) loc sn))
          ((or (reg? loc) (stk? loc))
           (commut-oper gen-logxor opnds loc sn #f '() '()))
          (else
           (gen-logxor opnds '() loc sn #f))))))

(define-APPLY "##FIXNUM.LOGAND" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (cond ((null? opnds)
           (copy-opnd-to-loc (make-obj '-1) loc sn))
          ((null? (cdr opnds))
           (copy-opnd-to-loc (car opnds) loc sn))
          ((or (reg? loc) (stk? loc))
           (commut-oper gen-logand opnds loc sn #f '() '()))
          (else
           (gen-logand opnds '() loc sn #f))))))

(define-APPLY "##FIXNUM.LOGNOT" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnd (car (touch-operands opnds '0 sn-loc))))

    (if (and (or (reg? loc) (stk? loc))
             (not (eq? loc return-reg)))

      (begin
        (copy-opnd-to-loc opnd loc sn-loc)
        (let ((loc68 (loc->loc68 loc #f sn)))
          (make-top-of-frame-if-stk-opnd68 loc68 sn)
          (emit-not.l (opnd68->true-opnd68 loc68 sn))
          (emit-and.w (make-imm -8) (opnd68->true-opnd68 loc68 sn))))

      (begin
        (move-opnd-to-loc68 opnd dtemp1 (sn-opnd loc sn))
        (emit-not.l dtemp1)
        (emit-and.w (make-imm -8) dtemp1)
        (move-opnd68-to-loc dtemp1 loc sn))))))

(define-APPLY "##FIXNUM.ASH" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (let* ((opnd1 (car opnds))
           (opnd2 (cadr opnds))
           (sn-opnd1 (sn-opnd opnd1 sn-loc))
           (o2 (opnd->opnd68 opnd2 #f sn-opnd1)))
      (make-top-of-frame-if-stk-opnd68 o2 sn-opnd1)
      (if (imm? o2)

        (let* ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                        (reg->reg68 loc)
                        dtemp1))
               (n (quotient (imm-val o2) 8))
               (emit-shft (if (> n 0) emit-lsl.l emit-asr.l)))
          (move-opnd-to-loc68 opnd1 reg68 sn-loc)
          (let loop ((i (min (abs n) 29)))
            (if (> i 0)
              (begin (emit-shft (make-imm (min i 8)) reg68) (loop (- i 8)))))
          (if (< n 0)
            (emit-and.w (make-imm -8) reg68))
          (move-opnd68-to-loc reg68 loc sn))

        (let* ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                        (reg->reg68 loc)
                        dtemp1))
               (reg68* (if (and (reg? loc) (not (eq? loc return-reg)))
                         dtemp1
                         false-reg))
               (lbl1 (new-lbl!))
               (lbl2 (new-lbl!)))
          (emit-move.l (opnd68->true-opnd68 o2 sn-opnd1) reg68*)
          (move-opnd-to-loc68 opnd1 reg68 sn-loc)
          (emit-asr.l (make-imm 3) reg68*)
          (emit-bmi lbl1)
          (emit-lsl.l reg68* reg68)
          (emit-bra lbl2)
          (emit-label lbl1)
          (emit-neg.l reg68*)
          (emit-asr.l reg68* reg68)
          (emit-and.w (make-imm -8) reg68)
          (emit-label lbl2)
          (move-opnd68-to-loc reg68 loc sn)
          (if (not (and (reg? loc) (not (eq? loc return-reg))))
            (emit-move.l (make-imm bits-FALSE) false-reg))))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-COND "##FIXNUM.ZERO?" (lambda (not? opnds lbl fs)
  (gen-eq-test 0 not? opnds lbl fs)))

(define-COND "##FIXNUM.POSITIVE?" (lambda (not? opnds lbl fs)
  (gen-compares emit-bgt emit-ble emit-blt emit-bge
                not?
                (list (touch-operand (car opnds) fs) (make-obj '0))
                lbl
                fs)))

(define-COND "##FIXNUM.NEGATIVE?" (lambda (not? opnds lbl fs)
  (gen-compares emit-blt emit-bge emit-bgt emit-ble
                not?
                (list (touch-operand (car opnds) fs) (make-obj '0))
                lbl
                fs)))

(define-COND "##FIXNUM.ODD?" (lambda (not? opnds lbl fs)
  (gen-even-test (not not?) opnds lbl fs)))

(define-COND "##FIXNUM.EVEN?" (lambda (not? opnds lbl fs)
  (gen-even-test not? opnds lbl fs)))

(define-COND "##FIXNUM.=" (lambda (not? opnds lbl fs)
  (gen-compares emit-beq emit-bne emit-beq emit-bne
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##FIXNUM.<" (lambda (not? opnds lbl fs)
  (gen-compares emit-blt emit-bge emit-bgt emit-ble
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##FIXNUM.>" (lambda (not? opnds lbl fs)
  (gen-compares emit-bgt emit-ble emit-blt emit-bge
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##FIXNUM.<=" (lambda (not? opnds lbl fs)
  (gen-compares emit-ble emit-bgt emit-bge emit-blt
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##FIXNUM.>=" (lambda (not? opnds lbl fs)
  (gen-compares emit-bge emit-blt emit-ble emit-bgt
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##FLONUM.->FIXNUM" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (move-opnd-to-loc68 (car opnds) atemp1 sn-loc)
    (let ((reg68 (if (and (reg? loc) (not (eq? loc return-reg)))
                   (reg->reg68 loc)
                   dtemp1)))
      (emit-fmov.d (make-disp* atemp1 (- pointer-size type-SUBTYPED)) ftemp1)
      (emit-fmov.l ftemp1 reg68)
      (emit-asl.l (make-imm 3) reg68)
      (if (not (and (reg? loc) (not (eq? loc return-reg))))
        (move-opnd68-to-loc reg68 loc sn))))))

(define-APPLY "##FLONUM.<-FIXNUM" #f (lambda (opnds loc sn)
  (gen-guarantee-space 4) ; make sure there is enough space for flonum
  (move-opnd-to-loc68 (car opnds) dtemp1 (sn-opnds (cdr opnds) (sn-opnd loc sn)))
  (emit-asr.l (make-imm 3) dtemp1)
  (emit-fmov.l dtemp1 ftemp1)
  (add-n-to-loc68 (* -4 pointer-size) heap-reg) ; allocate flonum
  (emit-move.l (make-imm (+ (* 2 1024) (* subtype-FLONUM 8)))
               (make-ind heap-reg))
  (let ((reg68 (if (reg? loc) (reg->reg68 loc) atemp1)))
    (emit-move.l heap-reg reg68)
    (emit-addq.l type-SUBTYPED reg68))
  (emit-fmov.d ftemp1 (make-disp* heap-reg pointer-size))
  (if (not (reg? loc))
    (move-opnd68-to-loc atemp1 loc sn))))

(define-APPLY "##FLONUM.+" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (cond ((null? opnds)
           (copy-opnd-to-loc (make-obj inexact-0) loc sn))
          ((null? (cdr opnds))
           (copy-opnd-to-loc (car opnds) loc sn))
          (else
           (flo-oper emit-fmov.d emit-fadd.d opnds loc sn))))))

(define-APPLY "##FLONUM.-" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (if (null? (cdr opnds))
      (flo-oper emit-fneg.d #f opnds loc sn)
      (flo-oper emit-fmov.d emit-fsub.d opnds loc sn)))))

(define-APPLY "##FLONUM.*" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (cond ((null? opnds)
           (copy-opnd-to-loc (make-obj inexact-+1) loc sn))
          ((null? (cdr opnds))
           (copy-opnd-to-loc (car opnds) loc sn))
          (else
           (flo-oper emit-fmov.d emit-fmul.d opnds loc sn))))))

(define-APPLY "##FLONUM./" #f (lambda (opnds loc sn)

  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (if (null? (cdr opnds))
      (flo-oper emit-fmov.d emit-fdiv.d (cons (make-obj inexact-+1) opnds) loc sn)
      (flo-oper emit-fmov.d emit-fdiv.d opnds loc sn)))))

(define-APPLY "##FLONUM.ABS" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fabs.d #f opnds loc sn))))

(define-APPLY "##FLONUM.TRUNCATE" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fintrz.d #f opnds loc sn))))

(define-APPLY "##FLONUM.ROUND" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fint.d #f opnds loc sn))))

(define-APPLY "##FLONUM.EXP" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fetox.d #f opnds loc sn))))

(define-APPLY "##FLONUM.LOG" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-flogn.d #f opnds loc sn))))

(define-APPLY "##FLONUM.SIN" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fsin.d #f opnds loc sn))))

(define-APPLY "##FLONUM.COS" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fcos.d #f opnds loc sn))))

(define-APPLY "##FLONUM.TAN" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-ftan.d #f opnds loc sn))))

(define-APPLY "##FLONUM.ASIN" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fasin.d #f opnds loc sn))))

(define-APPLY "##FLONUM.ACOS" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-facos.d #f opnds loc sn))))

(define-APPLY "##FLONUM.ATAN" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fatan.d #f opnds loc sn))))

(define-APPLY "##FLONUM.SQRT" #f (lambda (opnds loc sn)
  (let* ((sn-loc (sn-opnd loc sn))
         (opnds (touch-operands opnds '0 sn-loc)))
    (flo-oper emit-fsqrt.d #f opnds loc sn))))

(define-COND "##FLONUM.ZERO?" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fbeq emit-fbne emit-fbeq emit-fbne
                    not?
                    (list (touch-operand (car opnds) fs) (make-obj inexact-0))
                    lbl
                    fs)))

(define-COND "##FLONUM.NEGATIVE?" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fblt emit-fbge emit-fbgt emit-fble
                    not?
                    (list (touch-operand (car opnds) fs) (make-obj inexact-0))
                    lbl
                    fs)))

(define-COND "##FLONUM.POSITIVE?" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fbgt emit-fble emit-fblt emit-fbge
                    not?
                    (list (touch-operand (car opnds) fs) (make-obj inexact-0))
                    lbl
                    fs)))

(define-COND "##FLONUM.=" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fbeq emit-fbne emit-fbeq emit-fbne
                    not?
                    (touch-operands opnds '0 fs)
                    lbl
                    fs)))

(define-COND "##FLONUM.<" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fblt emit-fbge emit-fbgt emit-fble
                    not?
                    (touch-operands opnds '0 fs)
                    lbl
                    fs)))

(define-COND "##FLONUM.>" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fbgt emit-fble emit-fblt emit-fbge
                    not?
                    (touch-operands opnds '0 fs)
                    lbl
                    fs)))

(define-COND "##FLONUM.<=" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fble emit-fbgt emit-fbge emit-fblt
                    not?
                    (touch-operands opnds '0 fs)
                    lbl
                    fs)))

(define-COND "##FLONUM.>=" (lambda (not? opnds lbl fs)
  (gen-compares-flo emit-fbge emit-fblt emit-fble emit-fbgt
                    not?
                    (touch-operands opnds '0 fs)
                    lbl
                    fs)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-COND "##CHAR=?" (lambda (not? opnds lbl fs)
  (gen-compares emit-beq emit-bne emit-beq emit-bne
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##CHAR<?" (lambda (not? opnds lbl fs)
  (gen-compares emit-blt emit-bge emit-bgt emit-ble
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##CHAR>?" (lambda (not? opnds lbl fs)
  (gen-compares emit-bgt emit-ble emit-blt emit-bge
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##CHAR<=?" (lambda (not? opnds lbl fs)
  (gen-compares emit-ble emit-bgt emit-bge emit-blt
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

(define-COND "##CHAR>=?" (lambda (not? opnds lbl fs)
  (gen-compares emit-bge emit-blt emit-ble emit-bgt
                not?
                (touch-operands opnds '0 fs)
                lbl
                fs)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##CONS" #f (lambda (opnds loc sn)
  (gen-cons #f opnds loc sn)))

(define-APPLY "##SET-CAR!" #t (lambda (opnds loc sn)
  (gen-set-car! #f opnds loc sn)))

(define-APPLY "##SET-CDR!" #t (lambda (opnds loc sn)
  (gen-set-cdr! #f opnds loc sn)))

(define-APPLY "##CAR"    #f (make-gen-APPLY-C...R #f 2))
(define-APPLY "##CDR"    #f (make-gen-APPLY-C...R #f 3))
(define-APPLY "##CAAR"   #f (make-gen-APPLY-C...R #f 4))
(define-APPLY "##CADR"   #f (make-gen-APPLY-C...R #f 5))
(define-APPLY "##CDAR"   #f (make-gen-APPLY-C...R #f 6))
(define-APPLY "##CDDR"   #f (make-gen-APPLY-C...R #f 7))
(define-APPLY "##CAAAR"  #f (make-gen-APPLY-C...R #f 8))
(define-APPLY "##CAADR"  #f (make-gen-APPLY-C...R #f 9))
(define-APPLY "##CADAR"  #f (make-gen-APPLY-C...R #f 10))
(define-APPLY "##CADDR"  #f (make-gen-APPLY-C...R #f 11))
(define-APPLY "##CDAAR"  #f (make-gen-APPLY-C...R #f 12))
(define-APPLY "##CDADR"  #f (make-gen-APPLY-C...R #f 13))
(define-APPLY "##CDDAR"  #f (make-gen-APPLY-C...R #f 14))
(define-APPLY "##CDDDR"  #f (make-gen-APPLY-C...R #f 15))
(define-APPLY "##CAAAAR" #f (make-gen-APPLY-C...R #f 16))
(define-APPLY "##CAAADR" #f (make-gen-APPLY-C...R #f 17))
(define-APPLY "##CAADAR" #f (make-gen-APPLY-C...R #f 18))
(define-APPLY "##CAADDR" #f (make-gen-APPLY-C...R #f 19))
(define-APPLY "##CADAAR" #f (make-gen-APPLY-C...R #f 20))
(define-APPLY "##CADADR" #f (make-gen-APPLY-C...R #f 21))
(define-APPLY "##CADDAR" #f (make-gen-APPLY-C...R #f 22))
(define-APPLY "##CADDDR" #f (make-gen-APPLY-C...R #f 23))
(define-APPLY "##CDAAAR" #f (make-gen-APPLY-C...R #f 24))
(define-APPLY "##CDAADR" #f (make-gen-APPLY-C...R #f 25))
(define-APPLY "##CDADAR" #f (make-gen-APPLY-C...R #f 26))
(define-APPLY "##CDADDR" #f (make-gen-APPLY-C...R #f 27))
(define-APPLY "##CDDAAR" #f (make-gen-APPLY-C...R #f 28))
(define-APPLY "##CDDADR" #f (make-gen-APPLY-C...R #f 29))
(define-APPLY "##CDDDAR" #f (make-gen-APPLY-C...R #f 30))
(define-APPLY "##CDDDDR" #f (make-gen-APPLY-C...R #f 31))

(define-APPLY "##WEAK-CONS" #f (lambda (opnds loc sn)
  (gen-cons #t opnds loc sn)))

(define-APPLY "##WEAK-SET-CAR!" #t (lambda (opnds loc sn)
  (gen-set-car! #t opnds loc sn)))

(define-APPLY "##WEAK-SET-CDR!" #t (lambda (opnds loc sn)
  (gen-set-cdr! #t opnds loc sn)))

(define-APPLY "##WEAK-CAR" #f (make-gen-APPLY-C...R #t 2))
(define-APPLY "##WEAK-CDR" #f (make-gen-APPLY-C...R #t 3))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##MAKE-CELL" #f (lambda (opnds loc sn)
  (gen-cons #f (list (car opnds) (make-obj '())) loc sn)))

(define-APPLY "##CELL-REF" #f (make-gen-APPLY-C...R #f 2))

(define-APPLY "##CELL-SET!" #t (lambda (opnds loc sn)
  (gen-set-car! #f opnds loc sn)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##VECTOR"           #f (gen-vector 'VECTOR))
(define-APPLY "##VECTOR-LENGTH"    #f (gen-vector-length 'VECTOR))
(define-APPLY "##VECTOR-REF"       #f (gen-vector-ref 'VECTOR))
(define-APPLY "##VECTOR-SET!"      #t (gen-vector-set! 'VECTOR))
(define-APPLY "##VECTOR-SHRINK!"   #t (gen-vector-shrink! 'VECTOR))

(define-APPLY "##STRING"           #f (gen-vector 'STRING))
(define-APPLY "##STRING-LENGTH"    #f (gen-vector-length 'STRING))
(define-APPLY "##STRING-REF"       #f (gen-vector-ref 'STRING))
(define-APPLY "##STRING-SET!"      #t (gen-vector-set! 'STRING))
(define-APPLY "##STRING-SHRINK!"   #t (gen-vector-shrink! 'STRING))

(define-APPLY "##VECTOR8"          #f (gen-vector 'VECTOR8))
(define-APPLY "##VECTOR8-LENGTH"   #f (gen-vector-length 'VECTOR8))
(define-APPLY "##VECTOR8-REF"      #f (gen-vector-ref 'VECTOR8))
(define-APPLY "##VECTOR8-SET!"     #t (gen-vector-set! 'VECTOR8))
(define-APPLY "##VECTOR8-SHRINK!"  #t (gen-vector-shrink! 'VECTOR8))

(define-APPLY "##VECTOR16"         #f (gen-vector 'VECTOR16))
(define-APPLY "##VECTOR16-LENGTH"  #f (gen-vector-length 'VECTOR16))
(define-APPLY "##VECTOR16-REF"     #f (gen-vector-ref 'VECTOR16))
(define-APPLY "##VECTOR16-SET!"    #t (gen-vector-set! 'VECTOR16))
(define-APPLY "##VECTOR16-SHRINK!" #t (gen-vector-shrink! 'VECTOR16))

(define-APPLY "##SLOT-REF"         #f (gen-vector-ref 'SLOT))
(define-APPLY "##SLOT-SET!"        #t (gen-vector-set! 'SLOT))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##PSTATE" #f (lambda (opnds loc sn)
  (move-opnd68-to-loc pstate-reg loc sn)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-APPLY "##TOUCH" #t (lambda (opnds loc sn)
  (let ((opnd (car opnds)))
    (let ((opnd* (if (and (not (pot-fut? opnd))
                          (not (lbl? opnd))
                          (not (obj? opnd)))
                   (put-pot-fut opnd)
                   opnd)))
      (if loc
        (touch-opnd-to-loc opnd* loc sn)
        (touch-opnd-to-any-reg68 opnd* #f sn))))))

;------------------------------------------------------------------------------

(def-spec "NOT"        (safe "##NOT"))
(def-spec "NULL?"      (safe "##NULL?"))
(def-spec "EQ?"        (safe "##EQ?"))

(def-spec "PAIR?"      (safe "##PAIR?"))
(def-spec "PROCEDURE?" (safe "##PROCEDURE?"))
(def-spec "VECTOR?"    (safe "##VECTOR?"))
(def-spec "SYMBOL?"    (safe "##SYMBOL?"))
(def-spec "STRING?"    (safe "##STRING?"))
(def-spec "CHAR?"      (safe "##CHAR?"))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(def-spec "ZERO?"     (safe-arith   "##FIXNUM.ZERO?"     "##FLONUM.ZERO?"))
(def-spec "POSITIVE?" (safe-arith   "##FIXNUM.POSITIVE?" "##FLONUM.POSITIVE?"))
(def-spec "NEGATIVE?" (safe-arith   "##FIXNUM.NEGATIVE?" "##FLONUM.NEGATIVE?"))
(def-spec "ODD?"      (safe-arith   "##FIXNUM.ODD?"      #f))
(def-spec "EVEN?"     (safe-arith   "##FIXNUM.EVEN?"     #f))

(def-spec "+"         (unsafe-arith "##FIXNUM.+"         "##FLONUM.+"))
(def-spec "*"         (unsafe-arith "##FIXNUM.*"         "##FLONUM.*"))
(def-spec "-"         (unsafe-arith "##FIXNUM.-"         "##FLONUM.-"))
(def-spec "/"         (unsafe-arith #f                   "##FLONUM./"))
(def-spec "QUOTIENT"  (unsafe-arith "##FIXNUM.QUOTIENT"  #f))
(def-spec "REMAINDER" (unsafe-arith "##FIXNUM.REMAINDER" #f))
(def-spec "MODULO"    (unsafe-arith "##FIXNUM.MODULO"    #f))

(def-spec "##LOGIOR"  (unsafe-arith "##FIXNUM.LOGIOR"    #f))
(def-spec "##LOGXOR"  (unsafe-arith "##FIXNUM.LOGXOR"    #f))
(def-spec "##LOGAND"  (unsafe-arith "##FIXNUM.LOGAND"    #f))
(def-spec "##LOGNOT"  (unsafe-arith "##FIXNUM.LOGNOT"    #f))
(def-spec "##ASH"     (unsafe-arith "##FIXNUM.ASH"       #f))

(def-spec "="         (safe-arith   "##FIXNUM.="         "##FLONUM.="))
(def-spec "<"         (safe-arith   "##FIXNUM.<"         "##FLONUM.<"))
(def-spec ">"         (safe-arith   "##FIXNUM.>"         "##FLONUM.>"))
(def-spec "<="        (safe-arith   "##FIXNUM.<="        "##FLONUM.<="))
(def-spec ">="        (safe-arith   "##FIXNUM.>="        "##FLONUM.>="))

(def-spec "ABS"       (unsafe-arith #f                   "##FLONUM.ABS"))
(def-spec "TRUNCATE"  (unsafe-arith #f                   "##FLONUM.TRUNCATE"))
(def-spec "EXP"       (unsafe-arith #f                   "##FLONUM.EXP"))
(def-spec "LOG"       (unsafe-arith #f                   "##FLONUM.LOG"))
(def-spec "SIN"       (unsafe-arith #f                   "##FLONUM.SIN"))
(def-spec "COS"       (unsafe-arith #f                   "##FLONUM.COS"))
(def-spec "TAN"       (unsafe-arith #f                   "##FLONUM.TAN"))
(def-spec "ASIN"      (unsafe-arith #f                   "##FLONUM.ASIN"))
(def-spec "ACOS"      (unsafe-arith #f                   "##FLONUM.ACOS"))
(def-spec "ATAN"      (unsafe-arith #f                   "##FLONUM.ATAN"))
(def-spec "SQRT"      (unsafe-arith #f                   "##FLONUM.SQRT"))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(def-spec "CHAR=?"    (safe "##CHAR=?"))
(def-spec "CHAR<?"    (safe "##CHAR<?"))
(def-spec "CHAR>?"    (safe "##CHAR>?"))
(def-spec "CHAR<=?"   (safe "##CHAR<=?"))
(def-spec "CHAR>=?"   (safe "##CHAR>=?"))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(def-spec "CONS"             (safe "##CONS"))
(def-spec "SET-CAR!"         (unsafe "##SET-CAR!"))
(def-spec "SET-CDR!"         (unsafe "##SET-CDR!"))
(def-spec "CAR"              (unsafe "##CAR"))
(def-spec "CDR"              (unsafe "##CDR"))
(def-spec "CAAR"             (unsafe "##CAAR"))
(def-spec "CADR"             (unsafe "##CADR"))
(def-spec "CDAR"             (unsafe "##CDAR"))
(def-spec "CDDR"             (unsafe "##CDDR"))
(def-spec "CAAAR"            (unsafe "##CAAAR"))
(def-spec "CAADR"            (unsafe "##CAADR"))
(def-spec "CADAR"            (unsafe "##CADAR"))
(def-spec "CADDR"            (unsafe "##CADDR"))
(def-spec "CDAAR"            (unsafe "##CDAAR"))
(def-spec "CDADR"            (unsafe "##CDADR"))
(def-spec "CDDAR"            (unsafe "##CDDAR"))
(def-spec "CDDDR"            (unsafe "##CDDDR"))
(def-spec "CAAAAR"           (unsafe "##CAAAAR"))
(def-spec "CAAADR"           (unsafe "##CAAADR"))
(def-spec "CAADAR"           (unsafe "##CAADAR"))
(def-spec "CAADDR"           (unsafe "##CAADDR"))
(def-spec "CADAAR"           (unsafe "##CADAAR"))
(def-spec "CADADR"           (unsafe "##CADADR"))
(def-spec "CADDAR"           (unsafe "##CADDAR"))
(def-spec "CADDDR"           (unsafe "##CADDDR"))
(def-spec "CDAAAR"           (unsafe "##CDAAAR"))
(def-spec "CDAADR"           (unsafe "##CDAADR"))
(def-spec "CDADAR"           (unsafe "##CDADAR"))
(def-spec "CDADDR"           (unsafe "##CDADDR"))
(def-spec "CDDAAR"           (unsafe "##CDDAAR"))
(def-spec "CDDADR"           (unsafe "##CDDADR"))
(def-spec "CDDDAR"           (unsafe "##CDDDAR"))
(def-spec "CDDDDR"           (unsafe "##CDDDDR"))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(def-spec "VECTOR"           (safe "##VECTOR"))
(def-spec "VECTOR-LENGTH"    (unsafe "##VECTOR-LENGTH"))
(def-spec "VECTOR-REF"       (unsafe "##VECTOR-REF"))
(def-spec "VECTOR-SET!"      (unsafe "##VECTOR-SET!"))

(def-spec "STRING"           (safe "##STRING"))
(def-spec "STRING-LENGTH"    (unsafe "##STRING-LENGTH"))
(def-spec "STRING-REF"       (unsafe "##STRING-REF"))
(def-spec "STRING-SET!"      (unsafe "##STRING-SET!"))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(def-spec "TOUCH"            (safe "##TOUCH"))

;------------------------------------------------------------------------------

(let ((targ (make-target 3 'M68000)))

  (target-begin!-set! targ (lambda (info-port) (begin! info-port targ)))

  (put-target targ))

;==============================================================================