diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index 0d7e57b..2f13c65 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -24,7 +24,8 @@ EXTRA_DIST=ikarus.boot.prebuilt ikarus.enumerations.ss \
   psyntax.internal.ss psyntax.library-manager.ss \
   unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
-  ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss
+  ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
+  ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss
  
 all: $(nodist_pkglib_DATA)
 
diff --git a/scheme/Makefile.in b/scheme/Makefile.in
index 8e74c84..32bdea9 100644
--- a/scheme/Makefile.in
+++ b/scheme/Makefile.in
@@ -178,7 +178,8 @@ EXTRA_DIST = ikarus.boot.prebuilt ikarus.enumerations.ss \
   psyntax.internal.ss psyntax.library-manager.ss \
   unicode/unicode-char-cases.ss unicode/unicode-charinfo.ss \
   ikarus.io.ss ikarus.time-and-date.ss ikarus.not-yet-implemented.ss \
-  ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss
+  ikarus.string-to-number.ss ikarus.compiler.source-optimizer.ss \
+  ikarus.compiler.tag-annotation-analysis.ss ikarus.ontology.ss
 
 revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)"
 CLEANFILES = $(nodist_pkglib_DATA) ikarus.config.ss
diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt
index a2f3ecf..cdc4609 100644
Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ
diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss
index d8e12cf..d531a83 100644
--- a/scheme/ikarus.compiler.altcogen.ss
+++ b/scheme/ikarus.compiler.altcogen.ss
@@ -67,6 +67,13 @@
   (define (mkfuncall op arg*)
     (import primops)
     (struct-case op
+      [(known x t)
+       (struct-case x
+         [(primref name)
+          (if (primop? name)
+              (make-primcall name arg*)
+              (make-funcall op arg*))]
+         [else (make-funcall op arg*)])]
       [(primref name)
        (cond
          [(primop? name)
@@ -74,6 +81,10 @@
          [else (make-funcall op arg*)])]
       [else (make-funcall op arg*)]))
   ;;;
+  (define (A x)
+    (struct-case x
+      [(known x t) (make-known (Expr x) t)]
+      [else (Expr x)]))
   (define (Expr x)
     (struct-case x
       [(constant) x]
@@ -91,11 +102,9 @@
       [(forcall op arg*)
        (make-forcall op (map Expr arg*))]
       [(funcall rator arg*)
-       (mkfuncall (Expr rator) (map Expr arg*))]
+       (mkfuncall (A rator) (map A arg*))]
       [(jmpcall label rator arg*)
        (make-jmpcall label (Expr rator) (map Expr arg*))]
-      [(mvcall rator k)
-       (make-mvcall (Expr rator) (Clambda k))]
       [else (error who "invalid expr" x)]))
   ;;;
   (define (ClambdaCase x)
@@ -142,6 +151,10 @@
           [(closure code free* well-known?) 
            (make-closure code (map Var free*) well-known?)]))
       (make-fix lhs* (map handle-closure rhs*) body))
+    (define (A x)
+      (struct-case x
+        [(known x t) (make-known (Expr x) t)]
+        [else (Expr x)]))
     (define (Expr x)
       (struct-case x
         [(constant) x]
@@ -159,15 +172,13 @@
          (let ([t (unique-var 'tmp)])
            (Expr (make-fix (list t) (list x) t)))]
         [(primcall op arg*)
-         (make-primcall op (map Expr arg*))]
+         (make-primcall op (map A arg*))]
         [(forcall op arg*)
          (make-forcall op (map Expr arg*))]
         [(funcall rator arg*)
-         (make-funcall (Expr rator) (map Expr arg*))]
+         (make-funcall (A rator) (map A arg*))]
         [(jmpcall label rator arg*)
          (make-jmpcall label (Expr rator) (map Expr arg*))]
-        [(mvcall rator k)
-         (make-mvcall (Expr rator) (Clambda k))]
         [else (error who "invalid expr" x)]))
     Expr)
   ;;;
@@ -208,20 +219,28 @@
 
 (define (insert-engine-checks x)
   (define who 'insert-engine-checks)
+  (define (known-primref? x)
+    (struct-case x
+      [(known x t) (known-primref? x)]
+      [(primref)   #t]
+      [else #f]))
+  (define (A x)
+    (struct-case x
+      [(known x t) (Expr x)]
+      [else (Expr x)]))
   (define (Expr x) 
     (struct-case x
       [(constant)                 #f]
       [(var)                      #f]
       [(primref)                  #f]
       [(jmpcall label rator arg*) #t]
-      [(mvcall rator k)           #t] 
       [(funcall rator arg*)
-       (if (primref? rator) (ormap Expr arg*) #t)]
+       (if (known-primref? rator) (ormap A arg*) #t)]
       [(bind lhs* rhs* body)      (or (ormap Expr rhs*) (Expr body))]
       [(fix lhs* rhs* body)       (Expr body)]
       [(conditional e0 e1 e2)     (or (Expr e0) (Expr e1) (Expr e2))]
       [(seq e0 e1)                (or (Expr e0) (Expr e1))]
-      [(primcall op arg*)         (ormap Expr arg*)]
+      [(primcall op arg*)         (ormap A arg*)]
       [(forcall op arg*)          (ormap Expr arg*)]
       [else (error who "invalid expr" x)]))
   (define (Main x)
@@ -245,6 +264,10 @@
 
 (define (insert-stack-overflow-check x)
   (define who 'insert-stack-overflow-check)
+  (define (A x)
+    (struct-case x
+      [(known x t) (NonTail x)]
+      [else (NonTail x)]))
   (define (NonTail x)
     (struct-case x
       [(constant)                 #f]
@@ -257,8 +280,9 @@
       [(fix lhs* rhs* body)   (NonTail body)]
       [(conditional e0 e1 e2) (or (NonTail e0) (NonTail e1) (NonTail e2))]
       [(seq e0 e1)            (or (NonTail e0) (NonTail e1))]
-      [(primcall op arg*)     (ormap NonTail arg*)]
+      [(primcall op arg*)     (ormap A arg*)]
       [(forcall op arg*)      (ormap NonTail arg*)]
+      [(known x t v) (NonTail x)]
       [else (error who "invalid expr" x)]))
   (define (Tail x) 
     (struct-case x
@@ -295,58 +319,6 @@
        (make-codes (map Clambda code*) (Main body))]))
   (Program x))
 
-
-
-(define (insert-dummy-type-annotations x)
-  (define who 'insert-dummy-type-annotations)
-  (define (Closure x)
-    (struct-case x
-      [(closure code free*) 
-       x]
-       ;(make-closure (Expr code) (map Var free*))]
-      [else (error who "not a closure" x)]))
-  (define (Expr x)
-    (struct-case x
-      [(constant i) 
-       (make-known x 'constant i)]
-      [(var)      x]
-      [(primref op) 
-       (make-known x 'primitive op)]
-      [(bind lhs* rhs* body)
-       (make-bind lhs* (map Expr rhs*) (Expr body))]
-      [(fix lhs* rhs* body)
-       (make-fix lhs* (map Closure rhs*) (Expr body))]
-      [(conditional e0 e1 e2)
-       (make-conditional (Expr e0) (Expr e1) (Expr e2))]
-      [(seq e0 e1)
-       (make-seq (Expr e0) (Expr e1))]
-      [(primcall op arg*)         
-       (make-primcall op (map Expr arg*))]
-      [(forcall op arg*)
-       (make-forcall op (map Expr arg*))]
-      [(funcall rator arg*)
-       (make-funcall (Expr rator) (map Expr arg*))]
-      [(jmpcall label rator arg*) 
-       (make-jmpcall label (Expr rator) (map Expr arg*))]
-      [(mvcall rator k)
-       (make-mvcall (Expr rator) (Expr k))]
-      [else (error who "invalid expr" x)]))
-  (define (ClambdaCase x)
-    (struct-case x
-      [(clambda-case info body)
-       (make-clambda-case info (Expr body))]))
-  (define (Clambda x)
-    (struct-case x
-      [(clambda label case* cp free* name)
-       (make-clambda label (map ClambdaCase case*) cp free* name)]))
-  (define (Program x)
-    (struct-case x 
-      [(codes code* body)
-       (make-codes (map Clambda code*) (Expr body))]))
-  (Program x))
-
-
-
 (include "pass-specify-rep.ss")
 
 (define parameter-registers '(%edi)) 
@@ -392,6 +364,7 @@
        (do-bind lhs* rhs* (S body k))]
       [(seq e0 e1)
        (make-seq (E e0) (S e1 k))]
+      [(known x) (S x k)]
       [else
        (cond
          [(or (constant? x) (symbol? x)) (k x)]
@@ -604,6 +577,7 @@
        (make-shortcut 
           (V d body)
           (V d handler))] 
+      [(known x) (V d x)]
       [else 
        (if (symbol? x) 
            (make-set d x)
@@ -3012,7 +2986,6 @@
          [x (eliminate-fix x)]
          [x (insert-engine-checks x)]
          [x (insert-stack-overflow-check x)]
-         ;[x (insert-dummy-type-annotations x)]
          [x (specify-representation x)]
          [x (impose-calling-convention/evaluation-order x)]
          [x (time-it "frame" (lambda () (assign-frame-sizes x)))]
diff --git a/scheme/ikarus.compiler.source-optimizer.ss b/scheme/ikarus.compiler.source-optimizer.ss
index 77e4232..cf2907f 100644
--- a/scheme/ikarus.compiler.source-optimizer.ss
+++ b/scheme/ikarus.compiler.source-optimizer.ss
@@ -106,9 +106,6 @@
 
   (define cp0-effort-limit (make-parameter 50))
   (define cp0-size-limit (make-parameter 8))
-  ;(define cp0-effort-limit (make-parameter 100))
-  ;(define cp0-size-limit (make-parameter 10))
-
 
   (define primitive-info-list
     '(
diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index f79b699..3f3da35 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -19,7 +19,8 @@
           assembler-output optimize-cp
           current-primitive-locations eval-core
           compile-core-expr expand/optimize optimizer-output
-          cp0-effort-limit cp0-size-limit optimize-level)
+          cp0-effort-limit cp0-size-limit optimize-level 
+          perform-tag-analysis tag-analysis-output)
   (import 
     (rnrs hashtables)
     (ikarus system $fx)
@@ -32,7 +33,8 @@
         compile-core-expr-to-port assembler-output
         current-primitive-locations eval-core
         cp0-size-limit cp0-effort-limit 
-        expand/optimize optimizer-output)
+        expand/optimize optimizer-output
+        tag-analysis-output perform-tag-analysis)
     (ikarus.fasl.write)
     (ikarus.intel-assembler))
 
@@ -139,7 +141,7 @@
 (define-struct assign (lhs rhs))
 (define-struct mvcall (producer consumer))
 
-(define-struct known (expr type value))
+(define-struct known (expr type))
 
 (define-struct shortcut (body handler))
 
@@ -440,9 +442,10 @@
   (define (E x)
     (struct-case x
       [(constant c) `(quote ,c)]
+      [(known x t) `(known ,(E x) ,(T:description t))]
       [(code-loc x) `(code-loc ,x)]
       [(var x) (string->symbol (format ":~a" x))]
-      [(prelex name) (string->symbol (format ":~a" x))]
+      [(prelex name) (string->symbol (format ":~a" name))]
       [(primref x) x]
       [(conditional test conseq altern) 
        `(if ,(E test) ,(E conseq) ,(E altern))]
@@ -1121,6 +1124,8 @@
       [else (error who "invalid expression" (unparse x))]))
   (Expr x))
 
+(include "ikarus.compiler.tag-annotation-analysis.ss")
+
 (define (introduce-vars x)
   (define who 'introduce-vars)
   (define (lookup x)
@@ -1134,6 +1139,10 @@
       (set-var-global-loc! v (prelex-global-location x))
       (set-prelex-operand! x v)
       v))
+  (define (A x)
+    (struct-case x
+      [(known x t) (make-known (E x) t)]
+      [else (E x)]))
   (define (E x)
     (struct-case x
       [(constant) x]
@@ -1163,9 +1172,9 @@
            cls*)
          cp free name)]
       [(primcall rator rand*)
-       (make-primcall rator (map E rand*))]
+       (make-primcall rator (map A rand*))]
       [(funcall rator rand*)
-       (make-funcall (E rator) (map E rand*))]
+       (make-funcall (A rator) (map A rand*))]
       [(forcall rator rand*) (make-forcall rator (map E rand*))]
       [(assign lhs rhs)
        (make-assign (lookup lhs) (E rhs))]
@@ -1192,6 +1201,10 @@
     (if (null? lhs*) 
         (Expr body)
         (make-fix lhs* (map CLambda rhs*) (Expr body))))
+  (define (A x)
+    (struct-case x
+      [(known x t) (make-known (Expr x) t)]
+      [else (Expr x)]))
   (define (Expr x)
     (struct-case x
       [(constant) x]
@@ -1217,12 +1230,22 @@
       [(forcall op rand*)
        (make-forcall op (map Expr rand*))]
       [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
+       (make-funcall (A rator) (map A rand*))]
       [(mvcall p c) (make-mvcall (Expr p) (Expr c))]
       [else (error who "invalid expression" (unparse x))]))
   (Expr x))
 
 
+(define (untag x)
+  (struct-case x 
+    [(known x t) (values x t)]
+    [else        (values x #f)]))
+
+(define (tag x t)
+  (if t
+      (make-known x t)
+      x))
+
 (define (optimize-for-direct-jumps x)
   (define who 'optimize-for-direct-jumps)
   (define (init-var x)
@@ -1252,20 +1275,24 @@
                  (cond
                    [proper
                     (if (fx= n (length fml*))
-                        (make-jmpcall label rator rand*)
+                        (make-jmpcall label (strip rator) (map strip rand*))
                         (f (cdr cls*)))]
                    [else
                     (if (fx<= (length (cdr fml*)) n)
-                        (make-jmpcall label rator
+                        (make-jmpcall label (strip rator)
                            (let f ([fml* (cdr fml*)] [rand* rand*])
                              (cond
                                [(null? fml*) 
                                 ;;; FIXME: construct list afterwards
                                 (list (make-funcall (make-primref 'list) rand*))]
                                [else
-                                (cons (car rand*)
+                                (cons (strip (car rand*))
                                       (f (cdr fml*) (cdr rand*)))])))
                         (f (cdr cls*)))])])]))])))
+  (define (strip x)
+    (struct-case x
+      [(known x t) x]
+      [else x]))
   (define (CLambda x)
     (struct-case x
       [(clambda g cls* cp free name) 
@@ -1277,6 +1304,14 @@
                    (make-clambda-case info (Expr body))]))
               cls*)
          cp free name)]))
+  (define (A x)
+    (struct-case x
+      [(known x t) (make-known (Expr x) t)]
+      [else (Expr x)]))
+  (define (A- x)
+    (struct-case x
+      [(known x t) (Expr x)]
+      [else (Expr x)])) 
   (define (Expr x)
     (struct-case x
       [(constant) x]
@@ -1296,19 +1331,18 @@
       [(forcall op rand*)
        (make-forcall op (map Expr rand*))]
       [(funcall rator rand*)
-       (let ([rator (Expr rator)])
+       (let-values ([(rator t) (untag (A rator))])
          (cond
            [(and (var? rator) (bound-var rator)) =>
             (lambda (c)
-              (optimize c rator (map Expr rand*)))]
+              (optimize c rator (map A rand*)))]
            [(and (primref? rator)
                  (eq? (primref-name rator) '$$apply))
-            (make-jmpcall (sl-apply-label) 
-                          (Expr (car rand*))
-                          (map Expr (cdr rand*)))]
+            (make-jmpcall (sl-apply-label)
+                          (A- (car rand*))
+                          (map A- (cdr rand*)))]
            [else
-            (make-funcall rator (map Expr rand*))]))]
-      [(mvcall p c) (make-mvcall (Expr p) (Expr c))]
+            (make-funcall (tag rator t) (map A rand*))]))]
       [else (error who "invalid expression" (unparse x))]))
   (Expr x))
 
@@ -1335,6 +1369,10 @@
              (list (make-constant loc) (car lhs*)))
            (global-assign (cdr lhs*) body)))]
       [else (global-assign (cdr lhs*) body)]))
+  (define (A x)
+    (struct-case x
+      [(known x t) (make-known (Expr x) t)]
+      [else (Expr x)]))
   (define (Expr x)
     (struct-case x
       [(constant) x]
@@ -1367,11 +1405,14 @@
       [(forcall op rand*)
        (make-forcall op (map Expr rand*))]
       [(funcall rator rand*)
-       (make-funcall (Expr rator) (map Expr rand*))]
-      [(mvcall p c) (make-mvcall (Expr p) (Expr c))]
+       (make-funcall (A rator) (map A rand*))]
       [(jmpcall label rator rand*)
        (make-jmpcall label (Expr rator) (map Expr rand*))]
       [else (error who "invalid expression" (unparse x))]))
+  (define (AM x)
+    (struct-case x
+      [(known x t) (make-known (Main x) t)]
+      [else (Main x)]))
   (define (Main x)
     (struct-case x
       [(constant) x]
@@ -1397,8 +1438,7 @@
       [(forcall op rand*)
        (make-forcall op (map Main rand*))]
       [(funcall rator rand*)
-       (make-funcall (Main rator) (map Main rand*))]
-      [(mvcall p c) (make-mvcall (Main p) (Main c))]
+       (make-funcall (AM rator) (map AM rand*))]
       [(jmpcall label rator rand*)
        (make-jmpcall label (Main rator) (map Main rand*))]
       [else (error who "invalid expression" (unparse x))]))
@@ -1448,6 +1488,19 @@
               free
               #f)
             free))]))
+  (define (A x)
+    (struct-case x
+      [(known x t) 
+       (let-values ([(x free) (Expr x)])
+         (values (make-known x t) free))]
+      [else (Expr x)]))
+  (define (A* x*)
+    (cond
+      [(null? x*) (values '() '())]
+      [else
+       (let-values ([(a a-free) (A (car x*))]
+                    [(d d-free) (A* (cdr x*))])
+         (values (cons a d) (union a-free d-free)))]))
   (define (Expr ex)
     (struct-case ex
       [(constant) (values ex '())]
@@ -1486,19 +1539,25 @@
        (let-values ([(rand* rand*-free) (Expr* rand*)])
          (values (make-forcall op rand*)  rand*-free))]
       [(funcall rator rand*)
-       (let-values ([(rator rat-free) (Expr rator)]
-                    [(rand* rand*-free) (Expr* rand*)])
-         (values (make-funcall rator rand*) 
+       (let-values ([(rator rat-free) (A rator)]
+                    [(rand* rand*-free) (A* rand*)])
+         (values (make-funcall rator rand*)
                  (union rat-free rand*-free)))]
       [(jmpcall label rator rand*)
        (let-values ([(rator rat-free)
-                     (if (and (optimize-cp) (var? rator))
-                         (values rator (singleton rator))
-                         (Expr rator))]
-                    [(rand* rand*-free) (Expr* rand*)])
+                     (if (optimize-cp) (Rator rator) (Expr rator))]
+                    [(rand* rand*-free)
+                     (A* rand*)])
          (values (make-jmpcall label rator rand*) 
-                 (union rat-free rand*-free)))] 
+                 (union rat-free rand*-free)))]
       [else (error who "invalid expression" ex)]))
+  (define (Rator x)
+    (struct-case x
+      [(var) (values x (singleton x))]
+      ;[(known x t)
+      ; (let-values ([(x free) (Rator x)])
+      ;   (values (make-known x t) free))]
+      [else (Expr x)]))
   (let-values ([(prog free) (Expr prog)])
     (unless (null? free) 
       (error 'convert-closures "free vars encountered in program"
@@ -1696,6 +1755,10 @@
                 y)]
              [else y]))]
         [else x])))
+  (define (A x)
+    (struct-case x
+      [(known x t) (make-known (E x) t)]
+      [else (E x)]))
   (define (E x)
     (struct-case x
       [(constant) x]
@@ -1707,7 +1770,7 @@
        (make-conditional (E test) (E conseq) (E altern))]
       [(seq e0 e1)           (make-seq (E e0) (E e1))]
       [(forcall op rand*)    (make-forcall op (map E rand*))]
-      [(funcall rator rand*) (make-funcall (E rator) (map E rand*))]
+      [(funcall rator rand*) (make-funcall (A rator) (map A rand*))]
       [(jmpcall label rator rand*)
        (make-jmpcall label (E rator) (map E rand*))]
       [else (error who "invalid expression" (unparse x))]))
@@ -2267,6 +2330,7 @@
      (printf "    ~s\n" x)]))
 
 (define optimizer-output (make-parameter #f))
+(define perform-tag-analysis (make-parameter #f))
 
 (define (compile-core-expr->code p)
   (let* ([p (recordize p)]
@@ -2280,6 +2344,9 @@
                (pretty-print (unparse-pretty p)))
             #f)]
          [p (rewrite-assignments p)]
+         [p (if (perform-tag-analysis)
+                (introduce-tags p)
+                p)]
          [p (introduce-vars p)]
          [p (sanitize-bindings p)]
          [p (optimize-for-direct-jumps p)]
diff --git a/scheme/ikarus.compiler.tag-annotation-analysis.ss b/scheme/ikarus.compiler.tag-annotation-analysis.ss
new file mode 100644
index 0000000..b1154f4
--- /dev/null
+++ b/scheme/ikarus.compiler.tag-annotation-analysis.ss
@@ -0,0 +1,434 @@
+;;; 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/>.
+
+
+
+;;; THIS IS WIP
+(include "ikarus.ontology.ss")
+
+(define tag-analysis-output (make-parameter #f))
+
+(define (introduce-tags x)
+  (define who 'introduce-tags)
+  #;
+  (define primitive-return-types 
+    '(
+      [length                fixnum]
+      [bytevector-length     fixnum]
+      [bytevector-u8-ref     fixnum]
+      [bytevector-s8-ref     fixnum]
+      [bytevector-u16-ref    fixnum]
+      [bytevector-s16-ref    fixnum]
+      [bytevector-u16-native-ref    fixnum]
+      [bytevector-s16-native-ref    fixnum]
+      [fixnum-width          fixnum]
+      [greatest-fixnum       fixnum]
+      [least-fixnum          fixnum]
+      [=                     boolean]
+      [<                     boolean]
+      [<=                    boolean]
+      [>                     boolean]
+      [>=                    boolean]
+      [even?                 boolean]
+      [odd?                  boolean]
+      [rational?             boolean]
+      [rational-valued?      boolean]
+      [real?                 boolean]
+      [real-valued?          boolean]
+      [bignum?               boolean]
+      [ratnum?               boolean]
+      [flonum?               boolean]
+      [fixnum?               boolean]
+      [integer?              boolean]
+      [exact?                boolean]
+      [finite?               boolean]
+      [inexact?              boolean]
+      [infinite?             boolean]
+      [positive?             boolean]
+      [negative?             boolean]
+      [nan?                  boolean]
+      [number?               boolean]
+      [compnum?              boolean]
+      [cflonum?              boolean]
+      [complex?              boolean]
+      [list?                 boolean]
+      [eq?                   boolean]
+      [eqv?                  boolean]
+      [equal?                boolean]
+      [gensym?               boolean]
+      [symbol-bound?         boolean]
+      [code?                 boolean]
+      [immediate?            boolean]
+      [pair?                 boolean]
+      [procedure?            boolean]
+      [symbol?               boolean]
+      [symbol=?              boolean]
+      [boolean?              boolean]
+      [boolean=?             boolean]
+      [vector?               boolean]
+      [bitwise-bit-set?      boolean]
+      [bytevector?           boolean]
+      [bytevector=?          boolean]
+      [enum-set=?            boolean]
+      [binary-port?          boolean]
+      [textual-port?         boolean]
+      [input-port?           boolean]
+      [output-port?          boolean]
+      [port?                 boolean]
+      [port-eof?             boolean]
+      [port-closed?          boolean]
+      [char-ready?           boolean]
+      [eof-object?           boolean]
+      [hashtable?            boolean]
+      [hashtable-mutable?    boolean]
+      [file-exists?          boolean]
+      [file-regular?         boolean]
+      [file-directory?       boolean]
+      [file-symbolic-link?   boolean]
+      [record?               boolean]
+      [record-field-mutable? boolean]
+      [record-type-generative? boolean]
+      [record-type-sealed?   boolean]
+      [record-type-descriptor boolean]
+      [free-identifier=?     boolean]
+      [bound-identifier=?    boolean]
+      [identifier?           boolean]
+      [char-lower-case?      boolean]
+      [char-upper-case?      boolean]
+      [char-title-case?      boolean]
+      [char-whitespace?      boolean]
+      [char-numeric?         boolean]
+      [char-alphabetic?      boolean]
+    ))
+
+  (define number!
+    (let ([i 0])
+      (lambda (x)
+        (set-prelex-operand! x i)
+        (set! i (+ i 1)))))
+  (define (V* x* env)
+    (cond
+      [(null? x*) (values '() env '())]
+      [else
+       (let-values ([(x env1 t) (V (car x*) env)]
+                    [(x* env2 t*) (V* (cdr x*) env)])
+         (values (cons x x*)
+                 (and-envs env1 env2)
+                 (cons t t*)))]))
+  (define (constant-type x) 
+    (define (numeric x)
+      (define (size x t)
+        (T:and t
+          (cond
+            [(< x 0) T:negative]
+            [(> x 0) T:positive]
+            [(= x 0) T:zero]
+            [else    t])))
+      (cond
+        [(fixnum? x) (size x T:fixnum)]
+        [(flonum? x) (size x T:flonum)]
+        [(or (bignum? x) (ratnum? x)) 
+         (size x (T:and T:exact T:other-number))]
+        [else        T:number]))
+    (cond
+      [(number? x)    (numeric x)]
+      [(boolean? x)   (if x T:true T:false)]
+      [(null? x)      T:null]
+      [(char? x)      T:char]
+      [(string? x)    T:string]
+      [(vector? x)    T:vector]
+      [(pair? x)      T:pair]
+      [(eq? x (void)) T:void]
+      [else           T:object]))
+  (define (V x env)
+    (struct-case x
+      [(constant k) (values x env (constant-type k))]
+      [(prelex)     (values x env (lookup x env))]
+      [(primref op) (values x env T:procedure)]
+      [(seq e0 e1)
+       (let-values ([(e0 env t) (V e0 env)])
+         (cond
+           [(eq? (T:object? t) 'no)
+            (values e0 env t)]
+           [else
+            (let-values ([(e1 env t) (V e1 env)])
+              (values (make-seq e0 e1) env t))]))]
+      [(conditional e0 e1 e2)
+       (let-values ([(e0 env t) (V e0 env)])
+         (cond
+           [(eq? (T:object? t) 'no)
+            (values e0 env t)]
+           [(eq? (T:false? t) 'yes)
+            (let-values ([(e2 env t) (V e2 env)])
+              (values (make-seq e0 e2) env t))]
+           [(eq? (T:false? t) 'no)
+            (let-values ([(e1 env t) (V e1 env)])
+              (values (make-seq e0 e1) env t))]
+           [else
+            (let-values ([(e1 env1 t1) (V e1 env)]
+                         [(e2 env2 t2) (V e2 env)])
+              (values (make-conditional e0 e1 e2)
+                      (or-envs env1 env2)
+                      (T:or t1 t2)))]))]
+      [(bind lhs* rhs* body)
+       (let-values ([(rhs* env t*) (V* rhs* env)])
+         (for-each number! lhs*)
+         (let ([env (extend-env* lhs* t* env)])
+           (let-values ([(body env t) (V body env)])
+             (values 
+               (make-bind lhs* rhs* body)
+               env t))))]
+      [(fix lhs* rhs* body)
+       (for-each number! lhs*)
+       (let-values ([(rhs* env t*) (V* rhs* env)])
+         (let ([env (extend-env* lhs* t* env)])
+           (let-values ([(body env t) (V body env)])
+             (values 
+               (make-fix lhs* rhs* body)
+               env t))))]
+      [(clambda g cls* cp free name)
+       (values
+         (make-clambda g
+           (map 
+             (lambda (x)
+               (struct-case x 
+                 [(clambda-case info body)
+                  (for-each number! (case-info-args info))
+                  (let-values ([(body env t) (V body env)])
+                    ;;; dropped env and t
+                    (make-clambda-case info body))]))
+             cls*)
+           cp free name)
+         env
+         T:procedure)]
+      [(funcall rator rand*)
+       (let-values ([(rator rator-env rator-val) (V rator env)]
+                    [(rand* rand*-env rand*-val) (V* rand* env)])
+         (apply-funcall rator rand*
+           rator-val rand*-val
+           rator-env rand*-env))]
+      [(forcall rator rand*)
+       (let-values ([(rand* rand*-env rand*-val) (V* rand* env)])
+         (values (make-forcall rator rand*)
+                 rand*-env
+                 T:object))]
+      [else (error who "invalid expression" (unparse x))]))
+  (define (annotate x t)
+    (cond
+      [(T=? t T:object) x]
+      [else (make-known x t)]))
+  (define (apply-funcall rator rand* rator-val rand*-val rator-env rand*-env)
+    (let ([env (and-envs rator-env rand*-env)]
+          [rand* (map annotate rand* rand*-val)])
+      (struct-case rator
+        [(primref op) 
+         (apply-primcall op rand* env)]
+        [else
+         (values (make-funcall (annotate rator rator-val) rand*)
+                 env
+                 T:object)])))
+  (define (apply-primcall op rand* env)
+    (define (return t)
+      (values (make-funcall (make-primref op) rand*) env t))
+    (define (inject ret-t . rand-t*)
+      (define (extend* x* t* env)
+        (define (extend x t env)
+          (struct-case x
+            [(known expr t0)
+             (extend expr (T:and t t0) env)]
+            [(prelex)
+             (extend-env x t env)]
+            [else env]))
+        (cond
+          [(null? x*) env]
+          [else (extend (car x*) (car t*)
+                  (extend* (cdr x*) (cdr t*) env))]))
+      (cond
+        [(= (length rand-t*) (length rand*))
+         (values (make-funcall (make-primref op) rand*)
+                 (extend* rand* rand-t* env)
+                 ret-t)]
+        [else
+         (error 'apply-primcall "invalid extesion" op rand*)]))
+    (define (inject* ret-t arg-t)
+      (define (extend* x* env)
+        (define (extend x t env)
+          (struct-case x
+            [(known expr t0)
+             (extend expr (T:and t t0) env)]
+            [(prelex)
+             (extend-env x t env)]
+            [else env]))
+        (cond
+          [(null? x*) env]
+          [else (extend (car x*) arg-t
+                  (extend* (cdr x*) env))]))
+      (values (make-funcall (make-primref op) rand*)
+              (extend* rand* env)
+              ret-t))
+    (case op
+      [(cons)        
+       (return T:pair)]
+      [(car cdr
+        caar cadr cdar cddr
+        caaar caadr cadar caddr cdaar cdadr cddar cdddr
+        caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+        cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)
+       (inject T:object T:pair)]
+      [(set-car! set-cdr!)
+       (inject T:void T:pair T:object)]
+      [(vector make-vector list->vector)
+       (return T:vector)]
+      [(string make-string list->string)
+       (return T:string)]
+      [(string-length)
+       (inject T:fixnum T:string)]
+      [(vector-length)
+       (inject T:fixnum T:vector)]
+      [(string-ref)
+       (inject T:char T:string T:fixnum)]
+      [(string-set!)
+       (inject T:void T:string T:fixnum T:char)]
+      [(vector-ref)
+       (inject T:object T:vector T:fixnum)]
+      [(vector-set!)
+       (inject T:void T:vector T:fixnum T:object)]
+      [(integer->char)
+       (inject T:char T:fixnum)]
+      [(char->integer)
+       (inject T:fixnum T:char)]
+      [(fx+         fx-         fx*         fxadd1      fxsub1
+        fxquotient  fxremainder fxmodulo    fxsll       fxsra
+        fxand       fxdiv       fxdiv0      fxif        fxior
+        fxlength    fxmax       fxmin       fxmod       fxmod0
+        fxnot       fxxor       fxlogand    fxlogor     fxlognot
+        fxlogxor    fxlogand    fxlogand    fxlogand    fxlogand
+        fxlogand    fxlogand)
+       (inject* T:fixnum T:fixnum)]
+      [(fx= fx< fx<= fx> fx>= fx=? fx<? fx<=? fx>? fx>=?
+        fxeven? fxodd? fxnegative? fxpositive? fxzero?
+        fxbit-set?)
+       (inject* T:boolean T:fixnum)]
+      [(fl=? fl<? fl<=? fl>? fl>=?
+        fleven? flodd? flzero? flpositive? flnegative?
+        flfinite? flinfinite? flinteger? flnan?)
+       (inject* T:boolean T:flonum)]
+      [(char=? char<? char<=? char>? char>=? 
+        char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?)
+       (inject* T:boolean T:char)]
+      [(string=? string<? string<=? string>? string>=?
+        string-ci=? string-ci<? string-ci<=? string-ci>?
+        string-ci>=?)
+       (inject* T:boolean T:string)]
+      [(make-parameter 
+        record-constructor  
+        record-accessor     
+        record-constructor  
+        record-predicate    
+        condition-accessor  
+        condition-predicate 
+        enum-set-constructor
+        enum-set-indexer    
+        make-guardian)
+       (return T:procedure)]
+      [else
+       (return T:object)]))
+      
+ 
+
+  ;;;
+  (define (extend-env* x* v* env)
+    (cond
+      [(null? x*) env]
+      [else 
+       (extend-env* (cdr x*) (cdr v*)
+         (extend-env (car x*) (car v*) env))]))
+  (define (extend-env x t env)
+    (cond
+      [(T=? t T:object) env]
+      [else
+       (let ([x (prelex-operand x)])
+         (let f ([env env])
+           (cond
+             [(or (null? env) (< x (caar env)))
+              (cons (cons x t) env)]
+             [else
+              (cons (car env) (f (cdr env)))])))]))
+  (define (or-envs env1 env2)
+    (define (cons-env x v env)
+      (cond
+        [(T=? v T:object) env]
+        [else (cons (cons x v) env)]))
+    (define (merge-envs1 a1 env1 env2)
+      (if (pair? env2)
+          (merge-envs2 a1 env1 (car env2) (cdr env2))
+          empty-env))
+    (define (merge-envs2 a1 env1 a2 env2)
+      (let ([x1 (car a1)] [x2 (car a2)])
+        (if (eq? x1 x2)
+            (cons-env x1 (T:or (cdr a1) (cdr a2))
+              (merge-envs env1 env2))
+            (if (< x2 x1)
+                (merge-envs1 a1 env1 env2)
+                (merge-envs1 a2 env2 env1)))))
+    (define (merge-envs env1 env2)
+      (if (eq? env1 env2)
+          env1
+          (if (pair? env1)
+              (if (pair? env2) 
+                  (merge-envs2 (car env1) (cdr env1) (car env2) (cdr env2))
+                  empty-env)
+              empty-env)))
+    (merge-envs env1 env2))
+  (define (and-envs env1 env2)
+    (define (cons-env x v env)
+      (cond
+        [(T=? v T:object) env]
+        [else (cons (cons x v) env)]))
+    (define (merge-envs1 a1 env1 env2)
+      (if (pair? env2)
+          (merge-envs2 a1 env1 (car env2) (cdr env2))
+          env1))
+    (define (merge-envs2 a1 env1 a2 env2)
+      (let ([x1 (car a1)] [x2 (car a2)])
+        (if (eq? x1 x2)
+            (cons-env x1 (T:and (cdr a1) (cdr a2))
+              (merge-envs env1 env2))
+            (if (< x2 x1)
+                (cons a2 (merge-envs1 a1 env1 env2))
+                (cons a1 (merge-envs1 a2 env2 env1))))))
+    (define (merge-envs env1 env2)
+      (if (eq? env1 env2)
+          env1
+          (if (pair? env1)
+              (if (pair? env2) 
+                  (merge-envs2 (car env1) (cdr env1) (car env2) (cdr env2))
+                  env1)
+              env2)))
+    (merge-envs env1 env2))
+  (define empty-env '())
+  (define (lookup x env)
+    (cond
+      [(eq? env 'bottom) #f]
+      [else
+       (let ([x (prelex-operand x)])
+         (cond
+           [(assq x env) => cdr]
+           [else T:object]))]))
+  (let-values ([(x env t) (V x empty-env)])
+    (when (tag-analysis-output)
+      (pretty-print (unparse x)))
+    x))
+
diff --git a/scheme/ikarus.conditions.ss b/scheme/ikarus.conditions.ss
index ba1ccf2..674cffa 100644
--- a/scheme/ikarus.conditions.ss
+++ b/scheme/ikarus.conditions.ss
@@ -72,13 +72,6 @@
           &i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd
           &no-nans-rtd &no-nans-rcd
           &interrupted-rtd &interrupted-rcd 
-
-
-          &i/o-would-block-rtd
-          &i/o-would-block-rcd
-          make-i/o-would-block-condition
-          i/o-would-block-condition?
-          i/o-would-block-port
           )
   (import
     (rnrs records inspection)
@@ -131,11 +124,6 @@
           i/o-encoding-error? i/o-encoding-error-char
           no-infinities-violation? make-no-infinities-violation
           no-nans-violation? make-no-nans-violation
-          
-          &i/o-would-block
-          make-i/o-would-block-condition
-          i/o-would-block-condition?
-          i/o-would-block-port
           ))
   
   (define-record-type &condition 
@@ -344,10 +332,6 @@
   (define-condition-type &interrupted &serious
     make-interrupted-condition interrupted-condition?)
 
-  (define-condition-type &i/o-would-block &condition
-    make-i/o-would-block-condition i/o-would-block-condition?
-    (port i/o-would-block-port))
-
   (define print-condition 
     (let ()
       (define (print-simple-condition x p)
diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss
index 05e8ffe..8243b5e 100644
--- a/scheme/ikarus.io.ss
+++ b/scheme/ikarus.io.ss
@@ -1309,8 +1309,6 @@
                               (cond
                                 [(fx>= bytes 0) bytes]
                                 [(fx= bytes EAGAIN-error-code)
-                                 ;(raise-continuable 
-                                 ;  (make-i/o-would-block-condition port))
                                  (call/cc 
                                    (lambda (k) 
                                      (add-io-event fd k 'r)
@@ -1351,8 +1349,6 @@
                               (cond
                                 [(fx>= bytes 0) bytes]
                                 [(fx= bytes EAGAIN-error-code)
-                                 ;(raise-continuable 
-                                 ;  (make-i/o-would-block-condition port))
                                  (call/cc 
                                    (lambda (k)
                                      (add-io-event fd k 'w)
diff --git a/scheme/ikarus.ontology.ss b/scheme/ikarus.ontology.ss
new file mode 100755
index 0000000..513604f
--- /dev/null
+++ b/scheme/ikarus.ontology.ss
@@ -0,0 +1,273 @@
+;;; 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 define-ontology
+  (lambda (x)
+    (define (make-ontology main ls)
+      (define (set-cons x ls)
+        (cond
+          [(memq x ls) ls]
+          [else (cons x ls)]))
+      (define (union ls1 ls2)
+        (cond
+          [(null? ls1) ls2]
+          [else (union (cdr ls1) (set-cons (car ls1) ls2))]))
+      (define (difference ls1 ls2)
+        (cond
+          [(null? ls1) '()]
+          [(memq (car ls1) ls2) (difference (cdr ls1) ls2)]
+          [else (cons (car ls1) (difference (cdr ls1) ls2))]))
+      (define (collect-names ls)
+        (syntax-case ls ()
+          [() '()]
+          [((name (of name* ...)) . rest)
+           (union (cons #'name #'(name* ...)) (collect-names #'rest))]))
+      (define (expand x all)
+        (define (lookup x ls)
+          (cond
+            [(null? ls) (values 'tag '())]
+            [else
+             (let ([a (car ls)])
+               (cond
+                 [(eq? x (car a)) 
+                  (values (cadr a) (cdr ls))]
+                 [else
+                  (let-values ([(xp ls) (lookup x (cdr ls))])
+                    (values xp (cons a ls)))]))]))
+        (let f ([x x] [ls ls])
+          (let-values ([(xp ls) (lookup x ls)])
+            (cond
+              [(pair? xp)
+               (cons (car xp) (map (lambda (x) (f x ls)) (cdr xp)))]
+              [(eq? xp 'tag) x]
+              [else (error 'expand-lookup "invalid" xp)]))))
+      (define (rename alist x)
+        (cond
+          [(symbol? x) (cdr (assq x alist))]
+          [else (cons (car x) (map (lambda (x) (rename alist x)) (cdr x)))]))
+      (define (enumerate ls)
+        (let f ([i 1] [ls ls])
+          (cond
+            [(null? ls) '()]
+            [else (cons i (f (* i 2) (cdr ls)))])))
+      (define (unique-elements x)
+        (define (exclude m ls)
+          (cond
+            [(null? ls) '()]
+            [(zero? (bitwise-and m (car ls)))
+             (cons (car ls) (exclude m (cdr ls)))]
+            [else (exclude m (cdr ls))]))
+        (define (exclusive* m* x**)
+          (cond
+            [(null? (cdr m*)) (values (car m*) (car x**))]
+            [else
+             (let-values ([(m1 x1*) (values (car m*) (car x**))]
+                          [(m2 x2*) (exclusive* (cdr m*) (cdr x**))])
+               (let ([x1* (exclude m2 x1*)]
+                     [x2* (exclude m1 x2*)])
+                 (values (bitwise-ior m1 m2) (append x1* x2*))))]))
+        (define (inclusive* m* x**)
+          (cond
+            [(null? (cdr m*)) (values (car m*) (car x**))]
+            [else
+             (let-values ([(m1 x1*) (values (car m*) (car x**))]
+                          [(m2 x2*) (inclusive* (cdr m*) (cdr x**))])
+               (values (bitwise-ior m1 m2)
+                       (remp not
+                         (apply append
+                           (map (lambda (x)
+                                  (map (lambda (y)
+                                         (if (= (bitwise-and m1 m2 x)
+                                                (bitwise-and m1 m2 y))
+                                             (bitwise-ior x y)
+                                             #f))
+                                       x2*))
+                                x1*)))))]))
+        (define (f* ls)
+          (cond
+            [(null? ls) (values '() '())]
+            [else
+             (let-values ([(m x*) (f (car ls))]
+                          [(m* x**) (f* (cdr ls))])
+               (values (cons m m*) (cons x* x**)))]))
+        (define (f x)
+          (cond
+            [(integer? x) (values x (list x))]
+            [else
+             (let ([tag (car x)] [ls (cdr x)])
+               (let-values ([(m* x**) (f* ls)])
+                 (case tag
+                   [(exclusive) (exclusive* m* x**)]
+                   [(inclusive) (inclusive* m* x**)]
+                   [else (error 'f "invalid")])))]))
+        (let-values ([(m ls) (f x)])
+          ls))
+      (define (expand-names alist)
+        (lambda (n)
+          (let f ([alist alist])
+            (cond
+              [(null? alist) '()]
+              [(zero? (bitwise-and n (cdar alist)))
+               (f (cdr alist))]
+              [else 
+               (cons (caar alist) (f (cdr alist)))]))))
+      (define (extend-alist* ls alist)
+        (define (extend-alist x alist)
+          (define (lookup x)
+            (cond
+              [(assq x alist) => cdr]
+              [else (error 'lookup "cannot find" x alist)]))
+          (let ([name (car x)] [info (cadr x)])
+            (let ([tag (car info)] [x* (map lookup (cdr info))])
+              (case tag
+                [(exclusive) 
+                 (cons (cons name (apply bitwise-ior x*)) alist)]
+                [(inclusive)
+                 (assert (= (apply bitwise-ior x*) (apply bitwise-and x*)))
+                 (cons (cons name (apply bitwise-ior x*)) alist)]
+                [else (assert #f)]))))
+        (cond
+          [(null? ls) alist]
+          [else
+           (extend-alist (car ls)
+             (extend-alist* (cdr ls) alist))]))
+      (let* ([names (difference (collect-names ls) (map car ls))]
+             [names-alist (map cons names (enumerate names))])
+        (let* ([expanded (expand main ls)]
+               [renamed (rename names-alist expanded)])
+          (let* ([unique* (list-sort < (unique-elements renamed))]
+                 [canonicals (map (expand-names names-alist) unique*)])
+            (let* ([canonical-alist (map cons canonicals (enumerate canonicals))]
+                   [seed-alist
+                    (map 
+                      (lambda (x) 
+                        (let ([ls (filter (lambda (y) (memq x (car y))) canonical-alist)])
+                          (cons x (apply bitwise-ior (map cdr ls)))))
+                      names)])
+              (extend-alist* ls seed-alist))))))
+    (define (property-names ls)
+      (cond
+        [(null? ls) '()]
+        [else
+         (let ([fst (car ls)] [rest (property-names (cdr ls))])
+           (let ([name (car fst)] [info (cadr fst)])
+             (case (car info)
+               [(exclusive) rest]
+               [(inclusive) (append (cdr info) rest)]
+               [else (assert #f)])))]))
+    (define (generate-base-cases T main ls)
+      (define (value-name x)
+        (datum->syntax T
+          (string->symbol
+            (string-append 
+              (symbol->string (syntax->datum T))
+              ":" 
+              (symbol->string x)))))
+      (define (predicate-name x)
+        (datum->syntax T
+          (string->symbol
+            (string-append 
+              (symbol->string (syntax->datum T))
+              ":" 
+              (symbol->string x)
+              "?"))))
+      (let ([maind (syntax->datum main)] [lsd (syntax->datum ls)])
+        (let ([alist (make-ontology maind lsd)]
+              [pnames (property-names lsd)])
+          (let ([alist (remp (lambda (x) (memq (car x) pnames)) alist)])
+            (map 
+              (lambda (x) (list (value-name (car x))
+                                (predicate-name (car x))
+                                (cdr x)))
+              alist)))))
+    (syntax-case x ()
+      [(_ T T:description T? T:=? T:and T:or [name cls] [name* cls*] ...)
+       (with-syntax ([((name* predname* val*) ...)
+                      (generate-base-cases #'T #'name
+                        #'([name cls] [name* cls*] ...))])
+         #'(begin
+             (define-record-type (T make-T T?)
+               (sealed     #t)
+               (fields (immutable n T-n)))
+             (define (T:and x0 x1)
+               (make-T (bitwise-and (T-n x0) (T-n x1))))
+             (define (T:or x0 x1)
+               (make-T (bitwise-ior (T-n x0) (T-n x1))))
+             (define (test x v)
+               (let ([bits (bitwise-and x v)])
+                 (cond
+                   [(= 0 (bitwise-and x v))  'no]
+                   [(= v (bitwise-ior x v)) 'yes]
+                   [else                  'maybe])))
+             (define name* (make-T val*)) ...
+             (define (predname* x) (test (T-n x) val*)) ...
+             (define (T:description x)
+               (let* ([ls '()]
+                      [ls
+                       (case (predname* x)
+                         [(yes) (cons '(name* yes) ls)]
+                         [else  ls])]
+                      ...)
+                 ls))
+             (define (T:=? x y)
+               (= (T-n x) (T-n y)))
+             ))])))
+
+(define-ontology T T:description T? T=? T:and T:or
+  [object        (inclusive obj-tag obj-immediacy obj-truth)]
+  [obj-immediacy (exclusive nonimmediate immediate)]
+  [immediate     (exclusive fixnum boolean null char void)]
+  [obj-truth     (exclusive false non-false)]
+  [obj-tag       (exclusive procedure string vector pair null
+                            boolean char number void other-object)]
+  [boolean       (exclusive true false)]
+  [number        (inclusive number-tag number-size number-exactness)]
+  [number-size   (exclusive negative zero positive)]
+  [number-tag    (exclusive fixnum flonum other-number)]
+  [number-exactness (exclusive exact inexact)]
+  [exact         (exclusive fixnum other-exact)]
+  [inexact       (exclusive flonum other-inexact)]
+  )
+
+#!eof
+
+(define (do-test expr result expected)
+  (if (equal? result expected)
+      (printf "OK: ~s -> ~s\n" expr expected)
+      (error 'test "failed/got/expected" expr result expected)))
+
+(define-syntax test
+  (syntax-rules ()
+    [(_ expr expected) (do-test 'expr expr 'expected)]))
+
+(test (T:object? T:object) yes)
+(test (T:object? T:true)   yes)
+(test (T:true? T:object)   maybe)
+(test (T:true? T:true)     yes)
+(test (T:true? T:false)    no)
+(test (T:true? T:null)     no)
+(test (T:non-false? T:true) yes)
+(test (T:non-false? T:null) yes)
+(test (T:non-false? T:false) no)
+(test (T:non-false? T:boolean) maybe)
+(test (T:non-false? T:object) maybe)
+(test (T:boolean? T:true) yes)
+(test (T:boolean? T:false) yes)
+(test (T:boolean? (T:or T:true T:false)) yes)
+(test (T:boolean? (T:and T:true T:false)) no)
+(test (T:object? (T:and T:true T:false)) no)
+
+
+
diff --git a/scheme/last-revision b/scheme/last-revision
index 4aea099..c16dfe7 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1526
+1527
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index c3ae0f4..6ef7bbc 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -19,7 +19,7 @@
 (import (except (ikarus) 
           assembler-output optimize-cp optimize-level
           cp0-size-limit cp0-effort-limit expand/optimize
-          optimizer-output))
+          optimizer-output tag-analysis-output perform-tag-analysis))
 (import (ikarus.compiler))
 (import (except (psyntax system $bootstrap)
                 eval-core 
@@ -27,6 +27,7 @@
                 compile-core-expr-to-port))
 (import (ikarus.compiler)) ; just for fun
 (optimize-level 2)
+(perform-tag-analysis #t)
 (pretty-width 160)
 ((pretty-format 'fix) ((pretty-format 'letrec)))
 
@@ -1414,8 +1415,6 @@
     [&no-nans-rcd]
     [&interrupted-rtd]
     [&interrupted-rcd]
-    [&i/o-would-block-rtd]
-    [&i/o-would-block-rcd]
     [tcp-connect                      i]
     [udp-connect                      i]
     [tcp-connect-nonblocking          i]
@@ -1429,15 +1428,13 @@
     [input-socket-buffer-size         i]
     [output-socket-buffer-size        i]
 
-    ;[&i/o-would-block                 i]
-    ;[make-i/o-would-block-condition   i]
-    ;[i/o-would-block-condition?       i]
-    ;[i/o-would-block-port             i]
     [ellipsis-map ]
     [optimize-cp i]
     [optimize-level i]
     [cp0-size-limit i]
     [cp0-effort-limit i]
+    [tag-analysis-output i]
+    [perform-tag-analysis i]
   ))
 
 (define (macro-identifier? x) 
diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss
index d67335c..b5efeb9 100644
--- a/scheme/pass-specify-rep-primops.ss
+++ b/scheme/pass-specify-rep-primops.ss
@@ -39,11 +39,6 @@
     (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)
   (define shift-bits 2)
   (prm 'mset 
@@ -59,9 +54,14 @@
      (if (or (fixnum? t) (immediate? t))
          (prm 'nop)
          (dirty-vector-set addr))]
+    [(known x t)
+     (cond
+       [(eq? (T:immediate? t) 'yes)
+        (record-optimization 'smart-dirty-vec t)
+        (nop)]
+       [else (smart-dirty-vector-set addr x)])]
     [else (dirty-vector-set addr)]))
 
-
 (define (slow-mem-assign v x i)
   (with-tmp ([t (prm 'int+ x (K i))])
     (make-seq 
@@ -74,6 +74,12 @@
      (if (or (fixnum? t) (immediate? t))
          (prm 'mset x (K i) (T v))
          (slow-mem-assign v x i))]
+    [(known expr t)
+     (cond
+       [(eq? (T:immediate? t) 'yes)
+        (record-optimization 'mem-assign v)
+        (prm 'mset x (K i) (T expr))]
+       [else (slow-mem-assign expr x i)])]
     [else (slow-mem-assign v x i)]))
 
 (define (align-code unknown-amt known-amt)
@@ -111,6 +117,7 @@
 (define (equable-constant? x)
   (struct-case x 
     [(constant xv) (equable? xv)]
+    [(known x t) (equable-constant? x)]
     [else #f]))
 
 (define-primop eqv? safe
@@ -151,7 +158,8 @@
   [(E x) (nop)])
 
 (define-primop boolean? safe
-  [(P x) (tag-test (T x) bool-mask bool-tag)]
+  [(P x) 
+   (tag-test (T x) bool-mask bool-tag)]
   [(E x) (nop)])
 
 (define-primop bwp-object? safe
@@ -195,6 +203,8 @@
                   (prm '= x (T (K (car ls))))
                   (K #t)
                   (f (cdr ls)))])))])]
+     [(known expr t) 
+      (cogen-pred-$memq x expr)]
      [else (interrupt)])]
   [(V x ls)
    (struct-case ls
@@ -211,6 +221,8 @@
                   (prm '= x (T (K (car ls))))
                   (T (K ls))
                   (f (cdr ls)))])))])]
+     [(known expr t) 
+      (cogen-value-$memq x expr)]
      [else (interrupt)])]
   [(E x ls) (nop)])
 
@@ -223,6 +235,7 @@
       (cond
         [(list? ls) (nop)]
         [else (interrupt)])]
+     [(known) (error 'translate "memq")]
      [else (interrupt)])])
 
 (define (equable? x)
@@ -236,6 +249,7 @@
         [(and (list? lsv) (andmap equable? lsv))
          (cogen-value-$memq x ls)]
         [else (interrupt)])]
+     [(known) (error 'translate "memv")]
      [else (interrupt)])]
   [(P x ls) 
    (struct-case ls
@@ -244,6 +258,7 @@
         [(and (list? lsv) (andmap equable? lsv))
          (cogen-pred-$memq x ls)]
         [else (interrupt)])]
+     [(known) (error 'translate "memv")]
      [else (interrupt)])]
   [(E x ls)
    (struct-case ls
@@ -251,6 +266,7 @@
       (cond
         [(list? lsv) (nop)]
         [else (interrupt)])]
+     [(known) (error 'translate "memv")]
      [else (interrupt)])])
 
 /section)
@@ -258,7 +274,8 @@
 (section ;;; pairs 
 
 (define-primop pair? safe
-  [(P x) (tag-test (T x) pair-mask pair-tag)]
+  [(P x)
+   (tag-test (T x) pair-mask pair-tag)]
   [(E x) (nop)])
 
 (define-primop cons safe
@@ -290,29 +307,41 @@
      (prm 'mset x (K (- disp-cdr pair-tag)) (T v))
      (smart-dirty-vector-set x v))])
 
+(define (assert-pair x)
+  (struct-case x
+    [(known x t)
+     (case (T:pair? t)
+       [(yes) (record-optimization 'assert-pair x) (nop)]
+       [(no)  (interrupt)]
+       [else  (assert-pair x)])]
+    [else
+     (interrupt-unless (tag-test x pair-mask pair-tag))]))
+
 (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))])
+   (with-tmp ([x (T x)])
+     (assert-pair x)
+     (prm 'mref x (K (- disp-car pair-tag))))]
+  [(E x) (assert-pair (T x))])
 
 (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))])
+   (with-tmp ([x (T x)])
+     (assert-pair x)
+     (prm 'mref x (K (- disp-cdr pair-tag))))]
+  [(E x) (assert-pair (T x))])
 
 (define-primop set-car! safe
   [(E x v)
    (with-tmp ([x (T x)])
-     (interrupt-unless (tag-test x pair-mask pair-tag))
+     (assert-pair x)
      (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))
+     (assert-pair x)
      (prm 'mset x (K (- disp-cdr pair-tag)) (T v))
      (smart-dirty-vector-set x v))])
 
@@ -322,7 +351,7 @@
     [(null? ls) (T val)]
     [else 
      (with-tmp ([x (expand-cxr val (cdr ls))]) 
-       (interrupt-unless (tag-test x pair-mask pair-tag))
+       (assert-pair x)
        (prm 'mref x 
           (case (car ls) 
             [(a)  (K (- disp-car pair-tag))]
@@ -408,25 +437,60 @@
 (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))
+      (define (check-non-vector x idx)
+        (define (check-fx 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))
+               (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 idx)
+               (check-? idx))]
+          [(known idx idx-t)
+           (case (T:fixnum? idx-t)
+             [(yes) (check-fx idx)]
+             [(maybe) (vector-range-check x idx)]
+             [else
+              (printf "vector check with mismatch index tag ~s" idx-t)
+              (vector-range-check x idx)])]
+          [else (check-? idx)]))
+      (define (check-vector x idx)
+        (define (check-fx idx)
           (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)]))
+            (interrupt-unless (prm 'u< (T idx) len))))
+        (define (check-? idx)
+          (seq*
+            (interrupt-unless-fixnum (T idx)) 
+            (with-tmp ([len (cogen-value-$vector-length x)])
+              (interrupt-unless (prm 'u< (T idx) len)))))
+        (struct-case idx
+          [(constant i)
+           (if (and (fixnum? i) (fx>= i 0)) 
+               (check-fx idx)
+               (check-? idx))]
+          [(known idx idx-t)
+           (case (T:fixnum? idx-t)
+             [(yes) (check-fx idx)]
+             [(no)  (interrupt)]
+             [else  (check-vector x idx)])]
+          [else (check-? idx)])) 
+      (struct-case x
+        [(known x t)
+         (case (T:vector? t)
+           [(yes) (record-optimization 'check-vector x) (check-vector x idx)]
+           [(no) (interrupt)]
+           [else (check-non-vector x idx)])]
+        [else (check-non-vector x idx)]))
     /section)
 
 (define-primop vector? unsafe
@@ -437,30 +501,31 @@
   [(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 (* i fx-scale)))
-          v)]
+      (if (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 (* i fx-scale)))
+              v))]
+     [(known expr t)
+      (cogen-value-$make-vector expr)]
      [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))])]
+          (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)))]) 
+   (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 
@@ -470,6 +535,8 @@
              (fx>= i 0)
              (prm 'mref (T x) 
                   (K (+ (* i wordsize) (- disp-vector-data vector-tag)))))]
+       [(known i t)
+        (cogen-value-$vector-ref x i)]
        [else #f])
      (prm 'mref (T x) 
         (prm 'int+ (T i) (K (- disp-vector-data vector-tag)))))]
@@ -482,16 +549,30 @@
 
 (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))]
+   (struct-case x
+     [(known x t)
+      (case (T:vector? t)
+        [(yes) (record-optimization 'vector-length x) (cogen-value-$vector-length x)]
+        [(no)  (interrupt)]
+        [else  (cogen-value-vector-length x)])]
+     [else
+      (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)))]
+   (struct-case x
+     [(known x t)
+      (case (T:vector? t)
+        [(yes) (record-optimization 'vector-length x) (nop)]
+        [(no)  (interrupt)]
+        [else  (cogen-effect-vector-length x)])]
+     [else
+      (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))])
 
@@ -512,6 +593,8 @@
       (mem-assign v (T x) 
          (+ (* i wordsize)
             (- disp-vector-data vector-tag)))]
+     [(known i t)
+      (cogen-effect-$vector-set! x i v)]
      [else
       (mem-assign v 
          (prm 'int+ (T x) (T i))
@@ -558,6 +641,7 @@
       (prm 'mref (T x)
          (K (+ (- disp-closure-data closure-tag)
                (* i wordsize))))]
+     [(known) (error 'translate "$cpref")]
      [else (interrupt)])])
 
 /section)
@@ -635,6 +719,7 @@
             (interrupt-when (cogen-pred-$unbound-object? v))
             v)
           (interrupt))]
+     [(known) (error 'translate "top-level-value")]
      [else
       (with-tmp ([x (T x)])
         (interrupt-unless (cogen-pred-symbol? x))
@@ -648,6 +733,7 @@
           (with-tmp ([v (cogen-value-$symbol-value x)])
             (interrupt-when (cogen-pred-$unbound-object? v)))
           (interrupt))]
+     [(known) (error 'translate "top-level-value")]
      [else
       (with-tmp ([x (T x)])
         (interrupt-unless (cogen-pred-symbol? x))
@@ -659,7 +745,6 @@
   [(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))])
 
 
@@ -737,11 +822,13 @@
     [(constant a)
      (unless (fixnum? a) (interrupt))
      (prm 'int* (T b) (K a))]
+    [(known a t) (cogen-value-$fx* a b)]
     [else
      (struct-case b
        [(constant b)
         (unless (fixnum? b) (interrupt))
         (prm 'int* (T a) (K b))]
+       [(known b t) (cogen-value-$fx* a b)]
        [else
         (prm 'int* (T a) (prm 'sra (T b) (K fx-shift)))])])]
   [(P x y) (K #t)]
@@ -778,6 +865,7 @@
      [(constant i) 
       (unless (fixnum? i) (interrupt))
       (prm 'sll (T x) (K i))]
+     [(known i t) (cogen-value-$fxsll x i)]
      [else 
       (prm 'sll (T x) (prm 'sra (T i) (K fx-shift)))])]
   [(P x i) (K #t)]
@@ -791,6 +879,7 @@
       (prm 'logand 
            (prm 'sra (T x) (K (if (> i 31) 31 i)))
            (K (* -1 fx-scale)))]
+     [(known i t) (cogen-value-$fxsra x i)]
      [else 
       (with-tmp ([i (prm 'sra (T i) (K fx-shift))])
         (with-tmp ([i (make-conditional
@@ -880,6 +969,7 @@
              (K (+ i (- disp-bignum-data record-tag))))
            (K 255))
         (K fx-shift))]
+     [(known i t) (cogen-value-$bignum-byte-ref s i)]
      [else
       (prm 'sll
         (prm 'srl ;;; FIXME: bref
@@ -950,6 +1040,7 @@
              (K (+ (- 7 i) (- disp-flonum-data record-tag))))
            (K 255))
         (K fx-shift))]
+     [(known) (error 'translate "$flonum-u8-ref")]
      [else (interrupt)])]
   [(P s i) (K #t)]
   [(E s i) (nop)])
@@ -971,6 +1062,7 @@
       (prm 'bset/h (T x)
          (K (+ (- 7 i) (- disp-flonum-data vector-tag)))
             (prm 'sll (T v) (K (- 8 fx-shift))))]
+     [(known) (error 'translate "$flonum-set!")]
      [else (interrupt)])])
 
 (define-primop $fixnum->flonum unsafe
@@ -992,6 +1084,13 @@
         (if (flonum? v) 
             (check-flonums (cdr ls) code)
             (interrupt))]
+       [(known x t)
+        (case (T:flonum? t)
+          [(yes)
+           (record-optimization 'check-flonum x)
+           (check-flonums (cdr ls) code)]
+          [(no) (interrupt)]
+          [else (check-flonums (cons x (cdr ls)) code)])]
        [else
         (check-flonums (cdr ls) 
           (with-tmp ([x (T (car ls))])
@@ -1188,116 +1287,107 @@
 
 (section ;;; generic arithmetic
 
-(define (non-fixnum? x)
-  (struct-case x
-    [(constant i) (not (fixnum? i))]
-    [else #f]))
 
-(define (or* a a*)
-  (cond
-    [(null? a*) a]
-    [(constant? (car a*)) (or* a (cdr a*))]
-    [else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
 
 (define (assert-fixnums a a*)
-  (cond
-    [(constant? a) 
-     (if (null? a*) 
-         (nop)
-         (assert-fixnums (car a*) (cdr a*)))]
-    [else
-     (interrupt-unless 
-       (tag-test (or* (T a) a*) fx-mask fx-tag))]))
+  (define (or* a a*)
+    (cond
+      [(null? a*) a]
+      [else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
+  (define (known-fixnum? x)
+    (struct-case x
+      [(constant i) (fixnum? i)]
+      [(known x t) 
+       (case (T:fixnum? t)
+         [(yes) (record-optimization 'assert-fixnum x) #t]
+         [else  #f])]
+      [else #f]))
+  (define (known-non-fixnum? x)
+    (struct-case x
+      [(constant i) (not (fixnum? i))]
+      [(known x t) (eq? (T:fixnum? t) 'no)]
+      [else #f]))
+  (let-values ([(fx* others) (partition known-fixnum? (cons a a*))])
+    (let-values ([(nfx* others) (partition known-non-fixnum?  others)])
+      (cond
+        [(not (null? nfx*)) (interrupt)]
+        [(null? others)     (nop)]
+        [else
+         (interrupt-unless 
+           (tag-test (or* (T (car others)) (cdr others)) fx-mask fx-tag))]))))
 
 (define (fixnum-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 (fixnum-fold-e a a*)
-  (cond
-    [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
-    [else (assert-fixnums a a*)]))
+  (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-primop = safe
   [(P) (interrupt)]
   [(P a . a*) (fixnum-fold-p '= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fixnum-fold-e a a*)])
+  [(E a . a*) (assert-fixnums a a*)])
 
 (define-primop < safe
   [(P) (interrupt)]
   [(P a . a*) (fixnum-fold-p '< a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fixnum-fold-e a a*)])
+  [(E a . a*) (assert-fixnums a a*)])
 
 (define-primop <= safe
   [(P) (interrupt)]
   [(P a . a*) (fixnum-fold-p '<= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fixnum-fold-e a a*)])
+  [(E a . a*) (assert-fixnums a a*)])
 
 (define-primop > safe
   [(P) (interrupt)]
   [(P a . a*) (fixnum-fold-p '> a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fixnum-fold-e a a*)])
+  [(E a . a*) (assert-fixnums a a*)])
 
 (define-primop >= safe
   [(P) (interrupt)]
   [(P a . a*) (fixnum-fold-p '>= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (fixnum-fold-e a a*)])
+  [(E a . a*) (assert-fixnums a a*)])
 
 (define-primop - safe
   [(V a) 
-   (cond
-     [(non-fixnum? a) (interrupt)]
-     [else
-      (interrupt)
-      (seq*
-        (assert-fixnums a '())
-        (prm 'int-/overflow (K 0) (T a)))])]
+   (interrupt)
+   (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
-      (interrupt)
-      (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*))])))])]
+   (interrupt)
+   (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
-      (interrupt)
-      (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*))])))])]
+   (interrupt)
+   (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)]
@@ -1314,27 +1404,34 @@
   [(V x) (cogen-value-+ x (K -1))])
 
 
+(define (cogen-binary-* a b)
+  (define (cogen-*-non-constants a b)
+    (interrupt)
+    (with-tmp ([a (T a)] [b (T b)])
+      (assert-fixnum a)
+      (assert-fixnum b)
+      (prm 'int*/overflow a 
+        (prm 'sra b (K fx-shift)))))
+  (define (cogen-*-constant a b)
+    (struct-case a
+      [(constant ak)
+       (if (fx? ak)
+           (begin
+             (interrupt)
+             (with-tmp ([b (T b)])
+                (assert-fixnum b)
+                (prm 'int*/overflow a b)))
+           (interrupt))]
+      [(known x t) (cogen-*-constant x b)]
+      [else #f]))
+  (or (cogen-*-constant a b)
+      (cogen-*-constant b a)
+      (cogen-*-non-constants a b)))
+
+
 (define-primop * safe
   [(V) (K (fxsll 1 fx-shift))]
-  [(V a b) 
-   (struct-case a
-     [(constant ak) 
-      (cond
-        [(fx? ak)
-         (with-tmp ([b (T b)])
-           (assert-fixnum b)
-           (prm 'int*/overflow b a))]
-        [else (interrupt)])]
-     [else 
-      (struct-case b
-        [(constant bk)
-         (cond
-           [(fx? bk) 
-            (with-tmp ([a (T a)])
-              (assert-fixnum a)
-              (prm 'int*/overflow a b))]
-           [else (interrupt)])]
-        [else (interrupt)])])]
+  [(V a b) (cogen-binary-* a b)]
   [(P) (K #t)]
   [(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
   [(E) (nop)]
@@ -1343,17 +1440,14 @@
 (define-primop bitwise-and safe
   [(V) (K (fxsll -1 fx-shift))]
   [(V a . a*)
-   (cond
-     [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)]
-     [else
-      (interrupt)
-      (seq*
-        (assert-fixnums a a*)
-        (let f ([a (T a)] [a* a*])
-          (cond
-            [(null? a*) a]
-            [else
-             (f (prm 'logand a (T (car a*))) (cdr a*))])))])]
+   (interrupt)
+   (seq*
+     (assert-fixnums a a*)
+     (let f ([a (T a)] [a* a*])
+       (cond
+         [(null? a*) a]
+         [else
+          (f (prm 'logand a (T (car a*))) (cdr a*))])))]
   [(P) (K #t)]
   [(P a . a*) (seq* (assert-fixnums a a*) (K #t))]
   [(E) (nop)]
@@ -1367,37 +1461,14 @@
   [(V x y) (cogen-value-- x y)])
 
 (define-primop fx* safe
-  [(V a b) 
-   (struct-case a
-     [(constant ak) 
-      (cond
-        [(fx? ak)
-         (with-tmp ([b (T b)])
-           (assert-fixnum b)
-           (prm 'int*/overflow b a))]
-        [else (interrupt)])]
-     [else 
-      (struct-case b
-        [(constant bk)
-         (cond
-           [(fx? bk) 
-            (with-tmp ([a (T a)])
-              (assert-fixnum a)
-              (prm 'int*/overflow a b))]
-           [else (interrupt)])]
-        [else 
-         (with-tmp ([a (T a)] [b (T b)])
-           (assert-fixnum a)
-           (assert-fixnum b)
-           (prm 'int*/overflow 
-             (prm 'sra a (K fx-shift)) b))])])])
+  [(V a b) (cogen-binary-* a b)])
 
 (define-primop zero? safe
   [(P x)
    (seq*
-     (interrupt-unless (cogen-pred-fixnum? x))
+     (assert-fixnum x)
      (cogen-pred-$fxzero? x))]
-  [(E x) (interrupt-unless (cogen-pred-fixnum? x))])
+  [(E x) (assert-fixnum x)])
 
 
 (define-primop fxarithmetic-shift-left safe
@@ -1444,7 +1515,6 @@
       [else #f])))
 
 
-
 (define-primop div safe
   [(V x n) 
    (struct-case n 
@@ -1459,6 +1529,7 @@
                (K fx-shift))))]
         [else
          (interrupt)])]
+     [(known) (error 'translate "div")]
      [else (interrupt)])])
 
 (define-primop quotient safe
@@ -1479,6 +1550,7 @@
                (prm 'sra (T x) (K 1))
                (K (fxsll -1 fx-shift)))))
          (interrupt))]
+    [(known expr t) (cogen-value-quotient x expr)]
     [else (interrupt)])])
 
 /section)
@@ -1507,6 +1579,8 @@
                          (K vector-tag))])
         (prm 'mset t (K (- disp-struct-rtd vector-tag)) (T rtd))
         t)]
+     [(known expr t)
+      (cogen-value-$make-struct rtd expr)]
      [else
       (with-tmp ([ln (align-code len disp-struct-data)])
         (with-tmp ([t (prm 'alloc ln (K vector-tag))])
@@ -1594,71 +1668,74 @@
   [(P x) (K #t)]
   [(E x) (nop)])
 
-(define (non-char? x)
-  (struct-case x
-    [(constant i) (not (char? i))]
-    [else #f]))
 
 (define (assert-chars a a*)
-  (cond
-    [(constant? a) 
-     (if (null? a*) 
-         (nop)
-         (assert-chars (car a*) (cdr a*)))]
-    [else
-     (interrupt-unless 
-       (tag-test (or* (T a) a*) char-mask char-tag))]))
+  (define (or* a a*)
+    (cond
+      [(null? a*) a]
+      [else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
+  (define (known-char? x)
+    (struct-case x
+      [(constant i) (char? i)]
+      [(known x t) (eq? (T:char? t) 'yes)]
+      [else #f]))
+  (define (known-non-char? x)
+    (struct-case x
+      [(constant i) (not (char? i))]
+      [(known x t) (eq? (T:char? t) 'no)]
+      [else #f]))
+  (let-values ([(fx* others) (partition known-char? (cons a a*))])
+    (let-values ([(nfx* others) (partition known-non-char?  others)])
+      (cond
+        [(not (null? nfx*)) (interrupt)]
+        [(null? others)     (nop)]
+        [else
+         (interrupt-unless 
+           (tag-test (or* (T (car others)) (cdr others)) char-mask char-tag))]))))
 
 (define (char-fold-p op a a*)
-  (cond
-    [(or (non-char? a) (ormap non-char? a*)) (interrupt)]
-    [else
-     (seq*
-       (assert-chars 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)))])))]))
+  (seq*
+    (assert-chars 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 (char-fold-e a a*)
-  (cond
-    [(or (non-char? a) (ormap non-char? a*)) (interrupt)]
-    [else (assert-chars a a*)]))
 
 (define-primop char=? safe
   [(P) (interrupt)]
   [(P a . a*) (char-fold-p '= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (char-fold-e a a*)])
+  [(E a . a*) (assert-chars a a*)])
 
 (define-primop char<? safe
   [(P) (interrupt)]
   [(P a . a*) (char-fold-p '< a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (char-fold-e a a*)])
+  [(E a . a*) (assert-chars a a*)])
 
 (define-primop char<=? safe
   [(P) (interrupt)]
   [(P a . a*) (char-fold-p '<= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (char-fold-e a a*)])
+  [(E a . a*) (assert-chars a a*)])
 
 (define-primop char>? safe
   [(P) (interrupt)]
   [(P a . a*) (char-fold-p '> a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (char-fold-e a a*)])
+  [(E a . a*) (assert-chars a a*)])
 
 (define-primop char>=? safe
   [(P) (interrupt)]
   [(P a . a*) (char-fold-p '>= a a*)]
   [(E) (interrupt)]
-  [(E a . a*) (char-fold-e a a*)])
+  [(E a . a*) (assert-chars a a*)])
 
 /section)
 
@@ -1683,6 +1760,8 @@
              (K (+ n (- disp-bytevector-data bytevector-tag)))
              (K 0))
          s)]
+     [(known expr t)
+      (cogen-value-$make-bytevector expr)]
      [else
       (with-tmp ([s (prm 'alloc 
                       (align-code 
@@ -1937,6 +2016,8 @@
              (K (- disp-string-length string-tag))
              (K (* n fx-scale)))
          s)]
+     [(known expr) 
+      (cogen-value-$make-string expr)]
      [else
       (with-tmp ([s (prm 'alloc 
                       (align-code (T n) disp-string-data)
@@ -1973,15 +2054,27 @@
   [(P s i) (K #t)]
   [(E s i) (nop)])
 
-(define (assert-fixnum x)
-  (struct-case x
-    [(constant i) 
-     (if (fixnum? i) (nop) (interrupt))]
-    [else (interrupt-unless (cogen-pred-fixnum? x))]))
+(define assert-fixnum 
+  (case-lambda 
+    [(x)
+     (struct-case x
+       [(constant i) 
+        (if (fixnum? i) (nop) (interrupt))]
+       [(known expr t)
+        (case (T:fixnum? t)
+          [(yes) (nop)]
+          [(no)  (interrupt)]
+          [else  (assert-fixnum expr)])]
+       [else (interrupt-unless (cogen-pred-fixnum? x))])]))
 
 (define (assert-string x)
   (struct-case x
     [(constant s) (if (string? s) (nop) (interrupt))]
+    [(known expr t)
+     (case (T:string? t)
+       [(yes) (record-optimization 'assert-string x) (nop)]
+       [(no)  (interrupt)]
+       [else  (assert-string expr)])]
     [else (interrupt-unless (cogen-pred-string? x))]))
 
 (define-primop string-ref safe
@@ -2003,7 +2096,6 @@
      (assert-string s)
      (interrupt-unless (prm 'u< (T i) (cogen-value-$string-length s))))])
 
-
 (define-primop $string-set! unsafe
   [(E x i c)
    (struct-case i
diff --git a/scheme/pass-specify-rep.ss b/scheme/pass-specify-rep.ss
index 1599b86..a1bb299 100644
--- a/scheme/pass-specify-rep.ss
+++ b/scheme/pass-specify-rep.ss
@@ -44,7 +44,6 @@
   )
 
 (module (specify-representation)
-  ;(import object-representation)
   (import primops)
   (define-struct PH
     (interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?))
@@ -108,6 +107,14 @@
                      (prm '!= (make-no-interrupt-call x args) (K bool-f))
                      (make-shortcut body h)))]
              [else (error 'with-interrupt-handler "invalid context" ctxt)])))]))
+  (define (copy-tag orig new)
+    (struct-case orig
+      [(known _ t) (make-known new t)]
+      [else new]))
+  (define (remove-tag x)
+    (struct-case x
+      [(known expr t) expr]
+      [else x]))
   (define-syntax with-tmp
     (lambda (x)
       (syntax-case x ()
@@ -116,7 +123,7 @@
            #'(let ([lhs* rhs*] ...)
                (let ([n* (unique-var 'lhs*)] ...)
                  (make-bind (list n* ...) (list lhs* ...)
-                    (let ([lhs* n*] ...)
+                    (let ([lhs* (copy-tag lhs* n*)] ...)
                       (seq* b b* ...))))))])))
   ;;; if ctxt is V:
   ;;;   if cogen-value, then V
@@ -140,11 +147,17 @@
          (let-values ([(lhs* rhs* arg*) (S* (cdr ls))])
            (let ([a (car ls)])
              (struct-case a
-               [(known expr type v)
-                (let ([tmp (unique-var 'tmp)])
-                  (values (cons tmp lhs*)
-                          (cons (V expr) rhs*)
-                          (cons (make-known tmp type v) arg*)))]
+               [(known expr type)
+                (struct-case expr
+                  [(constant i)
+                   ;;; erase known tag
+                   (values lhs* rhs* (cons expr arg*))]
+                  [else
+                   ;(printf "known ~s ~s\n" type expr)
+                   (let ([tmp (unique-var 'tmp)])
+                     (values (cons tmp lhs*)
+                             (cons (V expr) rhs*)
+                             (cons (make-known tmp type) arg*)))])]
                [(constant i)
                 (values lhs* rhs* (cons a arg*))]
                [else
@@ -353,7 +366,7 @@
 
   (define (V x) ;;; erase known values
     (struct-case x 
-      [(known x type value)
+      [(known x t)
        (unknown-V x)]
       [else (unknown-V x)]))
 
@@ -439,43 +452,59 @@
       [else (error 'cogen-E "invalid effect expr" 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 "not a procedure") x))))))
-    (struct-case x
-       [(primcall op args)
+    (define (Function x check?)
+      (define (nonproc x check?)
         (cond
-          [(and (eq? op 'top-level-value)
-                (= (length args) 1)
-                (struct-case (car args)
-                  [(constant t) 
-                   (and (symbol? t) t)]
-                  [else #f])) =>
-           (lambda (sym)
-             (record-symbol-call! sym)
-             (reset-symbol-proc! sym)
-             (prm 'mref (T (K sym))
-                  (K (- disp-symbol-record-proc symbol-ptag))))]
-          [else (nonproc x)])]
-       [(primref op) (V x)]
-       [else (nonproc x)]))
+          [check?
+           (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 "not a procedure") x)))))]
+          [else
+           (V x)]))
+      (struct-case x
+         [(primcall op args)
+          (cond
+            [(and (eq? op 'top-level-value)
+                  (= (length args) 1)
+                  (let f ([x (car args)])
+                    (struct-case x
+                      [(constant x) 
+                       (and (symbol? x) x)]
+                      [(known x t) (f x)]
+                      [else #f]))) =>
+             (lambda (sym)
+               (reset-symbol-proc! sym)
+               (prm 'mref (T (K sym))
+                    (K (- disp-symbol-record-proc symbol-ptag))))]
+            [else (nonproc x check?)])]
+         [(primref op) (V x)]
+         [(known x t v)
+          (cond
+            [(eq? (T:procedure? t) 'yes)
+             ;(record-optimization 'procedure x)
+             (Function x #f)]
+            [else (Function x check?)])]
+         [else (nonproc x check?)]))
+    (Function x #t))
 
 
-  (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 record-optimization^
+    (let ([h (make-eq-hashtable)])
+      (lambda (what expr)
+        (let ([n (hashtable-ref h what 0)])
+          (hashtable-set! h what (+ n 1))
+          (printf "optimize ~a[~s]: ~s\n" what n (unparse expr))))))
+  (define-syntax record-optimization
+    (syntax-rules ()
+      [(_ what expr) (void)]))
 
   ;;;========================================================================
   ;;;
@@ -491,7 +520,8 @@
     (struct-case x
       [(var) x]
       [(constant i) (constant-rep x)]
-      [(known expr type val) (T expr)]
+      [(known expr type)
+       (make-known (T expr) type)]
       [else (error 'cogen-T "invalid" (unparse x))]))
 
   (define (ClambdaCase x)