ikarus/scheme/pass-specify-rep-primops.ss

;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
;;; 
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License version 3 as
;;; published by the Free Software Foundation.
;;; 
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;; 
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(define-syntax section
  (syntax-rules (/section)
    [(section e* ... /section) (begin e* ...)]))

(section ;;; helpers

(define (prm op . arg*)
  (make-primcall op arg*))

(define (nop) (make-primcall 'nop '()))

(define (K x) (make-constant x))


(define (tag-test x mask tag)
  (if mask
      (prm '= (prm 'logand x (K mask)) (K tag))
      (prm '= x (K tag))))

(define (sec-tag-test x pmask ptag smask stag)
  (make-conditional 
    (tag-test x pmask ptag)
    (tag-test (prm 'mref x (K (- ptag))) smask stag)
    (make-constant #f)))

(define (safe-ref x disp mask tag)
  (seq*
    (interrupt-unless (tag-test x mask tag))
    (prm 'mref x (K (- disp tag)))))

(define (dirty-vector-set address)
  (prm 'mset 
     (prm 'int+
          (prm 'mref pcr (K pcb-dirty-vector))
          (prm 'sll (prm 'srl address (K pageshift)) (K wordshift)))
     (K 0)
     (K dirty-word)))

(define (smart-dirty-vector-set addr what)
  (struct-case what
    [(constant t) 
     (if (or (fixnum? t) (immediate? t))
         (prm 'nop)
         (dirty-vector-set addr))]
    [else (dirty-vector-set addr)]))


(define (slow-mem-assign v x i)
  (with-tmp ([t (prm 'int+ x (K i))])
    (make-seq 
      (prm 'mset t (K 0) (T v))
      (dirty-vector-set t))))

(define (mem-assign v x i)
  (struct-case v
    [(constant t) 
     (if (or (fixnum? t) (immediate? t))
         (prm 'mset x (K i) (T v))
         (slow-mem-assign v x i))]
    [else (slow-mem-assign v x i)]))

(define (align-code unknown-amt known-amt)
  (prm 'sll 
     (prm 'sra
          (prm 'int+ unknown-amt
               (K (+ known-amt (sub1 object-alignment))))
          (K align-shift))
     (K align-shift)))
/section)

(section ;;; simple objects section

(define-primop base-rtd safe
  [(V) (prm 'mref pcr (K pcb-base-rtd))]
  [(P) (K #t)]
  [(E) (prm 'nop)])

(define-primop void safe
  [(V) (K void-object)]
  [(P) (K #t)]
  [(E) (prm 'nop)])

(define-primop nop unsafe
  [(E) (prm 'nop)])

(define-primop neq? unsafe
  [(P x y) (prm '!= (T x) (T y))]
  [(E x y) (nop)])

(define-primop eq? safe
  [(P x y) (prm '= (T x) (T y))]
  [(E x y) (nop)])

(define-primop null? safe
  [(P x) (prm '= (T x) (K nil))]
  [(E x) (nop)])

(define-primop not safe
  [(P x) (prm '= (T x) (K bool-f))]
  [(E x) (nop)])

(define-primop eof-object safe
  [(V) (K eof)]
  [(P) (K #t)]
  [(E) (nop)])

(define-primop eof-object? safe
  [(P x) (prm '= (T x) (K eof))]
  [(E x) (nop)])

(define-primop $unbound-object? unsafe
  [(P x) (prm '= (T x) (K unbound))]
  [(E x) (nop)])

(define-primop immediate? safe
  [(P x)
   (make-conditional
     (tag-test (T x) fx-mask fx-tag)
     (make-constant #t)
     (tag-test (T x) 7 7))]
  [(E x) (nop)])

(define-primop boolean? safe
  [(P x) (tag-test (T x) bool-mask bool-tag)]
  [(E x) (nop)])

(define-primop bwp-object? safe
  [(P x) (prm '= (T x) (K bwp-object))]
  [(E x) (nop)])

(define-primop $forward-ptr? unsafe
  [(P x) (prm '= (T x) (K -1))]
  [(E x) (nop)])

(define-primop pointer-value unsafe
  [(V x) (prm 'logand 
           (prm 'srl (T x) (K 1))
           (K (* -1 fx-scale)))]
  [(P x) (K #t)]
  [(E x) (nop)])

(define-primop $arg-list unsafe
  [(V) (prm 'mref pcr (K pcb-arg-list))]
  [(P) (K #t)]
  [(E) (nop)])

(define-primop $collect-key unsafe
  [(V) (prm 'mref pcr (K pcb-collect-key))]
  [(E x) (prm 'mset pcr (K pcb-collect-key) (T x))])

(define-primop $memq safe
  [(P x ls)
   (struct-case ls
     [(constant ls)
      (cond
        [(not (list? ls)) (interrupt)]
        [else
         (with-tmp ([x (T x)])
           (let f ([ls ls])
             (cond
               [(null? ls) (K #f)]
               [(null? (cdr ls)) (prm '= x (T (K (car ls))))]
               [else
                (make-conditional 
                  (prm '= x (T (K (car ls))))
                  (K #t)
                  (f (cdr ls)))])))])]
     [else (interrupt)])]
  [(V x ls)
   (struct-case ls
     [(constant ls)
      (cond
        [(not (list? ls)) (interrupt)]
        [else
         (with-tmp ([x (T x)])
           (let f ([ls ls])
             (cond
               [(null? ls) (K bool-f)]
               [else
                (make-conditional 
                  (prm '= x (T (K (car ls))))
                  (T (K ls))
                  (f (cdr ls)))])))])]
     [else (interrupt)])]
  [(E x ls) (nop)])


/section)

(section ;;; pairs 

(define-primop pair? safe
  [(P x) (tag-test (T x) pair-mask pair-tag)]
  [(E x) (nop)])

(define-primop cons safe
  [(V a d)
   (with-tmp ([t (prm 'alloc (K pair-size) (K pair-tag))])
     (prm 'mset t (K (- disp-car pair-tag)) (T a))
     (prm 'mset t (K (- disp-cdr pair-tag)) (T d))
     t)]
  [(P a d) (K #t)]
  [(E a d) (prm 'nop)])

(define-primop $car unsafe
  [(V x) (prm 'mref  (T x) (K (- disp-car pair-tag)))]
  [(E x) (nop)])

(define-primop $cdr unsafe
  [(V x) (prm 'mref  (T x) (K (- disp-cdr pair-tag)))]
  [(E x) (nop)])

(define-primop $set-car! unsafe
  [(E x v)
   (with-tmp ([x (T x)])
     (prm 'mset x (K (- disp-car pair-tag)) (T v))
     (smart-dirty-vector-set x v))])

(define-primop $set-cdr! unsafe
  [(E x v)
   (with-tmp ([x (T x)])
     (prm 'mset x (K (- disp-cdr pair-tag)) (T v))
     (smart-dirty-vector-set x v))])

(define-primop car safe
  [(V x)
   (safe-ref (T x) disp-car pair-mask pair-tag)]
  [(E x)
   (interrupt-unless (tag-test (T x) pair-mask pair-tag))])

(define-primop cdr safe
  [(V x)
   (safe-ref (T x) disp-cdr pair-mask pair-tag)]
  [(E x)
   (interrupt-unless (tag-test (T x) pair-mask pair-tag))])

(define-primop set-car! safe
  [(E x v)
   (with-tmp ([x (T x)])
     (interrupt-unless (tag-test x pair-mask pair-tag))
     (prm 'mset x (K (- disp-car pair-tag)) (T v))
     (smart-dirty-vector-set x v))])

(define-primop set-cdr! safe
  [(E x v)
   (with-tmp ([x (T x)])
     (interrupt-unless (tag-test x pair-mask pair-tag))
     (prm 'mset x (K (- disp-cdr pair-tag)) (T v))
     (smart-dirty-vector-set x v))])


(define (expand-cxr val ls) 
  (cond
    [(null? ls) (T val)]
    [else 
     (with-tmp ([x (expand-cxr val (cdr ls))]) 
       (interrupt-unless (tag-test x pair-mask pair-tag))
       (prm 'mref x 
          (case (car ls) 
            [(a)  (K (- disp-car pair-tag))]
            [else (K (- disp-cdr pair-tag))])))]))

(define-primop caar   safe [(V x) (expand-cxr x '(a a))])
(define-primop cadr   safe [(V x) (expand-cxr x '(a d))])
(define-primop cdar   safe [(V x) (expand-cxr x '(d a))])
(define-primop cddr   safe [(V x) (expand-cxr x '(d d))])
(define-primop caaar  safe [(V x) (expand-cxr x '(a a a))])
(define-primop caadr  safe [(V x) (expand-cxr x '(a a d))])
(define-primop cadar  safe [(V x) (expand-cxr x '(a d a))])
(define-primop caddr  safe [(V x) (expand-cxr x '(a d d))])
(define-primop cdaar  safe [(V x) (expand-cxr x '(d a a))])
(define-primop cdadr  safe [(V x) (expand-cxr x '(d a d))])
(define-primop cddar  safe [(V x) (expand-cxr x '(d d a))])
(define-primop cdddr  safe [(V x) (expand-cxr x '(d d d))])
;(define-primop caaaar safe [(V x) (expand-cxr x '(a a a a))])
;(define-primop caaadr safe [(V x) (expand-cxr x '(a a a d))])
;(define-primop caadar safe [(V x) (expand-cxr x '(a a d a))])
;(define-primop caaddr safe [(V x) (expand-cxr x '(a a d d))])
;(define-primop cadaar safe [(V x) (expand-cxr x '(a d a a))])
;(define-primop cadadr safe [(V x) (expand-cxr x '(a d a d))])
;(define-primop caddar safe [(V x) (expand-cxr x '(a d d a))])
(define-primop cadddr safe [(V x) (expand-cxr x '(a d d d))])
;(define-primop cdaaar safe [(V x) (expand-cxr x '(d a a a))])
;(define-primop cdaadr safe [(V x) (expand-cxr x '(d a a d))])
;(define-primop cdadar safe [(V x) (expand-cxr x '(d a d a))])
;(define-primop cdaddr safe [(V x) (expand-cxr x '(d a d d))])
;(define-primop cddaar safe [(V x) (expand-cxr x '(d d a a))])
;(define-primop cddadr safe [(V x) (expand-cxr x '(d d a d))])
;(define-primop cdddar safe [(V x) (expand-cxr x '(d d d a))])
;(define-primop cddddr safe [(V x) (expand-cxr x '(d d d d))])


(define-primop list safe
  [(V) (K nil)]
  [(V . arg*)
   (let ([n (length arg*)] [t* (map T arg*)])
     (with-tmp ([v (prm 'alloc (K (align (* n pair-size))) (K pair-tag))])
       (prm 'mset v (K (- disp-car pair-tag)) (car t*))
       (prm 'mset v
            (K (- (+ disp-cdr (* (sub1 n) pair-size)) pair-tag))
            (K nil))
       (let f ([t* (cdr t*)] [i pair-size])
         (cond
           [(null? t*) v]
           [else
            (with-tmp ([tmp (prm 'int+ v (K i))])
              (prm 'mset tmp (K (- disp-car pair-tag)) (car t*))
              (prm 'mset tmp (K (+ disp-cdr (- pair-size) (- pair-tag))) tmp)
              (f (cdr t*) (+ i pair-size)))]))))]
  [(P . arg*) (K #t)]
  [(E . arg*) (nop)])

(define-primop cons* safe
  [(V) (interrupt)]
  [(V x) (T x)]
  [(V a . a*)
   (let ([t* (map T a*)] [n (length a*)])
     (with-tmp ([v (prm 'alloc (K (* n pair-size)) (K pair-tag))])
       (prm 'mset v (K (- disp-car pair-tag)) (T a))
       (let f ([t* t*] [i pair-size])
         (cond
           [(null? (cdr t*)) 
            (seq* (prm 'mset v (K (- i disp-cdr pair-tag)) (car t*)) v)]
           [else
            (with-tmp ([tmp (prm 'int+ v (K i))])
              (prm 'mset tmp (K (- disp-car pair-tag)) (car t*))
              (prm 'mset tmp (K (- (- disp-cdr pair-tag) pair-size)) tmp)
              (f (cdr t*) (+ i pair-size)))]))))]
  [(P) (interrupt)]
  [(P x) (P x)]
  [(P a . a*) (K #t)]
  [(E) (interrupt)]
  [(E . a*) (nop)])




/section)

(section ;;; vectors
  (section ;;; helpers
    (define (vector-range-check x idx)
      (define (check-fx i)
        (seq*
           (interrupt-unless (tag-test (T x) vector-mask vector-tag))
           (with-tmp ([len (cogen-value-$vector-length x)])
             (interrupt-unless (prm 'u< (K (* i wordsize)) len))
             (interrupt-unless-fixnum len))))
      (define (check-? idx)
        (seq*
          (interrupt-unless (tag-test (T x) vector-mask vector-tag))
          (with-tmp ([len (cogen-value-$vector-length x)])
            (interrupt-unless (prm 'u< (T idx) len))
            (with-tmp ([t (prm 'logor len (T idx))])
              (interrupt-unless-fixnum t)))))
      (struct-case idx
        [(constant i)
         (if (and (fixnum? i) (fx>= i 0)) 
             (check-fx i)
             (check-? idx))]
        [else (check-? idx)]))
    /section)

(define-primop vector? unsafe
  [(P x) (sec-tag-test (T x) vector-mask vector-tag fx-mask fx-tag)]
  [(E x) (nop)])

(define-primop $make-vector unsafe
  [(V len)
   (struct-case len
     [(constant i)
      (unless (fixnum? i) (interrupt))
      (with-tmp ([v (prm 'alloc
                        (K (align (+ (* i wordsize) disp-vector-data)))
                        (K vector-tag))])
          (prm 'mset v 
               (K (- disp-vector-length vector-tag))
               (K (make-constant (* i fx-scale))))
          v)]
     [else
      (with-tmp ([alen (align-code (T len) disp-vector-data)])
        (with-tmp ([v (prm 'alloc alen (K vector-tag))])
            (prm 'mset v (K (- disp-vector-length vector-tag)) (T len))
            v))])]
  [(P len) (K #t)]
  [(E len) (nop)])

(define-primop make-vector safe
  [(V len) 
   (with-tmp ([x (make-forcall "ikrt_make_vector1" (list (T len)))]) 
      (interrupt-when (prm '= x (K 0)))
      x)])



(define-primop $vector-ref unsafe
  [(V x i)
   (or 
     (struct-case i
       [(constant i) 
        (and (fixnum? i) 
             (fx>= i 0)
             (prm 'mref (T x) 
                  (K (+ (* i wordsize) (- disp-vector-data vector-tag)))))]
       [else #f])
        (prm 'mref (T x) 
           (prm 'int+ (T i) (K (- disp-vector-data vector-tag)))))])

(define-primop $vector-length unsafe
  [(V x) (prm 'mref (T x) (K (- disp-vector-length vector-tag)))]
  [(E x) (prm 'nop)]
  [(P x) (K #t)])

(define-primop vector-length safe
  [(V x)
   (seq*
     (interrupt-unless (tag-test (T x) vector-mask vector-tag))
     (with-tmp ([t (cogen-value-$vector-length x)])
       (interrupt-unless-fixnum t)
       t))]
  [(E x)
   (seq*
     (interrupt-unless (tag-test (T x) vector-mask vector-tag))
     (with-tmp ([t (cogen-value-$vector-length x)])
       (interrupt-unless-fixnum t)))]
  [(P x) 
   (seq* (cogen-effect-vector-length x) (K #t))])

(define-primop vector-ref safe
  [(V x i)
   (seq*
     (vector-range-check x i)
     (cogen-value-$vector-ref x i))]
  [(E x i)
   (vector-range-check x i)])


(define-primop $vector-set! unsafe
  [(E x i v)
   (struct-case i
     [(constant i) 
      (unless (fixnum? i) (interrupt)) 
      (mem-assign v (T x) 
         (+ (* i wordsize)
            (- disp-vector-data vector-tag)))]
     [else
      (mem-assign v 
         (prm 'int+ (T x) (T i))
         (- disp-vector-data vector-tag))])])

(define-primop vector-set! safe
  [(E x i v)
   (seq*
     (vector-range-check x i)
     (cogen-effect-$vector-set! x i v))])

(define-primop vector safe
  [(V . arg*)
   (with-tmp ([v (prm 'alloc
                   (K (align (+ disp-vector-data
                                (* (length arg*) wordsize))))
                   (K vector-tag))])
     (seq*
       (prm 'mset v (K (- disp-vector-length vector-tag))
            (K (* (length arg*) wordsize)))
       (let f ([t* (map T arg*)]
               [i (- disp-vector-data vector-tag)])
         (cond
           [(null? t*) v]
           [else
            (make-seq
              (prm 'mset v (K i) (car t*))
              (f (cdr t*) (+ i wordsize)))]))))]
  [(E . arg*) (prm 'nop)]
  [(P . arg*) (K #t)])

/section)

(section ;;; closures

(define-primop procedure? safe
  [(P x) (tag-test (T x) closure-mask closure-tag)])

(define-primop $cpref unsafe
  [(V x i) 
   (struct-case i
     [(constant i) 
      (unless (fixnum? i) (interrupt))
      (prm 'mref (T x)
         (K (+ (- disp-closure-data closure-tag)
               (* i wordsize))))]
     [else (interrupt)])])

/section)

(section ;;; symbols

(define-primop symbol? safe
  [(P x) 
   (sec-tag-test (T x) vector-mask vector-tag #f symbol-record-tag)]
  [(E x) (nop)])

(define-primop $make-symbol unsafe
  [(V str)
   (with-tmp ([x (prm 'alloc (K (align symbol-record-size)) (K symbol-ptag))])
     (prm 'mset x (K (- symbol-ptag)) (K symbol-record-tag))
     (prm 'mset x (K (- disp-symbol-record-string symbol-ptag))  (T str))
     (prm 'mset x (K (- disp-symbol-record-ustring symbol-ptag)) (K 0))
     (prm 'mset x (K (- disp-symbol-record-value symbol-ptag))   (K unbound))
     (prm 'mset x (K (- disp-symbol-record-proc symbol-ptag))    (K unbound))
     (prm 'mset x (K (- disp-symbol-record-plist symbol-ptag))   (K nil))
     x)]
  [(P str) (K #t)]
  [(E str) (nop)])

(define-primop $symbol-string unsafe
  [(V x) (prm 'mref (T x) (K (- disp-symbol-record-string symbol-ptag)))]
  [(E x) (nop)])

(define-primop $set-symbol-string! unsafe
  [(E x v) (mem-assign v (T x) (- disp-symbol-record-string symbol-ptag))])

(define-primop $symbol-unique-string unsafe
  [(V x) (prm 'mref (T x) (K (- disp-symbol-record-ustring symbol-ptag)))]
  [(E x) (nop)])

(define-primop $set-symbol-unique-string! unsafe
  [(E x v) (mem-assign v (T x) (- disp-symbol-record-ustring symbol-ptag))])

(define-primop $symbol-plist unsafe
  [(V x) (prm 'mref (T x) (K (- disp-symbol-record-plist symbol-ptag)))]
  [(E x) (nop)])

(define-primop $set-symbol-plist! unsafe
  [(E x v) (mem-assign v (T x) (- disp-symbol-record-plist symbol-ptag))])

(define-primop $symbol-value unsafe
  [(V x) (prm 'mref (T x) (K (- disp-symbol-record-value symbol-ptag)))]
  [(E x) (nop)])

(define-primop $set-symbol-value! unsafe
  [(E x v)
   (with-tmp ([x (T x)])
     (prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) (T v))
     (dirty-vector-set x))])

(define-primop $set-symbol-proc! unsafe
  [(E x v)
   (with-tmp ([x (T x)])
     (prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) (T v))
     (dirty-vector-set x))])

(define-primop $set-symbol-value/proc! unsafe
  [(E x v)
   (with-tmp ([x (T x)] [v (T v)])
     (prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) v)
     (prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) v)
     (dirty-vector-set x))])

(define-primop top-level-value safe
  [(V x)
   (struct-case x
     [(constant s)
      (if (symbol? s)
          (with-tmp ([v (cogen-value-$symbol-value x)])
            (interrupt-when (cogen-pred-$unbound-object? v))
            v)
          (interrupt))]
     [else
      (with-tmp ([x (T x)])
        (interrupt-unless (cogen-pred-symbol? x))
        (with-tmp ([v (cogen-value-$symbol-value x)])
          (interrupt-when (cogen-pred-$unbound-object? v))
          v))])]
  [(E x)
   (struct-case x
     [(constant s)
      (if (symbol? s)
          (with-tmp ([v (cogen-value-$symbol-value x)])
            (interrupt-when (cogen-pred-$unbound-object? v)))
          (interrupt))]
     [else
      (with-tmp ([x (T x)])
        (interrupt-unless (cogen-pred-symbol? x))
        (with-tmp ([v (cogen-value-$symbol-value x)])
          (interrupt-when (cogen-pred-$unbound-object? v))))])])


(define-primop $init-symbol-function! unsafe
  [(E x v)
   (with-tmp ([x (T x)] [v (T v)])
     (prm 'mset x (K (- disp-symbol-record-proc symbol-ptag)) v)
     ;(prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
     (dirty-vector-set x))])


/section)

(section ;;; fixnums

(define-primop fixnum? safe
  [(P x) (tag-test (T x) fx-mask fx-tag)]
  [(E x) (nop)])


(define-primop fixnum-width safe
  [(V) (K (fxsll (- (* wordsize 8) fx-shift) fx-shift))]
  [(E) (nop)]
  [(P) (K #t)])

(define-primop least-fixnum safe
  [(V) (K (sll (- (expt 2 (- (- (* wordsize 8) fx-shift) 1)))
               fx-shift))]
  [(E) (nop)]
  [(P) (K #t)])

(define-primop greatest-fixnum safe
  [(V) (K (sll (- (expt 2 (- (- (* wordsize 8) fx-shift) 1)) 1)
               fx-shift))]
  [(E) (nop)]
  [(P) (K #t)])




(define-primop $fxzero? unsafe
  [(P x) (prm '= (T x) (K 0))]
  [(E x) (nop)])

(define-primop $fx= unsafe
  [(P x y) (prm '= (T x) (T y))]
  [(E x y) (nop)])

(define-primop $fx< unsafe
  [(P x y) (prm '< (T x) (T y))]
  [(E x y) (nop)])

(define-primop $fx<= unsafe
  [(P x y) (prm '<= (T x) (T y))]
  [(E x y) (nop)])

(define-primop $fx> unsafe
  [(P x y) (prm '> (T x) (T y))]
  [(E x y) (nop)])

(define-primop $fx>= unsafe
  [(P x y) (prm '>= (T x) (T y))]
  [(E x y) (nop)])

(define-primop $fxadd1 unsafe
  [(V x) (cogen-value-$fx+ x (K 1))]
  [(P x) (K #t)]
  [(E x) (nop)])

(define-primop $fxsub1 unsafe
  [(V x) (cogen-value-$fx+ x (K -1))]
  [(P x) (K #t)]
  [(E x) (nop)])

(define-primop $fx+ unsafe
  [(V x y) (prm 'int+ (T x) (T y))]
  [(P x y) (K #t)]
  [(E x y) (nop)])

(define-primop $fx* unsafe
  [(V a b) 
   (struct-case a
    [(constant a)
     (unless (fixnum? a) (interrupt))
     (prm 'int* (T b) (K a))]
    [else
     (struct-case b
       [(constant b)
        (unless (fixnum? b) (interrupt))
        (prm 'int* (T a) (K b))]
       [else
        (prm 'int* (T a) (prm 'sra (T b) (K fx-shift)))])])]
  [(P x y) (K #t)]
  [(E x y) (nop)])

(define-primop $fxlognot unsafe
  [(V x) (cogen-value-$fxlogxor x (K -1))]
  [(P x) (K #t)]
  [(E x) (nop)])

(define-primop $fxlogand unsafe
  [(V x y) (prm 'logand (T x) (T y))]
  [(P x y) (K #t)]
  [(E x y) (nop)])

(define-primop $fxlogor unsafe
  [(V x y) (prm 'logor (T x) (T y))]
  [(P x y) (K #t)]
  [(E x y) (nop)])

(define-primop $fxlogxor unsafe
  [(V x y) (prm 'logxor (T x) (T y))]
  [(P x y) (K #t)]
  [(E x y) (nop)])

(define-primop $fx- unsafe
  [(V x y) (prm 'int- (T x) (T y))]
  [(P x y) (K #t)]
  [(E x y) (nop)])

(define-primop $fxsll unsafe
  [(V x i)
   (struct-case i
     [(constant i) 
      (unless (fixnum? i) (interrupt))
      (prm 'sll (T x) (K i))]
     [else 
      (prm 'sll (T x) (prm 'sra (T i) (K fx-shift)))])]
  [(P x i) (K #t)]
  [(E x i) (nop)])

(define-primop $fxsra unsafe
  [(V x i)
   (struct-case i
     [(constant i) 
      (unless (fixnum? i) (interrupt))
      (prm 'logand 
           (prm 'sra (T x) (K (if (> i 31) 31 i)))
           (K (* -1 fx-scale)))]
     [else 
      (with-tmp ([i (prm 'sra (T i) (K fx-shift))])
        (with-tmp ([i (make-conditional
                        (prm '< i (K 32))
                        i
                        (K 31))])
           (prm 'logand
                (prm 'sra (T x) i)
                (K (* -1 fx-scale)))))])]
  [(P x i) (K #t)]
  [(E x i) (nop)])

(define-primop $fxquotient unsafe
  [(V a b) 
   (with-tmp ([b (T b)]) ;;; FIXME: why is quotient called remainder?
    (prm 'sll (prm 'remainder (T a) b) (K fx-shift)))]
  [(P a b) (K #t)]
  [(E a b) (nop)])


(define-primop $fxmodulo unsafe
  [(V a b)
   (with-tmp ([b (T b)]) ;;; FIXME: why is modulo called quotient?
     (with-tmp ([c (prm 'logand b 
                      (prm 'sra (prm 'logxor b (T a))
                         (K (sub1 (* 8 wordsize)))))])
       (prm 'int+ c (prm 'quotient (T a) b))))]
  [(P a b) (K #t)]
  [(E a b) (nop)])

(define-primop $fxinthash unsafe
  [(V key)
   (with-tmp ([k (T key)])
     (with-tmp ([k (prm 'int+ k (prm 'logxor (prm 'sll k (K 15)) (K -1)))])
       (with-tmp ([k (prm 'logxor k (prm 'sra k (K 10)))])
         (with-tmp ([k (prm 'int+ k (prm 'sll k (K 3)))])
           (with-tmp ([k (prm 'logxor k (prm 'sra k (K 6)))])
             (with-tmp ([k (prm 'int+ k (prm 'logxor (prm 'sll k (K 11)) (K -1)))])
               (with-tmp ([k (prm 'logxor k (prm 'sra k (K 16)))])
                 (prm 'sll k (K fx-shift)))))))))])
           

;(define inthash
;    (lambda (key)
;      ;static int inthash(int key) { /* from Bob Jenkin's */
;      ;  key += ~(key << 15);
;      ;  key ^=  (key >> 10);
;      ;  key +=  (key << 3);
;      ;  key ^=  (key >> 6);
;      ;  key += ~(key << 11);
;      ;  key ^=  (key >> 16);
;      ;  return key;
;      ;}
;      (let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
;             [key ($fxlogxor key ($fxsra key 10))]
;             [key ($fx+ key ($fxsll key 3))]
;             [key ($fxlogxor key ($fxsra key 6))]
;             [key ($fx+ key ($fxlognot ($fxsll key 11)))]
;             [key ($fxlogxor key ($fxsra key 16))])
;        key)))


/section)

(section ;;; bignums

(define-primop bignum? safe
  [(P x) (sec-tag-test (T x) vector-mask vector-tag bignum-mask bignum-tag)]
  [(E x) (nop)])

(define-primop $bignum-positive? unsafe
  [(P x) 
   (prm '= (prm 'logand
                (prm 'mref (T x) (K (- vector-tag))) 
                (K bignum-sign-mask))
        (K 0))]
  [(E x) (nop)])

(define-primop $bignum-byte-ref unsafe
  [(V s i)
   (struct-case i
     [(constant i)
      (unless (fixnum? i) (interrupt))
      (prm 'sll
        (prm 'logand 
           (prm 'mref (T s)
             (K (+ i (- disp-bignum-data record-tag))))
           (K 255))
        (K fx-shift))]
     [else
      (prm 'sll
        (prm 'srl ;;; FIXME: bref
           (prm 'mref (T s)
                (prm 'int+
                   (prm 'sra (T i) (K fx-shift))
                   ;;; ENDIANNESS DEPENDENCY
                   (K (- disp-bignum-data 
                         (- wordsize 1) 
                         record-tag))))
           (K (* (- wordsize 1) 8)))
        (K fx-shift))])]
  [(P s i) (K #t)]
  [(E s i) (nop)])

(define-primop $bignum-size unsafe
  [(V x) 
   (prm 'sll
     (prm 'sra
       (prm 'mref (T x) (K (- record-tag))) 
       (K bignum-length-shift))
     (K (* 2 fx-shift)))])

/section)

(section ;;; flonums

(define ($flop-aux op fl0 fl1)
  (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
     (prm 'mset x (K (- vector-tag)) (K flonum-tag))
     (prm 'fl:load (T fl0) (K (- disp-flonum-data vector-tag)))
     (prm op (T fl1) (K (- disp-flonum-data vector-tag)))
     (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
     x))

(define ($flop-aux* op fl fl*)
  (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
     (prm 'mset x (K (- vector-tag)) (K flonum-tag))
     (prm 'fl:load (T fl) (K (- disp-flonum-data vector-tag)))
     (let f ([fl* fl*])
       (cond
         [(null? fl*) (prm 'nop)]
         [else
          (make-seq 
            (prm op (T (car fl*)) (K (- disp-flonum-data vector-tag)))
            (f (cdr fl*)))]))
     (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
     x))

(define ($flcmp-aux op fl0 fl1)
  (make-seq 
    (prm 'fl:load (T fl0) (K (- disp-flonum-data vector-tag)))
    (prm op (T fl1) (K (- disp-flonum-data vector-tag)))))

(define-primop flonum? safe
  [(P x) (sec-tag-test (T x) vector-mask vector-tag #f flonum-tag)]
  [(E x) (nop)])

(define-primop $flonum-u8-ref unsafe
  [(V s i)
   (struct-case i
     [(constant i)
      (unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7))
        (interrupt))
      (prm 'sll
        (prm 'logand 
           (prm 'bref (T s)
             (K (+ (- 7 i) (- disp-flonum-data record-tag))))
           (K 255))
        (K fx-shift))]
     [else (interrupt)])]
  [(P s i) (K #t)]
  [(E s i) (nop)])

(define-primop $make-flonum unsafe
  [(V)
   (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
     (prm 'mset x (K (- vector-tag)) (K flonum-tag))
     x)]
  [(P str) (K #t)]
  [(E str) (nop)])

(define-primop $flonum-set! unsafe
  [(E x i v)
   (struct-case i
     [(constant i)
      (unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7))
        (interrupt))
      (prm 'bset/h (T x)
         (K (+ (- 7 i) (- disp-flonum-data vector-tag)))
            (prm 'sll (T v) (K (- 8 fx-shift))))]
     [else (interrupt)])])

(define-primop $fixnum->flonum unsafe
  [(V fx) 
   (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
     (prm 'mset x (K (- vector-tag)) (K flonum-tag))
     (prm 'fl:from-int
          (K 0) ; dummy
          (prm 'sra (T fx) (K fx-shift)))
     (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
     x)])