diff --git a/bin/ikarus-runtime.c b/bin/ikarus-runtime.c
index 2921740..3229787 100644
--- a/bin/ikarus-runtime.c
+++ b/bin/ikarus-runtime.c
@@ -196,6 +196,10 @@ ik_mmap(int size){
     exit(-1);
   }
   memset(mem, -1, mapsize);
+#ifndef NDEBUG
+  fprintf(stderr, "MMAP 0x%08x .. 0x%08x\n", (int)mem,
+      ((int)(mem))+mapsize-1);
+#endif
   return mem;
 }
 
@@ -211,6 +215,10 @@ ik_munmap(void* mem, int size){
     fprintf(stderr, "ik_munmap failed: %s\n", strerror(errno));
     exit(-1);
   }
+#ifndef NDEBUG
+  fprintf(stderr, "UNMAP 0x%08x .. 0x%08x\n", (int)mem,
+      ((int)(mem))+mapsize-1);
+#endif
 }
 
 int total_malloced = 0;
diff --git a/src/ikarus.boot b/src/ikarus.boot
index 08c21d4..d6d0883 100644
Binary files a/src/ikarus.boot and b/src/ikarus.boot differ
diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss
new file mode 100644
index 0000000..a01fc15
--- /dev/null
+++ b/src/pass-specify-rep-primops.ss
@@ -0,0 +1,1342 @@
+(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 28)) ;;; FIXME: make srl
+          (prm 'sll (prm 'sra address (K pageshift)) (K wordshift)))
+     (K 0)
+     (K dirty-word)))
+
+(define (smart-dirty-vector-set addr what)
+  (record-case what
+    [(constant t) 
+     (if (or (fixnum? t) (immediate? t))
+         (prm 'nop)
+         (dirty-vector-set addr))]
+    [else (dirty-vector-set addr)]))
+
+(define (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 (smart-mem-assign what v x i)
+  (record-case what
+    [(constant t) 
+     (if (or (fixnum? t) (immediate? t))
+         (prm 'mset x (K i) v)
+         (mem-assign v x i))]
+    [else (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)))
+
+
+(define-syntax section
+  (syntax-rules (/section)
+    [(section e* ... /section) (begin e* ...)]))
+
+(section ;;; simple objects section
+
+(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 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) fixnum-mask fixnum-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 (T x) (K (* -1 fixnum-scale)))]
+  [(P x) (K #t)]
+  [(E x) (nop)])
+
+(define-primop $arg-list unsafe
+  [(V) (prm 'mref pcr (K 32))] ;; PCB ARGS-LIST
+  [(P) (K #t)]
+  [(E) (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-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 list* 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)))))
+    (record-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 fixnum-mask fixnum-tag)]
+  [(E x) (nop)])
+
+(define-primop $make-vector unsafe
+  [(V len)
+   (record-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 fixnum-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 $vector-ref unsafe
+  [(V x i)
+   (or 
+     (record-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)
+   (record-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) 
+   (record-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) (tag-test (T x) symbol-mask symbol-tag)]
+  [(E x) (nop)])
+
+(define-primop $make-symbol unsafe
+  [(V str)
+   (with-tmp ([x (prm 'alloc (K (align symbol-size)) (K symbol-tag))])
+     (prm 'mset x (K (- disp-symbol-string symbol-tag)) (T str))
+     (prm 'mset x (K (- disp-symbol-unique-string symbol-tag)) (K 0))
+     (prm 'mset x (K (- disp-symbol-value symbol-tag)) (K unbound))
+     (prm 'mset x (K (- disp-symbol-plist symbol-tag)) (K nil))
+     (prm 'mset x (K (- disp-symbol-system-value symbol-tag)) (K unbound))
+     (prm 'mset x (K (- disp-symbol-function symbol-tag)) (K 0))
+     (prm 'mset x (K (- disp-symbol-error-function symbol-tag)) (K 0)) 
+     (prm 'mset x (K (- disp-symbol-unused symbol-tag)) (K 0))
+     x)]
+  [(P str) (K #t)]
+  [(E str) (nop)])
+
+(define-primop primitive-set! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-symbol-system-value symbol-tag))])
+
+(define-primop primitive-ref unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-symbol-system-value symbol-tag)))]
+  [(E x) (nop)])
+
+(define-primop $symbol-string unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-symbol-string symbol-tag)))]
+  [(E x) (nop)])
+
+(define-primop $set-symbol-string! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-symbol-string symbol-tag))])
+
+(define-primop $symbol-unique-string unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-symbol-unique-string symbol-tag)))]
+  [(E x) (nop)])
+
+(define-primop $set-symbol-unique-string! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-symbol-unique-string symbol-tag))])
+
+(define-primop $symbol-plist unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-symbol-plist symbol-tag)))]
+  [(E x) (nop)])
+
+(define-primop $set-symbol-plist! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-symbol-plist symbol-tag))])
+
+(define-primop $symbol-value unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-symbol-value symbol-tag)))]
+  [(E x) (nop)])
+
+(define-primop $set-symbol-value! unsafe
+  [(E x v)
+   (with-tmp ([x (T x)])
+     (prm 'mset x (K (- disp-symbol-value symbol-tag)) (T v))
+     (prm 'mset x (K (- disp-symbol-function symbol-tag))
+          (prm 'mref x (K (- disp-symbol-error-function symbol-tag))))
+     (dirty-vector-set x))])
+
+(define-primop top-level-value safe
+  [(V x)
+   (record-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)
+   (record-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))))])])
+
+/section)
+
+(section ;;; fixnums
+
+(define-primop fixnum? safe
+  [(P x) (tag-test (T x) fixnum-mask fixnum-tag)]
+  [(E x) (nop)])
+
+(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) 
+   (record-case a
+    [(constant a)
+     (unless (fixnum? a) (interrupt))
+     (prm 'int* (T b) (K a))]
+    [else
+     (record-case b
+       [(constant b)
+        (unless (fixnum? b) (interrupt))
+        (prm 'int* (T a) (K b))]
+       [else
+        (prm 'int* (T a) (prm 'sra (T b) (K fixnum-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)
+   (record-case i
+     [(constant i) 
+      (unless (fixnum? i) (interrupt))
+      (prm 'sll (T x) (K i))]
+     [else 
+      (prm 'sll (T x) (prm 'sra (T i) (K fixnum-shift)))])]
+  [(P x i) (K #t)]
+  [(E x i) (nop)])
+
+(define-primop $fxsra unsafe
+  [(V x i)
+   (record-case i
+     [(constant i) 
+      (unless (fixnum? i) (interrupt))
+      (prm 'logand (prm 'sra (T x) (K i)) (K (* -1 fixnum-scale)))]
+     [else 
+      (prm 'logand
+           (prm 'sra (T x) (prm 'sra (T i) (K fixnum-shift)))
+           (K (* -1 fixnum-scale)))])]
+  [(P x i) (K #t)]
+  [(E x i) (nop)])
+
+(define-primop $fxquotient unsafe
+  [(V a b) 
+   (with-tmp ([b (T b)])
+    (prm 'sll (prm 'remainder (T a) b) (K fixnum-shift)))]
+  [(P a b) (K #t)]
+  [(E a b) (nop)])
+
+(define-primop $fxmodulo unsafe
+  [(V a b)
+   (with-tmp ([b (T b)])
+     (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)])
+
+/section)
+
+(section ;;; numbers
+
+(define (non-fixnum? x)
+  (record-case x
+    [(constant i) (not (fixnum? i))]
+    [else #f]))
+
+(define (or* a a*)
+  (cond
+    [(null? a*) a]
+    [else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
+
+(define (assert-fixnums a a*)
+  (interrupt-unless (tag-test (or* (T a) a*) fixnum-mask fixnum-tag)))
+
+(define (fold-p op a a*)
+  (cond
+    [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
+    [else
+     (seq*
+       (assert-fixnums a a*)
+       (let f ([a a] [a* a*])
+         (cond
+           [(null? a*) (K #t)]
+           [else
+            (let ([b (car a*)])
+              (make-conditional
+                (prm op (T a) (T b))
+                (f b (cdr a*))
+                (K #f)))])))]))
+
+(define (fold-e a a*)
+  (cond
+    [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
+    [else (assert-fixnums a a*)]))
+
+(define-primop = safe
+  [(P) (interrupt)]
+  [(P a . a*) (fold-p '= a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (fold-e a a*)])
+
+(define-primop < safe
+  [(P) (interrupt)]
+  [(P a . a*) (fold-p '< a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (fold-e a a*)])
+
+(define-primop <= safe
+  [(P) (interrupt)]
+  [(P a . a*) (fold-p '<= a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (fold-e a a*)])
+
+(define-primop > safe
+  [(P) (interrupt)]
+  [(P a . a*) (fold-p '> a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (fold-e a a*)])
+
+(define-primop >= safe
+  [(P) (interrupt)]
+  [(P a . a*) (fold-p '>= a a*)]
+  [(E) (interrupt)]
+  [(E a . a*) (fold-e a a*)])
+
+(define-primop - safe
+  [(V a) 
+   (cond
+     [(non-fixnum? a) (interrupt)]
+     [else
+      (seq*
+        (assert-fixnums a '())
+        (prm 'int-/overflow (K 0) (T a)))])]
+  [(V a . a*)
+   (cond
+     [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
+     [else
+      (seq*
+        (assert-fixnums a a*)
+        (let f ([a (T a)] [a* a*])
+          (cond
+            [(null? a*) a]
+            [else
+             (f (prm 'int-/overflow a (T (car a*))) (cdr a*))])))])]
+  [(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
+  [(E a . a*) (assert-fixnums a a*)])
+
+(define-primop + safe
+  [(V) (K 0)]
+  [(V a . a*)
+   (cond
+     [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
+     [else
+      (seq*
+        (assert-fixnums a a*)
+        (let f ([a (T a)] [a* a*])
+          (cond
+            [(null? a*) a]
+            [else
+             (f (prm 'int+/overflow a (T (car a*))) (cdr a*))])))])]
+  [(P) (K #t)]
+  [(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
+  [(E) (nop)]
+  [(E a . a*) (assert-fixnums a a*)])
+
+
+/section)
+
+(section ;;; records
+
+(define-primop $record? unsafe
+  [(P x) (sec-tag-test (T x) vector-mask vector-tag vector-mask vector-tag)]
+  [(E x) (nop)])
+
+#;(define-primop $record/rtd? unsafe
+  [(P x rtd)
+   (make-conditional
+     (tag-test (T x) vector-mask vector-tag)
+     (prm '= (prm 'mref (T x) (K (- vector-tag))) (T rtd))
+     (make-constant #f))]
+  [(E x rtd) (nop)])
+
+(define-primop $make-record unsafe
+  [(V rtd len)
+   (record-case len
+     [(constant i) 
+      (unless (fixnum? i) (interrupt))
+      (with-tmp ([t (prm 'alloc
+                         (K (align (+ (* i wordsize) disp-record-data)))
+                         (K vector-tag))])
+        (prm 'mset t (K (- disp-record-rtd vector-tag)) (T rtd))
+        t)]
+     [else
+      (with-tmp ([ln (align-code len disp-record-data)])
+        (with-tmp ([t (prm 'alloc ln (K vector-tag))])
+          (prm 'mset t (K (- disp-record-rtd vector-tag)) (T rtd))
+           t))])]
+  [(P rtd len) (K #t)]
+  [(E rtd len) (nop)])
+
+(define-primop $record-rtd unsafe
+  [(V x) 
+   (prm 'mref (T x) (K (- disp-record-rtd vector-tag)))]
+  [(E x) (nop)]
+  [(P x) #t])
+
+(define-primop $record-ref unsafe
+  [(V x i) (cogen-value-$vector-ref x i)]
+  [(E x i) (cogen-effect-$vector-ref x i)]
+  [(P x i) (cogen-pred-$vector-ref x i)])
+
+(define-primop $record-set! unsafe
+  [(V x i v) (cogen-value-$vector-set! x i v)]
+  [(E x i v) (cogen-effect-$vector-set! x i v)]
+  [(P x i v) (cogen-pred-$vector-set! x i v)])
+
+(define-primop $record unsafe
+  [(V rtd . v*)
+   (with-tmp ([t (prm 'alloc 
+                     (K (align
+                          (+ disp-record-data
+                            (* (length v*) wordsize))))
+                     (K vector-tag))])
+     (prm 'mset t (K (- disp-record-rtd vector-tag)) (T rtd))
+     (let f ([v* v*] 
+             [i (- disp-record-data vector-tag)])
+       (cond
+         [(null? v*) t]
+         [else
+          (make-seq 
+            (prm 'mset t (K i) (T (car v*)))
+            (f (cdr v*) (+ i wordsize)))])))]
+  [(P rtd . v*) (K #t)]
+  [(E rtd . v*) (nop)])
+
+/section)
+
+(section ;;; characters
+
+(define-primop char? safe
+  [(P x) (tag-test (T x) char-mask char-tag)]
+  [(E x) (nop)])
+
+(define-primop $char= unsafe
+  [(P x y) (prm '= (T x) (T y))]
+  [(E x y) (nop)])
+
+(define-primop $char< unsafe
+  [(P x y) (prm '< (T x) (T y))]
+  [(E x y) (nop)])
+
+(define-primop $char<= unsafe
+  [(P x y) (prm '<= (T x) (T y))]
+  [(E x y) (nop)])
+
+(define-primop $char> unsafe
+  [(P x y) (prm '> (T x) (T y))]
+  [(E x y) (nop)])
+
+(define-primop $char>= unsafe
+  [(P x y) (prm '>= (T x) (T y))]
+  [(E x y) (nop)])
+
+(define-primop $fixnum->char unsafe
+  [(V x) 
+   (prm 'logor
+        (prm 'sll (T x) (K (- char-shift fixnum-shift)))
+        (K char-tag))]
+  [(P x) (K #t)]
+  [(E x) (nop)])
+
+(define-primop $char->fixnum unsafe
+  [(V x) (prm 'sra (T x) (K (- char-shift fixnum-shift)))]
+  [(P x) (K #t)]
+  [(E x) (nop)])
+
+/section)
+
+(section ;;; strings
+         
+(define-primop string? safe
+  [(P x) (tag-test (T x) string-mask string-tag)]
+  [(E x) (nop)])
+
+(define-primop $make-string unsafe
+  [(V n)
+   (record-case n
+     [(constant n)
+      (unless (fixnum? n) (interrupt))
+      (with-tmp ([s (prm 'alloc 
+                      (K (align (+ n 1 disp-string-data)))
+                      (K string-tag))])
+         (prm 'mset s
+             (K (- disp-string-length string-tag))
+             (K (* n fixnum-scale)))
+         (prm 'bset/c s
+             (K (+ n (- disp-string-data string-tag)))
+             (K 0))
+         s)]
+     [else
+      (with-tmp ([s (prm 'alloc 
+                      (align-code 
+                        (prm 'sra (T n) (K fixnum-shift))
+                        (+ disp-string-data 1))
+                      (K string-tag))])
+          (prm 'mset s
+            (K (- disp-string-length string-tag))
+            (T n))
+          (prm 'bset/c s
+               (prm 'int+ 
+                    (prm 'sra (T n) (K fixnum-shift))
+                    (K (- disp-string-data string-tag)))
+               (K 0))
+          s)])]
+  [(P n) (K #t)]
+  [(E n) (nop)])
+
+(define-primop $string-length unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-string-length string-tag)))]
+  [(P x) (K #t)]
+  [(E x) (nop)])
+
+
+(define-primop $string-ref unsafe
+  [(V s i)
+   (record-case i
+     [(constant i)
+      (unless (fixnum? i) (interrupt))
+      (prm 'logor
+        (prm 'sll
+          (prm 'logand 
+             (prm 'mref (T s)
+               (K (+ i (- disp-string-data string-tag))))
+             (K 255))
+          (K char-shift))
+        (K char-tag))]
+     [else
+      (prm 'logor
+        (prm 'sll
+          (prm 'srl ;;; FIXME: bref
+             (prm 'mref (T s)
+                  (prm 'int+
+                     (prm 'sra (T i) (K fixnum-shift))
+                     ;;; ENDIANNESS DEPENDENCY
+                     (K (- disp-string-data 
+                           (- wordsize 1) 
+                           string-tag))))
+             (K (* (- wordsize 1) 8)))
+          (K char-shift))
+        (K char-tag))])]
+  [(P s i) (K #t)]
+  [(E s i) (nop)])
+
+(define (assert-fixnum x)
+  (record-case x
+    [(constant i) 
+     (if (fixnum? i) (nop) (interrupt))]
+    [else (interrupt-unless (cogen-pred-fixnum? x))]))
+
+(define (assert-string x)
+  (record-case x
+    [(constant s) (if (string? s) (nop) (interrupt))]
+    [else (interrupt-unless (cogen-pred-string? x))]))
+
+(define-primop string-ref safe
+  [(V s i)
+   (seq*
+     (assert-fixnum i)
+     (assert-string s)
+     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
+     (cogen-value-$string-ref s i))]
+  [(P s i)
+   (seq*
+     (assert-fixnum i)
+     (assert-string s)
+     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s)))
+     (K #t))]
+  [(E s i)
+   (seq*
+     (assert-fixnum i)
+     (assert-string s)
+     (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s))))])
+
+
+(define-primop $string-set! unsafe
+  [(E x i c)
+   (record-case i
+     [(constant i) 
+      (unless (fixnum? i) (interrupt))
+      (record-case c
+        [(constant c)
+         (unless (char? c) (interrupt))
+         (prm 'bset/c (T x) 
+              (K (+ i (- disp-string-data string-tag)))
+              (K (char->integer c)))]
+        [else
+         (unless (= char-shift 8) (error 'cogen-$string-set! "BUG"))
+         (prm 'bset/h (T x)
+               (K (+ i (- disp-string-data string-tag)))
+               (T c))])]
+     [else
+      (record-case c
+        [(constant c)
+         (unless (char? c) (interrupt))
+         (prm 'bset/c (T x) 
+              (prm 'int+ 
+                   (prm 'sra (T i) (K fixnum-shift))
+                   (K (- disp-string-data string-tag)))
+              (K (char->integer c)))]
+        [else
+         (unless (= char-shift 8) (error 'cogen-$string-set! "BUG"))
+         (prm 'bset/h (T x)
+               (prm 'int+ 
+                    (prm 'sra (T i) (K fixnum-shift))
+                    (K (- disp-string-data string-tag)))
+               (T c))])])])
+
+/section)
+
+(section ;;; ports
+
+(define-primop port? safe
+  [(P x) (sec-tag-test (T x) vector-mask vector-tag port-mask port-tag)]
+  [(E x) (nop)])
+
+(define-primop input-port? safe
+  [(P x) (sec-tag-test (T x) vector-mask vector-tag #f input-port-tag)]
+  [(E x) (nop)])
+
+(define-primop output-port? safe
+  [(P x) (sec-tag-test (T x) vector-mask vector-tag #f output-port-tag)]
+  [(E x) (nop)])
+
+(define (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o tag)
+  (with-tmp ([p (prm 'alloc (K (align port-size)) (K vector-tag))])
+    (prm 'mset p (K (- vector-tag)) (K tag))
+    (prm 'mset p (K (- disp-port-handler vector-tag)) (T handler))
+    (prm 'mset p (K (- disp-port-input-buffer vector-tag)) (T buf/i))
+    (prm 'mset p (K (- disp-port-input-index vector-tag)) (T idx/i))
+    (prm 'mset p (K (- disp-port-input-size vector-tag)) (T sz/i))
+    (prm 'mset p (K (- disp-port-output-buffer vector-tag)) (T buf/o))
+    (prm 'mset p (K (- disp-port-output-index vector-tag)) (T idx/o))
+    (prm 'mset p (K (- disp-port-output-size vector-tag)) (T sz/o))
+    p))
+
+(define-primop $make-port/input unsafe
+  [(V handler buf/i idx/i sz/i buf/o idx/o sz/o) 
+   (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o
+              input-port-tag)])
+(define-primop $make-port/output unsafe
+  [(V handler buf/i idx/i sz/i buf/o idx/o sz/o) 
+   (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o
+              output-port-tag)])
+(define-primop $make-port/both unsafe
+  [(V handler buf/i idx/i sz/i buf/o idx/o sz/o) 
+   (make-port handler buf/i idx/i sz/i buf/o idx/o sz/o
+              input/output-port-tag)])
+
+(define-primop $port-handler unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-port-handler vector-tag)))])
+(define-primop $port-input-buffer unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-port-input-buffer vector-tag)))])
+(define-primop $port-input-index unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-port-input-index vector-tag)))])
+(define-primop $port-input-size unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-port-input-size vector-tag)))])
+(define-primop $port-output-buffer unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-port-output-buffer vector-tag)))])
+(define-primop $port-output-index unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-port-output-index vector-tag)))])
+(define-primop $port-output-size unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-port-output-size vector-tag)))])
+
+(define-primop $set-port-input-index! unsafe
+  [(E x i) (prm 'mset (T x) (K (- disp-port-input-index vector-tag)) (T i))])
+(define-primop $set-port-output-index! unsafe
+  [(E x i) (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (T i))])
+
+(define-primop $set-port-input-size! unsafe
+  [(E x i) 
+   (seq*
+     (prm 'mset (T x) (K (- disp-port-input-index vector-tag)) (K 0))
+     (prm 'mset (T x) (K (- disp-port-input-size vector-tag)) (T i)))])
+(define-primop $set-port-output-size! unsafe
+  [(E x i) 
+   (seq*
+     (prm 'mset (T x) (K (- disp-port-output-index vector-tag)) (K 0))
+     (prm 'mset (T x) (K (- disp-port-output-size vector-tag)) (T i)))])
+
+
+
+/section)
+
+(section ;;; interrupts-and-engines
+
+(define-primop $interrupted? unsafe
+  [(P) (prm '!= (prm 'mref pcr (K 40)) (K 0))])
+
+(define-primop $unset-interrupted! unsafe
+  [(E) (prm 'mset pcr (K 40) (K 0))])
+
+/section)
+
+(section ;;; control operations
+
+(define-primop $fp-at-base unsafe
+  [(P) ;;; PCB FRAME-BASE
+   (prm '= (prm 'int+ (prm 'mref pcr (K 12)) (K (- wordsize))) fpr)])
+
+(define-primop $current-frame unsafe
+  [(V) (prm 'mref pcr (K 20))]) ;; PCB NEXT-CONTINUATION
+
+
+(define-primop $seal-frame-and-call unsafe
+  [(V x) ;;; PCB NEXT CONT;;; PCB BASE
+   (with-tmp ([k (prm 'alloc (K continuation-size) (K vector-tag))])
+     (with-tmp ([base (prm 'int+ (prm 'mref pcr (K 12)) (K (- wordsize)))])
+       (with-tmp ([underflow-handler (prm 'mref base (K 0))])
+         (prm 'mset k (K (- vector-tag)) (K continuation-tag))
+         (prm 'mset k (K (- disp-continuation-top vector-tag)) fpr)
+         (prm 'mset k (K (- disp-continuation-next vector-tag)) 
+              (prm 'mref pcr (K 20))) 
+         (prm 'mset k (K (- disp-continuation-size vector-tag)) (prm 'int- base fpr))
+         (prm 'mset pcr (K 20) k)
+         (prm 'mset pcr (K 12) fpr)
+         (prm '$call-with-underflow-handler underflow-handler (T x) k))))]
+  [(E . args) (interrupt)]
+  [(P . args) (interrupt)])
+
+(define-primop $frame->continuation unsafe
+  [(V x)
+   (with-tmp ([t (prm 'alloc
+                    (K (align (+ disp-closure-data wordsize)))
+                    (K closure-tag))])
+     (prm 'mset t (K (- disp-closure-code closure-tag))
+          (K (make-code-loc SL_continuation_code)))
+     (prm 'mset t (K (- disp-closure-data closure-tag))
+          (T x))
+     t)]
+  [(P x) (K #t)]
+  [(E x) (nop)])
+
+(define-primop $make-call-with-values-procedure unsafe
+  [(V) (K (make-closure (make-code-loc SL_call_with_values) '()))]
+  [(P) (interrupt)]
+  [(E) (interrupt)])
+
+(define-primop $make-values-procedure unsafe
+  [(V) (K (make-closure (make-code-loc SL_values) '()))]
+  [(P) (interrupt)]
+  [(E) (interrupt)])
+
+
+
+/section)
+
+(section ;;; hash table tcbuckets
+
+(define-primop $make-tcbucket unsafe
+  [(V tconc key val next)
+   (with-tmp ([x (prm 'alloc (K (align tcbucket-size)) (K vector-tag))])
+     (prm 'mset x (K (- disp-tcbucket-tconc vector-tag)) (T tconc))
+     (prm 'mset x (K (- disp-tcbucket-key vector-tag)) (T key))
+     (prm 'mset x (K (- disp-tcbucket-val vector-tag)) (T val))
+     (prm 'mset x (K (- disp-tcbucket-next vector-tag)) (T next))
+     x)])
+
+(define-primop $tcbucket-key unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-tcbucket-key vector-tag)))])
+(define-primop $tcbucket-val unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-tcbucket-val vector-tag)))])
+(define-primop $tcbucket-next unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-tcbucket-next vector-tag)))])
+
+(define-primop $set-tcbucket-key! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-tcbucket-key vector-tag))])
+(define-primop $set-tcbucket-val! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-tcbucket-val vector-tag))])
+(define-primop $set-tcbucket-next! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-tcbucket-next vector-tag))])
+(define-primop $set-tcbucket-tconc! unsafe
+  [(E x v) (mem-assign v (T x) (- disp-tcbucket-tconc vector-tag))])
+
+
+/section)
+
+(section ;;; codes
+
+(define-primop $code? unsafe
+  [(P x) (sec-tag-test (T x) vector-mask vector-tag #f code-tag)])
+
+(define-primop $closure-code unsafe
+  [(V x) 
+   (prm 'int+ 
+        (prm 'mref (T x) (K (- disp-closure-code closure-tag)))
+        (K (- vector-tag disp-code-data)))])
+
+(define-primop $code-freevars unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-code-freevars vector-tag)))])
+
+(define-primop $code-reloc-vector unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-code-relocsize vector-tag)))])
+
+(define-primop $code-size unsafe
+  [(V x) (prm 'mref (T x) (K (- disp-code-instrsize vector-tag)))])
+
+(define-primop $code->closure unsafe
+  [(V x) 
+   (with-tmp ([v (prm 'alloc
+                    (K (align (+ 0 disp-closure-data)))
+                    (K closure-tag))])
+     (prm 'mset v 
+          (K (- disp-closure-code closure-tag))
+          (prm 'int+ (T x) 
+            (K (- disp-code-data vector-tag))))
+     v)])
+
+(define-primop $code-ref unsafe
+  [(V x i) 
+   (prm 'sll
+     (prm 'logand
+          (prm 'mref (T x)
+               (prm 'int+
+                    (prm 'sra (T i) (K fixnum-shift))
+                    (K (- disp-code-data vector-tag))))
+          (K 255))
+     (K fixnum-shift))])
+
+(define-primop $code-set! unsafe
+  [(E x i v)
+   (prm 'bset/h (T x)
+        (prm 'int+ 
+             (prm 'sra (T i) (K fixnum-shift))
+             (K (- disp-code-data vector-tag)))
+        (prm 'sll (T v) (K (- 8 fixnum-shift))))])
+
+
+/section)
+
+#!eof
+
+
+         [($init-symbol-function!)
+          (tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
+            (seq*
+              (prm 'mset x (K (- disp-symbol-function symbol-tag)) v)
+              (prm 'mset x (K (- disp-symbol-error-function symbol-tag)) v)
+              (dirty-vector-set x)))]
+
+         [(zero?) 
+          (tbind ([x (Value (car arg*))])
+            (make-conditional
+              (tag-test x fixnum-mask fixnum-tag)
+              (prm '= x (K 0))
+              (prm '!=
+                   (make-funcall (Value (make-primref 'zero?)) (list x))
+                   (Value (K #f)))))]
+         [($procedure-check)
+          (tbind ([x (Value (car arg*))])
+            (make-shortcut
+              (make-seq
+                (make-conditional 
+                  (tag-test x closure-mask closure-tag)
+                  (prm 'nop)
+                  (prm 'interrupt))
+                x)
+              (Value 
+                (make-funcall (make-primref 'error)
+                  (list (make-constant 'apply)
+                        (make-constant "~s is not a procedure")
+                        x)))))]
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+(include "libprimops.ss")
+
+(define (specify-representation x)
+  (define who 'specify-representation)
+  ;;;
+  (define fixnum-scale 4)
+  (define fixnum-shift 2)
+  (define fixnum-tag 0)
+  (define fixnum-mask 3)
+  (define pcb-dirty-vector-offset 28)
+  ;;;
+  (define nop (make-primcall 'nop '()))
+  ;;;
+  (define (Effect x)
+       ]
+      [(forcall op arg*)
+       (make-forcall op (map Value arg*))]
+      [(funcall rator arg*)
+       (make-funcall (Function rator) (map Value arg*))]
+      [(jmpcall label rator arg*)
+       (make-jmpcall label (Value rator) (map Value arg*))]
+      [(mvcall rator x)
+       (make-mvcall (Value rator) (Clambda x Effect))]
+      [else (error who "invalid effect expr ~s" x)]))
+  ;;;
+  ;;;
+  ;;;
+  ;;;
+  ;;; value
+  ;;;
+  (define (ClambdaCase x k)
+    (record-case x
+      [(clambda-case info body)
+       (make-clambda-case info (k body))]
+      [else (error who "invalid clambda-case ~s" x)]))
+  ;;;
+  (define (Clambda x k)
+    (record-case x
+      [(clambda label case* free*)
+       (make-clambda label 
+          (map (lambda (x) (ClambdaCase x k)) case*)
+          free*)]
+      [else (error who "invalid clambda ~s" x)]))
+  ;;;
+  (define (error-codes)
+    (define (code-list symbol)
+      (define L1 (gensym))
+      (define L2 (gensym))
+      `(0
+        [movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
+        [andl ,closure-mask ,cp-register]
+        [cmpl ,closure-tag ,cp-register]
+        [jne (label ,L1)]
+        [movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
+        [movl ,cp-register (disp ,(- disp-symbol-function symbol-tag) (obj ,symbol))]
+        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
+        [label ,L1]
+        [movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) %eax]
+        [cmpl ,unbound %eax]
+        [je (label ,L2)]
+        [movl (obj apply) (disp -4 %esp)]
+        [movl (obj "~s is not a procedure") (disp -8 %esp)]
+        [movl %eax (disp -12 %esp)]
+        [movl (obj error) ,cp-register]
+        [movl (disp ,(- disp-symbol-system-value symbol-tag)
+                    ,cp-register) ,cp-register]
+        [movl ,(argc-convention 3) %eax]
+        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
+        [label ,L2]
+        [movl (obj ,symbol) (disp -4 %esp)]
+        [movl (obj top-level-value) ,cp-register]
+        [movl (disp ,(- disp-symbol-system-value symbol-tag)
+                    ,cp-register) ,cp-register]
+        [movl ,(argc-convention 1) %eax]
+        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]))
+    (let ([ls encountered-symbol-calls])
+      (let ([c* (map code-list ls)])
+        (let ([c* (list*->code* (lambda (x) #f) c*)])
+          (let ([p* (map (lambda (x) ($code->closure x)) c*)])
+            (let f ([ls ls] [p* p*])
+              (cond
+                [(null? ls) (prm 'nop)]
+                [else 
+                 (make-seq
+                   (tbind ([p (Value (K (car p*)))] [s (Value (K (car ls)))])
+                       (Effect (prm '$init-symbol-function! s p)))
+                   (f (cdr ls) (cdr p*)))])))))))
+  (define (Program x)
+    (record-case x 
+      [(codes code* body)
+       (let ([code* (map (lambda (x) (Clambda x Value)) code*)]
+             [body (Value body)])
+         (make-codes code*
+           (make-seq (error-codes) body)))]
+      [else (error who "invalid program ~s" x)]))
+  ;;;
+  ;(print-code x)
+  (Program x))
+
diff --git a/src/pass-specify-rep.ss b/src/pass-specify-rep.ss
new file mode 100644
index 0000000..14d9790
--- /dev/null
+++ b/src/pass-specify-rep.ss
@@ -0,0 +1,513 @@
+
+;(module primops (primop? cogen-primop)
+;  (define (primop? x) #f)
+;  (define cogen-primop (lambda args (error 'cogen-primop "not yet"))))
+;
+;#!eof
+
+(define-syntax export-all-module
+  (syntax-rules (define)
+    [(_ M (define name* v*) ...)
+     (module M (name* ...)
+       (define name* v*) ...)]))
+
+(export-all-module object-representation
+  (define fixnum-scale 4)
+  (define fixnum-shift 2)
+  (define fixnum-tag 0)
+  (define fixnum-mask 3))
+
+(module (specify-representation)
+  (import object-representation)
+  (define cookie (gensym))
+  (define (primop? x)
+    (and (getprop x cookie) #t))
+  (define-record PH
+    (interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?))
+  (define interrupt-handler
+    (make-parameter (lambda () (error 'interrupt-handler "uninitialized"))))
+  (define (interrupt) 
+    ((interrupt-handler))
+    (prm 'interrupt))
+  (define (with-interrupt-handler p x ctxt args k)
+    (cond
+      [(not (PH-interruptable? p))
+       (parameterize ([interrupt-handler 
+                       (lambda ()
+                         (error 'cogen "~s is uninterruptable" x))])
+          (k))]
+      [else
+       (let ([interrupted? #f])
+         (let ([body 
+                (parameterize ([interrupt-handler
+                                (lambda () (set! interrupted? #t))])
+                   (k))])
+           (cond
+             [(not interrupted?) body]
+             [(or (eq? ctxt 'V) (eq? ctxt 'E))
+              (make-shortcut body 
+                (make-funcall (V (K x)) args))]
+             [(eq? ctxt 'P)
+              (make-shortcut body
+                (prm '!=
+                     (make-funcall (V (K x)) args) 
+                     (K bool-f)))]
+             [else (error 'with-interrupt-handler "invalid context ~s" ctxt)])))]))
+  (define-syntax with-tmp
+    (lambda (x)
+      (syntax-case x ()
+        [(_ ([lhs* rhs*] ...) b b* ...)
+         (with-syntax ([(n* ...) (generate-temporaries #'(lhs* ...))])
+           #'(let ([lhs* rhs*] ...)
+               (let ([n* (unique-var 'lhs*)] ...)
+                 (make-bind (list n* ...) (list lhs* ...)
+                    (let ([lhs* n*] ...)
+                      (seq* b b* ...))))))])))
+  ;;; if ctxt is V:
+  ;;;   if cogen-value, then V
+  ;;;   if cogen-pred, then (if P #f #t)
+  ;;;   if cogen-effect, then (seq E (void))
+  ;;;
+  ;;; if ctxt is P:
+  ;;;   if cogen-pred, then P
+  ;;;   if cogen-value, then (!= V #f) 
+  ;;;   if cogen-effect, then (seq E #t)
+  ;;;
+  ;;; if ctxt is E:
+  ;;;   if cogen-effect, then E
+  ;;;   if cogen-value, then (let ([tmp V]) (nop))
+  ;;;   if cogen-pred, then (if P (nop) (nop))
+  (define (simplify* args k)
+    (define (S* ls)
+      (cond
+        [(null? ls) (values '() '() '())]
+        [else
+         (let-values ([(lhs* rhs* arg*) (S* (cdr ls))])
+           (let ([a (car ls)])
+             (cond
+               [(or (constant? a) (var? a)) 
+                (values lhs* rhs* (cons a arg*))]
+               [else
+                (let ([t (unique-var 'tmp)])
+                  (values (cons t lhs*) (cons (V a) rhs*) (cons t arg*)))])))]))
+    (let-values ([(lhs* rhs* args) (S* args)])
+      (cond
+        [(null? lhs*) (k args)]
+        [else
+         (make-bind lhs* rhs* (k args))])))
+
+  (define (cogen-primop x ctxt args)
+    (cond
+      [(getprop x cookie) => 
+       (lambda (p) 
+         (simplify* args
+           (lambda (args)
+             (with-interrupt-handler p x ctxt (map T args)
+               (lambda ()
+                 (case ctxt
+                   [(P) 
+                    (cond
+                      [(PH-p-handled? p) 
+                       (apply (PH-p-handler p) args)]
+                      [(PH-v-handled? p)
+                       (prm '!= 
+                            (apply (PH-v-handler p) args) 
+                            (K bool-f))]
+                      [(PH-e-handled? p)
+                       (make-seq (apply (PH-e-handler p) args) (K #t))]
+                      [else (error 'cogen-primop "~s is not handled" x)])]
+                   [(V) 
+                    (cond
+                      [(PH-v-handled? p) 
+                       (apply (PH-v-handler p) args)]
+                      [(PH-p-handled? p) 
+                       (make-conditional
+                         (apply (PH-p-handler p) args) 
+                         (K bool-t)
+                         (K bool-f))]
+                      [(PH-e-handled? p)
+                       (make-seq (apply (PH-e-handler p) args) (K void-object))]
+                      [else (error 'cogen-primop "~s is not handled" x)])]
+                   [(E) 
+                    (cond
+                      [(PH-e-handled? p) 
+                       (apply (PH-e-handler p) args)]
+                      [(PH-p-handled? p) 
+                       (make-conditional
+                         (apply (PH-p-handler p) args) 
+                         (prm 'nop)
+                         (prm 'nop))]
+                      [(PH-v-handled? p)
+                       (with-tmp ([t (apply (PH-v-handler p) args)])
+                         (prm 'nop))]
+                      [else (error 'cogen-primop "~s is not handled" x)])]
+                   [else (error 'cogen-primop "invalid context ~s"
+                                ctxt)]))))))]
+      [else (error 'cogen-primop "~s is not a prim" x)]))
+  
+  (define-syntax define-primop
+    (lambda (x)
+      (define (cogen-name stx name suffix)
+        (datum->syntax-object stx
+          (string->symbol
+            (format "cogen-~a-~a" suffix 
+                    (syntax-object->datum name)))))
+      (define (generate-handler name ctxt case*)
+        (define (filter-cases case*)
+          (syntax-case case* ()
+            [() '()]
+            [([(c . arg*) b b* ...] . rest)
+             (free-identifier=? #'c ctxt)
+             (cons #'[arg* b b* ...] (filter-cases #'rest))]
+            [(c . rest) (filter-cases #'rest)]))
+        (let ([case* (filter-cases case*)])
+          (with-syntax ([ctxt ctxt] [name name]
+                        [(case* ...) case*]
+                        [handled? (not (null? case*))])
+            #'[(case-lambda 
+                 case* ...
+                 [args (interrupt)])
+               handled?])))
+      (syntax-case x ()
+        [(_ name int? case* ...) 
+         (with-syntax ([cogen-p (cogen-name #'_ #'name "pred")]
+                       [cogen-e (cogen-name #'_ #'name "effect")]
+                       [cogen-v (cogen-name #'_ #'name "value")]
+                       [interruptable?
+                        (syntax-case #'int? (safe unsafe)
+                          [safe   #t] [unsafe #f])]
+                       [(p-handler phandled?) 
+                        (generate-handler #'name #'P #'(case* ...))]
+                       [(v-handler vhandled?)
+                        (generate-handler #'name #'V #'(case* ...))]
+                       [(e-handler ehandled?) 
+                        (generate-handler #'name #'E #'(case* ...))])
+           #'(begin
+               (define cogen-p p-handler)
+               (define cogen-v v-handler)
+               (define cogen-e e-handler)
+               (module ()
+                 (putprop 'name cookie 
+                    (make-PH interruptable? 
+                       cogen-p phandled? 
+                       cogen-v vhandled?
+                       cogen-e ehandled?)))))])))
+
+
+  (define (handle-fix lhs* rhs* body)
+    (define (closure-size x)
+      (record-case x
+        [(closure code free*) 
+         (if (null? free*) 
+             0
+             (align (+ disp-closure-data
+                       (* (length free*) wordsize))))]))
+    (define (partition p? lhs* rhs*)
+      (cond
+        [(null? lhs*) (values '() '() '() '())]
+        [else
+         (let-values ([(a* b* c* d*)
+                       (partition p? (cdr lhs*) (cdr rhs*))]
+                      [(x y) (values (car lhs*) (car rhs*))])
+           (cond
+             [(p? x y)
+              (values (cons x a*) (cons y b*) c* d*)]
+             [else 
+              (values a* b* (cons x c*) (cons y d*))]))]))
+    (define (combinator? lhs rhs)
+      (record-case rhs
+        [(closure code free*) (null? free*)]))
+    (define (sum n* n)
+      (cond
+        [(null? n*) n]
+        [else (sum (cdr n*) (+ n (car n*)))]))
+    (define (adders lhs n n*)
+      (cond
+        [(null? n*) '()]
+        [else
+         (cons (prm 'int+ lhs (K n))
+               (adders lhs (+ n (car n*)) (cdr n*)))]))
+    (define (build-closures lhs* rhs* body)
+      (let ([lhs (car lhs*)] [rhs (car rhs*)]
+            [lhs* (cdr lhs*)] [rhs* (cdr rhs*)])
+        (let ([n (closure-size rhs)] 
+              [n* (map closure-size rhs*)])
+          (make-bind (list lhs) 
+                     (list (prm 'alloc 
+                                (K (sum n* n))
+                                (K closure-tag)))
+            (make-bind lhs* (adders lhs n n*)
+              body)))))
+    (define (build-setters lhs* rhs* body)
+      (define (build-setter lhs rhs body)
+        (record-case rhs
+          [(closure code free*) 
+           (make-seq
+             (prm 'mset lhs 
+                  (K (- disp-closure-code closure-tag))
+                  (V code))
+             (let f ([ls free*] 
+                     [i (- disp-closure-data closure-tag)])
+               (cond
+                 [(null? ls) body]
+                 [else
+                  (make-seq
+                    (prm 'mset lhs (K i) (V (car ls)))
+                    (f (cdr ls) (+ i wordsize)))])))]))
+      (cond
+        [(null? lhs*) body]
+        [else
+         (build-setter (car lhs*) (car rhs*)
+           (build-setters (cdr lhs*) (cdr rhs*) body))]))
+    (let-values ([(flhs* frhs* clhs* crhs*)
+                  (partition combinator? lhs* rhs*)])
+      (cond
+        [(null? clhs*) (make-bind flhs* (map V frhs*) body)]
+        [(null? flhs*)
+         (build-closures clhs* crhs*
+            (build-setters clhs* crhs* body))]
+        [else
+         (make-bind flhs* (map V frhs*)
+           (build-closures clhs* crhs*
+             (build-setters clhs* crhs* body)))])))
+
+  (define (constant-rep x)
+    (let ([c (constant-value x)])
+      (cond
+        [(fixnum? c) (make-constant (* c fixnum-scale))]
+        [(boolean? c) (make-constant (if c bool-t bool-f))]
+        [(eq? c (void)) (make-constant void-object)]
+        [(bwp-object? c) (make-constant bwp-object)]
+        [(char? c) (make-constant 
+                     (fxlogor char-tag
+                       (fxsll (char->integer c) char-shift)))]
+        [(null? c) (make-constant nil)]
+        [(object? c) (error 'constant-rep "double-wrap")]
+        [else (make-constant (make-object c))])))
+
+  (define (V x)
+    (record-case x
+      [(constant) (constant-rep x)]
+      [(var)      x]
+      [(primref name)  
+       (prm 'mref
+             (K (make-object name))
+             (K (- disp-symbol-system-value symbol-tag)))]
+      [(code-loc) (make-constant x)]
+      [(closure)  (make-constant x)]
+      [(bind lhs* rhs* body)
+       (make-bind lhs* (map V rhs*) (V body))]
+      [(fix lhs* rhs* body) 
+       (handle-fix lhs* rhs* (V body))]
+      [(conditional e0 e1 e2) 
+       (make-conditional (P e0) (V e1) (V e2))]
+      [(seq e0 e1)
+       (make-seq (E e0) (V e1))]
+      [(primcall op arg*)
+       (cogen-primop op 'V arg*)]
+      [(forcall op arg*)
+       (make-forcall op (map V arg*))]
+      [(funcall rator arg*)
+       (make-funcall (Function rator) (map V arg*))]
+      [(jmpcall label rator arg*)
+       (make-jmpcall label (V rator) (map V arg*))]
+      [else (error 'cogen-V "invalid value expr ~s" x)])) 
+
+  (define (P x)
+    (record-case x
+      [(constant) x]
+      [(bind lhs* rhs* body)
+       (make-bind lhs* (map V rhs*) (P body))]
+      [(conditional e0 e1 e2) 
+       (make-conditional (P e0) (P e1) (P e2))]
+      [(seq e0 e1)
+       (make-seq (E e0) (P e1))]
+      [(fix lhs* rhs* body) 
+       (handle-fix lhs* rhs* (P body))]
+      [(primcall op arg*)
+       (cogen-primop op 'P arg*)]
+      [else (error 'cogen-P "invalid pred expr ~s" x)])) 
+  
+  (define (E x)
+    (record-case x
+      [(bind lhs* rhs* body)
+       (make-bind lhs* (map V rhs*) (E body))]
+      [(conditional e0 e1 e2) 
+       (make-conditional (P e0) (E e1) (E e2))]
+      [(seq e0 e1)
+       (make-seq (E e0) (E e1))]
+      [(fix lhs* rhs* body) 
+       (handle-fix lhs* rhs* (E body))]
+      [(primcall op arg*)
+       (cogen-primop op 'E arg*)]
+      [(forcall op arg*)
+       (make-forcall op (map V arg*))]
+      [(funcall rator arg*)
+       (make-funcall (Function rator) (map V arg*))]
+      [(jmpcall label rator arg*)
+       (make-jmpcall label (V rator) (map V arg*))]
+      [else (error 'cogen-E "invalid effect expr ~s" x)]))
+
+  (define (Function x)
+    (define (nonproc x)
+      (with-tmp ([x (V x)])
+        (make-shortcut
+          (make-seq
+            (make-conditional
+              (tag-test x closure-mask closure-tag)
+              (prm 'nop)
+              (prm 'interrupt))
+            x)
+          (V (make-funcall (make-primref 'error)
+               (list (K 'apply) (K "~s is not a procedure") x))))))
+    (record-case x
+       [(primcall op args)
+        (cond
+          [(and (eq? op 'top-level-value)
+                (= (length args) 1)
+                (record-case (car args)
+                  [(constant t) 
+                   (and (symbol? t) t)]
+                  [else #f])) =>
+           (lambda (sym)
+             (record-symbol-call! sym)
+             (prm 'mref (T (K sym))
+                  (K (- disp-symbol-function symbol-tag))))]
+          [else (nonproc x)])]
+       [(primref op) (V x)]
+       [else (nonproc x)]))
+
+
+  (define encountered-symbol-calls '())
+  (define (record-symbol-call! x)
+    (unless (memq x encountered-symbol-calls)
+      (set! encountered-symbol-calls 
+        (cons x encountered-symbol-calls))))
+
+
+  ;;;========================================================================
+  ;;;
+  (define (interrupt-unless x)
+    (make-conditional x (prm 'nop) (interrupt))) 
+  (define (interrupt-when x)
+    (make-conditional x (interrupt) (prm 'nop))) 
+  (define (interrupt-unless-fixnum x)
+    (interrupt-unless (tag-test x fixnum-mask fixnum-tag)))
+
+
+  (define (T x)
+    (record-case x
+      [(var) x]
+      [(constant i) (constant-rep x)]
+      [else (error 'cogen-T "invalid ~s" (unparse x))]))
+
+  (define (ClambdaCase x)
+    (record-case x
+      [(clambda-case info body)
+       (make-clambda-case info (V body))]
+      [else (error 'specify-rep "invalid clambda-case ~s" x)]))
+  ;;;
+  (define (Clambda x)
+    (record-case x
+      [(clambda label case* free*)
+       (make-clambda label 
+          (map ClambdaCase case*)
+          free*)]
+      [else (error 'specify-rep "invalid clambda ~s" x)]))
+  ;;;
+  (define (error-codes)
+    (define (code-list symbol)
+      (define L1 (gensym))
+      (define L2 (gensym))
+      `(0
+        [movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
+        [andl ,closure-mask ,cp-register]
+        [cmpl ,closure-tag ,cp-register]
+        [jne (label ,L1)]
+        [movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) ,cp-register]
+        [movl ,cp-register (disp ,(- disp-symbol-function symbol-tag) (obj ,symbol))]
+        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
+        [label ,L1]
+        [movl (disp ,(- disp-symbol-value symbol-tag) (obj ,symbol)) %eax]
+        [cmpl ,unbound %eax]
+        [je (label ,L2)]
+        [movl (obj apply) (disp -4 %esp)]
+        [movl (obj "~s is not a procedure") (disp -8 %esp)]
+        [movl %eax (disp -12 %esp)]
+        [movl (obj error) ,cp-register]
+        [movl (disp ,(- disp-symbol-system-value symbol-tag)
+                    ,cp-register) ,cp-register]
+        [movl ,(argc-convention 3) %eax]
+        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]
+        [label ,L2]
+        [movl (obj ,symbol) (disp -4 %esp)]
+        [movl (obj top-level-value) ,cp-register]
+        [movl (disp ,(- disp-symbol-system-value symbol-tag)
+                    ,cp-register) ,cp-register]
+        [movl ,(argc-convention 1) %eax]
+        [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)]))
+    (let ([ls encountered-symbol-calls])
+      (let ([c* (map code-list ls)])
+        (let ([c* (list*->code* (lambda (x) #f) c*)])
+          (let ([p* (map (lambda (x) ($code->closure x)) c*)])
+            (let f ([ls ls] [p* p*])
+              (cond
+                [(null? ls) (prm 'nop)]
+                [else 
+                 (make-seq
+                   (with-tmp ([p (V (K (car p*)))] [s (V (K (car ls)))])
+                     (E (prm '$init-symbol-function! s p)))
+                   (f (cdr ls) (cdr p*)))])))))))
+  (define (Program x)
+    (record-case x 
+      [(codes code* body)
+       (let ([code* (map Clambda code*)]
+             [body (V body)])
+         (make-codes code*
+           (make-seq (error-codes) body)))]
+      [else (error 'specify-rep "invalid program ~s" x)]))
+
+  (define (specify-representation x)
+    (Program x))
+
+
+
+  (include "pass-specify-rep-primops.ss")
+
+  )
+
+
+#!eof
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+  ;;;
+  (define (sec-tag-test x pmask ptag smask stag)
+    (tbind ([t x])
+      (make-conditional 
+        (tag-test t pmask ptag)
+        (tag-test (prm 'mref t (K (- ptag))) smask stag)
+        (make-constant #f))))
+  ;;;
+  ;;;
+  ;;;
+  (define encountered-symbol-calls '())
+  ;;; value
+  ;;;
+