From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 10 Feb 2008 06:14:19 +0000 (+0000)
Subject: Change lots of global primitives to be defined as compound procedures.
X-Git-Tag: 20090517-FFI~341
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e5a7698c1f021908792368b23305332ede40cbbf;p=mit-scheme.git

Change lots of global primitives to be defined as compound procedures.
The compiler will still open-code them appropriately when the appear
in the operator position.  However, this change means that
non-operator references to these primitives avoid passing a primitive
object around, which improves performance when the object is
eventually called.
---

diff --git a/v7/src/runtime/boole.scm b/v7/src/runtime/boole.scm
index 20b815fc8..61e4f7e40 100644
--- a/v7/src/runtime/boole.scm
+++ b/v7/src/runtime/boole.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: boole.scm,v 14.10 2008/01/30 20:02:28 cph Exp $
+$Id: boole.scm,v 14.11 2008/02/10 06:14:02 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,7 +30,8 @@ USA.
 
 (declare (usual-integrations))
 
-(define-primitives not (false? not))
+(define-integrable (not object)
+  ((ucode-primitive not) object))
 
 (define false #f)
 (define true #t)
diff --git a/v7/src/runtime/boot.scm b/v7/src/runtime/boot.scm
index 12c4b2b4d..a179e2062 100644
--- a/v7/src/runtime/boot.scm
+++ b/v7/src/runtime/boot.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: boot.scm,v 14.29 2008/01/30 20:02:28 cph Exp $
+$Id: boot.scm,v 14.30 2008/02/10 06:14:03 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -111,10 +111,11 @@ USA.
 (define-integrable interrupt-mask/all      #xFFFF)
 
 (define (with-absolutely-no-interrupts thunk)
-  (with-interrupt-mask interrupt-mask/none
-    (lambda (interrupt-mask)
-      interrupt-mask
-      (thunk))))
+  ((ucode-primitive with-interrupt-mask)
+   interrupt-mask/none
+   (lambda (interrupt-mask)
+     interrupt-mask
+     (thunk))))
 
 (define (without-interrupts thunk)
   (with-limited-interrupts interrupt-mask/gc-ok
@@ -123,12 +124,15 @@ USA.
       (thunk))))
 
 (define (with-limited-interrupts limit-mask procedure)
-  (with-interrupt-mask (fix:and limit-mask (get-interrupt-enables))
-    procedure))
+  ((ucode-primitive with-interrupt-mask)
+   (fix:and limit-mask (get-interrupt-enables))
+   procedure))
+
+(define (object-constant? object)
+  ((ucode-primitive constant?) object))
 
-(define-primitives
-  (object-constant? constant?)
-  gc-space-status)
+(define (gc-space-status)
+  ((ucode-primitive gc-space-status)))
 
 (define (object-pure? object)
   object
@@ -138,4 +142,4 @@ USA.
   (eq? object (default-object)))
 
 (define-integrable (default-object)
-  (object-new-type (ucode-type constant) 7))
\ No newline at end of file
+  ((ucode-primitive object-set-type) (ucode-type constant) 7))
\ No newline at end of file
diff --git a/v7/src/runtime/char.scm b/v7/src/runtime/char.scm
index 73c7a8074..2b4cec716 100644
--- a/v7/src/runtime/char.scm
+++ b/v7/src/runtime/char.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: char.scm,v 14.34 2008/01/30 20:02:28 cph Exp $
+$Id: char.scm,v 14.35 2008/02/10 06:14:04 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,10 +30,14 @@ USA.
 
 (declare (usual-integrations))
 
-(define-primitives
-  (char? 1)
-  char->integer
-  integer->char)
+(define-integrable (char? object)
+  ((ucode-primitive char?) object))
+
+(define-integrable (char->integer char)
+  ((ucode-primitive char->integer) char))
+
+(define-integrable (integer->char int)
+  ((ucode-primitive integer->char) int))
 
 (define-integrable char-code-limit #x110000)
 (define-integrable char-bits-limit #x10)
diff --git a/v7/src/runtime/fixart.scm b/v7/src/runtime/fixart.scm
index ed1350bea..fa452e980 100644
--- a/v7/src/runtime/fixart.scm
+++ b/v7/src/runtime/fixart.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fixart.scm,v 1.18 2008/01/30 20:02:30 cph Exp $
+$Id: fixart.scm,v 1.19 2008/02/10 06:14:05 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,85 +30,89 @@ USA.
 
 (declare (usual-integrations))
 
-(define-primitives
-  (fix:fixnum? fixnum? 1)
-  (fixnum? fixnum? 1)
-  (index-fixnum? index-fixnum? 1)
-  (fix:zero? zero-fixnum? 1)
-  (fix:negative? negative-fixnum? 1)
-  (fix:positive? positive-fixnum? 1)
-  (fix:= equal-fixnum? 2)
-  (fix:< less-than-fixnum? 2)
-  (fix:> greater-than-fixnum? 2)
-  (fix:1+ one-plus-fixnum 1)
-  (fix:-1+ minus-one-plus-fixnum 1)
-  (fix:+ plus-fixnum 2)
-  (fix:- minus-fixnum 2)
-  (fix:* multiply-fixnum 2)
-  (fix:divide divide-fixnum 2)
-  (fix:quotient fixnum-quotient 2)
-  (fix:remainder fixnum-remainder 2)
-  (fix:gcd gcd-fixnum 2)
-  (fix:andc fixnum-andc 2)
-  (fix:and fixnum-and 2)
-  (fix:or fixnum-or 2)
-  (fix:xor fixnum-xor 2)
-  (fix:not fixnum-not 1)
-  (fix:lsh fixnum-lsh 2)
-
-  (int:integer? integer? 1)
-  (int:zero? integer-zero? 1)
-  (int:positive? integer-positive? 1)
-  (int:negative? integer-negative? 1)
-  (int:= integer-equal? 2)
-  (int:< integer-less? 2)
-  (int:> integer-greater? 2)
-  (int:negate integer-negate 1)
-  (int:1+ integer-add-1 1)
-  (int:-1+ integer-subtract-1 1)
-  (int:+ integer-add 2)
-  (int:- integer-subtract 2)
-  (int:* integer-multiply 2)
-  (int:divide integer-divide 2)
-  (int:quotient integer-quotient 2)
-  (int:remainder integer-remainder 2)
-
-  (flo:flonum? flonum? 1)
-  (flo:zero? flonum-zero? 1)
-  (flo:positive? flonum-positive? 1)
-  (flo:negative? flonum-negative? 1)
-  (flo:= flonum-equal? 2)
-  (flo:< flonum-less? 2)
-  (flo:> flonum-greater? 2)
-  (flo:+ flonum-add 2)
-  (flo:- flonum-subtract 2)
-  (flo:* flonum-multiply 2)
-  (flo:/ flonum-divide 2)
-  (flo:negate flonum-negate 1)
-  (flo:abs flonum-abs 1)
-  (flo:exp flonum-exp 1)
-  (flo:log flonum-log 1)
-  (flo:sin flonum-sin 1)
-  (flo:cos flonum-cos 1)
-  (flo:tan flonum-tan 1)
-  (flo:asin flonum-asin 1)
-  (flo:acos flonum-acos 1)
-  (flo:atan flonum-atan 1)
-  (flo:atan2 flonum-atan2 2)
-  (flo:sqrt flonum-sqrt 1)
-  (flo:expt flonum-expt 2)
-  (flo:floor flonum-floor 1)
-  (flo:ceiling flonum-ceiling 1)
-  (flo:truncate flonum-truncate 1)
-  (flo:round flonum-round 1)
-  (flo:floor->exact flonum-floor->exact 1)
-  (flo:ceiling->exact flonum-ceiling->exact 1)
-  (flo:truncate->exact flonum-truncate->exact 1)
-  (flo:round->exact flonum-round->exact 1)
-  (flo:vector-cons floating-vector-cons 1)
-  (flo:vector-length floating-vector-length 1)
-  (flo:vector-ref floating-vector-ref 2)
-  (flo:vector-set! floating-vector-set! 3))
+(define-unary-primitive fix:-1+ minus-one-plus-fixnum)
+(define-unary-primitive fix:1+ one-plus-fixnum)
+(define-unary-primitive fix:fixnum? fixnum?)
+(define-unary-primitive fix:negative? negative-fixnum?)
+(define-unary-primitive fix:not fixnum-not)
+(define-unary-primitive fix:positive? positive-fixnum?)
+(define-unary-primitive fix:zero? zero-fixnum?)
+(define-unary-primitive fixnum? fixnum?)
+(define-unary-primitive index-fixnum? index-fixnum?)
+
+(define-binary-primitive fix:= equal-fixnum?)
+(define-binary-primitive fix:< less-than-fixnum?)
+(define-binary-primitive fix:> greater-than-fixnum?)
+(define-binary-primitive fix:+ plus-fixnum)
+(define-binary-primitive fix:- minus-fixnum)
+(define-binary-primitive fix:* multiply-fixnum)
+(define-binary-primitive fix:divide divide-fixnum)
+(define-binary-primitive fix:quotient fixnum-quotient)
+(define-binary-primitive fix:remainder fixnum-remainder)
+(define-binary-primitive fix:gcd gcd-fixnum)
+(define-binary-primitive fix:andc fixnum-andc)
+(define-binary-primitive fix:and fixnum-and)
+(define-binary-primitive fix:or fixnum-or)
+(define-binary-primitive fix:xor fixnum-xor)
+(define-binary-primitive fix:lsh fixnum-lsh)
+
+(define-unary-primitive int:-1+ integer-subtract-1)
+(define-unary-primitive int:1+ integer-add-1)
+(define-unary-primitive int:integer? integer?)
+(define-unary-primitive int:negate integer-negate)
+(define-unary-primitive int:negative? integer-negative?)
+(define-unary-primitive int:positive? integer-positive?)
+(define-unary-primitive int:zero? integer-zero?)
+
+(define-binary-primitive int:= integer-equal?)
+(define-binary-primitive int:< integer-less?)
+(define-binary-primitive int:> integer-greater?)
+(define-binary-primitive int:+ integer-add)
+(define-binary-primitive int:- integer-subtract)
+(define-binary-primitive int:* integer-multiply)
+(define-binary-primitive int:divide integer-divide)
+(define-binary-primitive int:quotient integer-quotient)
+(define-binary-primitive int:remainder integer-remainder)
+
+(define-unary-primitive flo:abs flonum-abs)
+(define-unary-primitive flo:acos flonum-acos)
+(define-unary-primitive flo:asin flonum-asin)
+(define-unary-primitive flo:atan flonum-atan)
+(define-unary-primitive flo:ceiling flonum-ceiling)
+(define-unary-primitive flo:ceiling->exact flonum-ceiling->exact)
+(define-unary-primitive flo:cos flonum-cos)
+(define-unary-primitive flo:exp flonum-exp)
+(define-unary-primitive flo:flonum? flonum?)
+(define-unary-primitive flo:floor flonum-floor)
+(define-unary-primitive flo:floor->exact flonum-floor->exact)
+(define-unary-primitive flo:log flonum-log)
+(define-unary-primitive flo:negate flonum-negate)
+(define-unary-primitive flo:negative? flonum-negative?)
+(define-unary-primitive flo:positive? flonum-positive?)
+(define-unary-primitive flo:round flonum-round)
+(define-unary-primitive flo:round->exact flonum-round->exact)
+(define-unary-primitive flo:sin flonum-sin)
+(define-unary-primitive flo:sqrt flonum-sqrt)
+(define-unary-primitive flo:tan flonum-tan)
+(define-unary-primitive flo:truncate flonum-truncate)
+(define-unary-primitive flo:truncate->exact flonum-truncate->exact)
+(define-unary-primitive flo:vector-cons floating-vector-cons)
+(define-unary-primitive flo:vector-length floating-vector-length)
+(define-unary-primitive flo:zero? flonum-zero?)
+
+(define-binary-primitive flo:= flonum-equal?)
+(define-binary-primitive flo:< flonum-less?)
+(define-binary-primitive flo:> flonum-greater?)
+(define-binary-primitive flo:+ flonum-add)
+(define-binary-primitive flo:- flonum-subtract)
+(define-binary-primitive flo:* flonum-multiply)
+(define-binary-primitive flo:/ flonum-divide)
+(define-binary-primitive flo:atan2 flonum-atan2)
+(define-binary-primitive flo:expt flonum-expt)
+(define-binary-primitive flo:vector-ref floating-vector-ref)
+
+(define-integrable (flo:vector-set! v i x)
+  ((ucode-primitive floating-vector-set!) v i x))
 
 (define-integrable (guarantee-index-fixnum object caller)
   (if (not (index-fixnum? object))
diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm
index 12a0a0c8b..200bcd315 100644
--- a/v7/src/runtime/gc.scm
+++ b/v7/src/runtime/gc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gc.scm,v 14.27 2008/01/30 20:02:30 cph Exp $
+$Id: gc.scm,v 14.28 2008/02/10 06:14:06 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -40,7 +40,7 @@ USA.
   (set! constant-space-queue (list 'CONSTANT-SPACE-QUEUE))
   (set! hook/gc-start default/gc-start)
   (set! hook/gc-finish default/gc-finish)
-  (let ((fixed-objects (get-fixed-objects-vector)))
+  (let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
     (let ((interrupt-vector (vector-ref fixed-objects 1)))
       (vector-set! interrupt-vector 0 condition-handler/stack-overflow)
       (vector-set! interrupt-vector 2 condition-handler/gc))
diff --git a/v7/src/runtime/gcdemn.scm b/v7/src/runtime/gcdemn.scm
index 6993f33f4..0b4f5ff2f 100644
--- a/v7/src/runtime/gcdemn.scm
+++ b/v7/src/runtime/gcdemn.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gcdemn.scm,v 14.14 2008/01/30 20:02:30 cph Exp $
+$Id: gcdemn.scm,v 14.15 2008/02/10 06:14:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -40,7 +40,7 @@ USA.
   (set! secondary-gc-daemons (make-queue))
   (set! trigger-secondary-gc-daemons! (make-trigger secondary-gc-daemons))
   (set! add-secondary-gc-daemon! (make-adder secondary-gc-daemons))
-  (let ((fixed-objects (get-fixed-objects-vector)))
+  (let ((fixed-objects ((ucode-primitive get-fixed-objects-vector))))
     (vector-set! fixed-objects #x0B trigger-primitive-gc-daemons!)
     ((ucode-primitive set-fixed-objects-vector!) fixed-objects)))
 
diff --git a/v7/src/runtime/gentag.scm b/v7/src/runtime/gentag.scm
index bded8f976..9ff801ad8 100644
--- a/v7/src/runtime/gentag.scm
+++ b/v7/src/runtime/gentag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: gentag.scm,v 1.9 2008/01/30 20:02:31 cph Exp $
+$Id: gentag.scm,v 1.10 2008/02/10 06:14:08 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -36,7 +36,7 @@ USA.
 
 (define (make-dispatch-tag contents)
   (let ((tag
-	 (object-new-type
+	 ((ucode-primitive object-set-type)
 	  (ucode-type record)
 	  ((ucode-primitive vector-cons) dispatch-tag-index-end #f))))
     (%record-set! tag 0 dispatch-tag-marker)
@@ -55,8 +55,12 @@ USA.
 
 (define-integrable dispatch-tag-index-start 2)
 (define-integrable dispatch-tag-index-end 10)
-(define-integrable dispatch-tag-ref %record-ref)
-(define-integrable dispatch-tag-set! %record-set!)
+
+(define-integrable (dispatch-tag-ref t i)
+  (%record-ref t i))
+
+(define-integrable (dispatch-tag-set! t i x)
+  (%record-set! t i x))
 
 (define (dispatch-tag-contents tag)
   (guarantee-dispatch-tag tag 'DISPATCH-TAG-CONTENTS)
diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index d59a059c5..384c3e162 100644
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.81 2008/01/30 20:02:31 cph Exp $
+$Id: global.scm,v 14.82 2008/02/10 06:14:09 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -34,42 +34,92 @@ USA.
 
 (define-primitives
   error-procedure
-  get-interrupt-enables set-interrupt-enables! with-interrupt-mask
+  set-interrupt-enables! with-interrupt-mask
   get-fixed-objects-vector with-history-disabled
-  (primitive-procedure-arity 1)
-  (primitive-procedure-documentation 1)
+  primitive-procedure-arity primitive-procedure-documentation
 
   ;; Environment
   lexical-reference lexical-assignment local-assignment
   lexical-unassigned? lexical-unbound? lexical-unreferenceable?
 
   ;; Pointers
-  (object-type 1)
-  (object-datum 1)
-  (object-type? 2)
-  (object-new-type object-set-type 2)
+  object-datum
+  (object-new-type object-set-type)
   make-non-pointer-object
-  eq?
 
   ;; Cells
   make-cell cell? cell-contents set-cell-contents!
 
-  ;; System Compound Datatypes
-  system-pair-cons system-pair?
-  system-pair-car system-pair-set-car!
-  system-pair-cdr system-pair-set-cdr!
-
-  hunk3-cons
-  system-hunk3-cxr0 system-hunk3-set-cxr0!
-  system-hunk3-cxr1 system-hunk3-set-cxr1!
-  system-hunk3-cxr2 system-hunk3-set-cxr2!
-
-  (system-list->vector system-list-to-vector)
-  (system-subvector->list system-subvector-to-list)
-  system-vector?
-  (system-vector-length system-vector-size)
-  system-vector-ref
-  system-vector-set!)
+  )
+
+(define-integrable (eq? x y)
+  ((ucode-primitive eq?) x y))
+
+(define-integrable (get-interrupt-enables)
+  ((ucode-primitive get-interrupt-enables)))
+
+(define-integrable (object-type object)
+  ((ucode-primitive object-type) object))
+
+(define-integrable (object-type? type object)
+  ((ucode-primitive object-type?) type object))
+
+(define-integrable (system-pair? object)
+  ((ucode-primitive system-pair?) object))
+
+(define-integrable (system-pair-cons type a b)
+  ((ucode-primitive system-pair-cons) type a b))
+
+(define-integrable (system-pair-car p)
+  ((ucode-primitive system-pair-car) p))
+
+(define-integrable (system-pair-cdr p)
+  ((ucode-primitive system-pair-cdr) p))
+
+(define-integrable (system-pair-set-car! p o)
+  ((ucode-primitive system-pair-set-car!) p o))
+
+(define-integrable (system-pair-set-cdr! p o)
+  ((ucode-primitive system-pair-set-cdr!) p o))
+
+(define-integrable (system-vector? object)
+  ((ucode-primitive system-vector?) object))
+
+(define-integrable (system-vector-ref v i)
+  ((ucode-primitive system-vector-ref) v i))
+
+(define-integrable (system-vector-set! v i x)
+  ((ucode-primitive system-vector-set!) v i x))
+
+(define-integrable (system-vector-length v)
+  ((ucode-primitive system-vector-size) v))
+
+(define-integrable (system-list->vector type list)
+  ((ucode-primitive system-list-to-vector) type list))
+
+(define-integrable (system-subvector->list v s e)
+  ((ucode-primitive system-subvector-to-list) v s e))
+
+(define-integrable (hunk3-cons x0 x1 x2)
+  ((ucode-primitive hunk3-cons) x0 x1 x2))
+
+(define-integrable (system-hunk3-cxr0 h3)
+  ((ucode-primitive system-hunk3-cxr0) h3))
+
+(define-integrable (system-hunk3-cxr1 h3)
+  ((ucode-primitive system-hunk3-cxr1) h3))
+
+(define-integrable (system-hunk3-cxr2 h3)
+  ((ucode-primitive system-hunk3-cxr2) h3))
+
+(define-integrable (system-hunk3-set-cxr0! h3 o)
+  ((ucode-primitive system-hunk3-set-cxr0!) h3 o))
+
+(define-integrable (system-hunk3-set-cxr1! h3 o)
+  ((ucode-primitive system-hunk3-set-cxr1!) h3 o))
+
+(define-integrable (system-hunk3-set-cxr2! h3 o)
+  ((ucode-primitive system-hunk3-set-cxr2!) h3 o))
 
 (define (host-big-endian?)
   host-big-endian?-saved)
diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm
index 018412b9e..179398969 100644
--- a/v7/src/runtime/list.scm
+++ b/v7/src/runtime/list.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: list.scm,v 14.57 2008/01/30 20:02:32 cph Exp $
+$Id: list.scm,v 14.58 2008/02/10 06:14:10 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -59,8 +59,29 @@ USA.
 
 (declare (usual-integrations))
 
-(define-primitives
-  cons pair? null? car cdr set-car! set-cdr! general-car-cdr)
+(define-integrable (cons a b)
+  ((ucode-primitive cons) a b))
+
+(define-integrable (pair? object)
+  ((ucode-primitive pair?) object))
+
+(define-integrable (null? object)
+  ((ucode-primitive null?) object))
+
+(define-integrable (car p)
+  ((ucode-primitive car) p))
+
+(define-integrable (cdr p)
+  ((ucode-primitive cdr) p))
+
+(define-integrable (set-car! p v)
+  ((ucode-primitive set-car!) p v))
+
+(define-integrable (set-cdr! p v)
+  ((ucode-primitive set-cdr!) p v))
+
+(define-integrable (general-car-cdr p i)
+  ((ucode-primitive general-car-cdr) p i))
 
 (define (list . items)
   items)
@@ -112,7 +133,7 @@ USA.
 
 (define (xcons d a)
   (cons a d))
-
+
 (define (iota count #!optional start step)
   (guarantee-index-fixnum count 'IOTA)
   (let ((start
@@ -131,7 +152,7 @@ USA.
       (if (fix:> count 0)
 	  (cons value (loop (fix:- count 1) (+ value step)))
 	  '()))))
-
+
 (define (list? object)
   (let loop ((l1 object) (l2 object))
     (if (pair? l1)
diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 35bcd8ac5..ddc009b76 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.114 2008/02/02 18:20:59 cph Exp $
+$Id: make.scm,v 14.115 2008/02/10 06:14:11 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,13 +30,13 @@ USA.
 
 (declare (usual-integrations))
 
-(set-interrupt-enables! 0)
+((ucode-primitive set-interrupt-enables!) 0)
 
 ;; This must be defined as follows so that it is no part of a multi-define
 ;; itself.  It must also precede any other top-level definitions in this file
 ;; that are not performed directly using LOCAL-ASSIGNMENT.
 
-(local-assignment
+((ucode-primitive local-assignment)
  #f ;global environment
  'DEFINE-MULTIPLE
  (lambda (env names values)
@@ -48,9 +48,9 @@ USA.
      (let loop ((i 0) (val unspecific))
        (if (fix:< i len)
 	   (loop (fix:+ i 1)
-		 (local-assignment env
-				   (vector-ref names i)
-				   (vector-ref values i)))
+		 ((ucode-primitive local-assignment) env
+						     (vector-ref names i)
+						     (vector-ref values i)))
 	   val)))))
 
 (define system-global-environment #f)
@@ -60,37 +60,20 @@ USA.
 ;; *MAKE-ENVIRONMENT is referred to by compiled code.  It must go
 ;; before the uses of the-environment later, and after apply above.
 (define (*make-environment parent names . values)
-  (let-syntax
-      ((ucode-type
-	(sc-macro-transformer
-	 (lambda (form environment)
-	   environment
-	   (microcode-type (cadr form))))))
-    (system-list->vector
-     (ucode-type environment)
-     (cons (system-pair-cons (ucode-type procedure)
-			     (system-pair-cons (ucode-type lambda)
-					       unspecific
-					       names)
-			     parent)
-	   values))))
+  ((ucode-primitive system-list-to-vector)
+   (ucode-type environment)
+   (cons ((ucode-primitive system-pair-cons)
+	  (ucode-type procedure)
+	  ((ucode-primitive system-pair-cons) (ucode-type lambda)
+					      unspecific
+					      names)
+	  parent)
+	 values)))
 
 (let ((environment-for-package
        (*make-environment system-global-environment
 			  (vector lambda-tag:unnamed))))
 
-(define-syntax ucode-primitive
-  (sc-macro-transformer
-   (lambda (form environment)
-     environment
-     (apply make-primitive-procedure (cdr form)))))
-
-(define-syntax ucode-type
-  (sc-macro-transformer
-   (lambda (form environment)
-     environment
-     (microcode-type (cadr form)))))
-
 (define-integrable + (ucode-primitive integer-add))
 (define-integrable - (ucode-primitive integer-subtract))
 (define-integrable < (ucode-primitive integer-less?))
@@ -300,7 +283,8 @@ USA.
 
 (define (implemented-primitive-procedure? primitive)
   ((ucode-primitive get-primitive-address)
-   (intern ((ucode-primitive get-primitive-name) (object-datum primitive)))
+   (intern ((ucode-primitive get-primitive-name)
+	    ((ucode-primitive object-datum) primitive)))
    #f))
 
 (define initialize-c-compiled-block
diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index 0f10c8ab7..8c2e7520f 100644
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: packag.scm,v 14.58 2008/02/02 18:20:19 cph Exp $
+$Id: packag.scm,v 14.59 2008/02/10 06:14:12 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -422,11 +422,12 @@ USA.
 							 #f
 							 vn)
 				       environment))
-	(object-new-type (ucode-type environment) vv)))))
+	((ucode-primitive object-set-type) (ucode-type environment) vv)))))
 
 (define null-environment
-  (object-new-type (object-type #f)
-		   (fix:xor (object-datum #F) 1)))
+  ((ucode-primitive object-set-type)
+   ((ucode-primitive object-type) #f)
+   (fix:xor ((ucode-primitive object-datum) #F) 1)))
 
 (define (find-package-environment name)
   (package/environment (find-package name)))
@@ -441,7 +442,9 @@ USA.
   (primitive-object-set-type (ucode-type reference-trap) 0))
 
 (define-primitives
+  lexical-reference
   lexical-unbound?
+  lexical-unreferenceable?
   link-variables
   local-assignment
   primitive-object-set-type)
diff --git a/v7/src/runtime/random.scm b/v7/src/runtime/random.scm
index ac44619da..2631998a9 100644
--- a/v7/src/runtime/random.scm
+++ b/v7/src/runtime/random.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: random.scm,v 14.41 2008/01/30 20:02:34 cph Exp $
+$Id: random.scm,v 14.42 2008/02/10 06:14:13 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -54,7 +54,7 @@ USA.
 (define-integrable b. 4294967291. #|(exact->inexact b)|#)
 
 (define (flo:random-element state)
-  (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+  (let ((mask ((ucode-primitive set-interrupt-enables!) interrupt-mask/gc-ok)))
     (let ((index (random-state-index state))
 	  (vector (random-state-vector state)))
       (let ((element (flo:vector-ref vector index)))
@@ -76,7 +76,7 @@ USA.
 				   (if (fix:= (fix:+ index 1) r)
 				       0
 				       (fix:+ index 1))))
-	(set-interrupt-enables! mask)
+	((ucode-primitive set-interrupt-enables!) mask)
 	element))))
 
 (define-integrable (int:random-element state)
diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index cb4311aec..681ce8f69 100644
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.60 2008/01/30 20:02:34 cph Exp $
+$Id: record.scm,v 1.61 2008/02/10 06:14:14 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -34,18 +34,29 @@ USA.
 (declare (usual-integrations))
 
 (define-primitives
-  (%record? 1)
   (%record -1)
-  (%record-length 1)
-  (%record-ref 2)
-  (%record-set! 3)
   (primitive-object-ref 2)
   (primitive-object-set! 3)
-  (primitive-object-set-type 2)
-  (vector-cons 2))
+  (primitive-object-set-type 2))
+
+(define-integrable (%record? object)
+  ((ucode-primitive %record?) object))
+
+(define-integrable (%record-length record)
+  ((ucode-primitive %record-length) record))
+
+(define-integrable (%record-ref record index)
+  ((ucode-primitive %record-ref) record index))
+
+(define-integrable (%record-set! record index value)
+  ((ucode-primitive %record-set!) record index value))
+
+(define-integrable (vector-cons length object)
+  ((ucode-primitive vector-cons) length object))
 
 (define-integrable (%make-record length object)
-  (object-new-type (ucode-type record) (vector-cons length object)))
+  ((ucode-primitive object-set-type) (ucode-type record)
+				     (vector-cons length object)))
 
 (define-integrable (%record-tag record)
   (%record-ref record 0))
@@ -131,7 +142,7 @@ USA.
 			  #!optional default-inits unparser-method)
   (let ((caller 'MAKE-RECORD-TYPE))
     (guarantee-list-of-unique-symbols field-names caller)
-    (let* ((names (list->vector field-names))
+    (let* ((names ((ucode-primitive list->vector) field-names))
 	   (n (vector-length names))
 	   (record-type
 	    (%record record-type-type-tag
@@ -190,7 +201,7 @@ USA.
   (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES)
   ;; Can't use VECTOR->LIST here because it isn't available at cold load.
   (let ((v (%record-type-field-names record-type)))
-    (subvector->list v 0 (vector-length v))))
+    ((ucode-primitive subvector->list) v 0 (vector-length v))))
 
 (define (record-type-default-inits record-type)
   (guarantee-record-type record-type 'RECORD-TYPE-DEFAULT-INITS)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index a5ad67bdf..6c1296aba 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.643 2008/02/02 18:21:30 cph Exp $
+$Id: runtime.pkg,v 14.644 2008/02/10 06:14:15 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -121,12 +121,12 @@ USA.
   (files "boole")
   (parent (runtime))
   (export ()
+	  (false? not)
 	  boolean/and
 	  boolean/or
 	  boolean=?
 	  boolean?
 	  false
-	  false?
 	  for-all?
 	  not
 	  there-exists?
@@ -4187,6 +4187,8 @@ USA.
 	  define-guarantee)
   (export (runtime)
 	  define-primitives
+	  define-unary-primitive
+	  define-binary-primitive
 	  ucode-primitive
 	  ucode-return-address
 	  ucode-type))
diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm
index a5a8cd3f8..568333810 100644
--- a/v7/src/runtime/string.scm
+++ b/v7/src/runtime/string.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: string.scm,v 14.67 2008/01/30 20:02:35 cph Exp $
+$Id: string.scm,v 14.68 2008/02/10 06:14:16 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -43,23 +43,41 @@ USA.
 
 ;;;; Primitives
 
-(define-primitives
-  read-byte-from-memory
-  set-string-length!
-  set-string-maximum-length!
-  string-allocate
-  string-hash-mod
-  string-length
-  string-maximum-length
-  string-ref
-  string-set!
-  string?
-  substring-move-left!
-  substring-move-right!
-  vector-8b-ref
-  vector-8b-set!
-  write-byte-to-memory
-  )
+(define-integrable (string-allocate n)
+  ((ucode-primitive string-allocate) n))
+
+(define-integrable (string? object)
+  ((ucode-primitive string?) object))
+
+(define-integrable (string-length string)
+  ((ucode-primitive string-length) string))
+
+(define-integrable (string-maximum-length string)
+  ((ucode-primitive string-maximum-length) string))
+
+(define-integrable (set-string-length! string length)
+  ((ucode-primitive set-string-length!) string length))
+
+(define-integrable (set-string-maximum-length! string length)
+  ((ucode-primitive set-string-maximum-length!) string length))
+
+(define-integrable (string-ref string index)
+  ((ucode-primitive string-ref) string index))
+
+(define-integrable (string-set! string index char)
+  ((ucode-primitive string-set!) string index char))
+
+(define-integrable (substring-move-left! string1 start1 end1 string2 start2)
+  ((ucode-primitive substring-move-left!) string1 start1 end1 string2 start2))
+
+(define-integrable (substring-move-right! string1 start1 end1 string2 start2)
+  ((ucode-primitive substring-move-right!) string1 start1 end1 string2 start2))
+
+(define-integrable (vector-8b-ref vector-8b index)
+  ((ucode-primitive vector-8b-ref) vector-8b index))
+
+(define-integrable (vector-8b-set! vector-8b index byte)
+  ((ucode-primitive vector-8b-set!) vector-8b index byte))
 
 (define-integrable (vector-8b-fill! string start end ascii)
   (substring-fill! string start end (ascii->char ascii)))
@@ -81,6 +99,9 @@ USA.
       ((ucode-primitive string-hash) key)
       ((ucode-primitive string-hash-mod) key modulus)))
 
+(define (string-hash-mod key modulus)
+  ((ucode-primitive string-hash-mod) key modulus))
+
 (define (string-ci-hash key #!optional modulus)
   (string-hash (string-downcase key) modulus))
 
@@ -1445,7 +1466,7 @@ USA.
 (define (xstring-ref xstring index)
   (cond ((external-string? xstring)
 	 (ascii->char
-	  (read-byte-from-memory
+	  ((ucode-primitive read-byte-from-memory)
 	   (+ (external-string-descriptor xstring) index))))
 	((string? xstring)
 	 (string-ref xstring index))
@@ -1454,7 +1475,7 @@ USA.
 
 (define (xstring-set! xstring index char)
   (cond ((external-string? xstring)
-	 (write-byte-to-memory
+	 ((ucode-primitive write-byte-to-memory)
 	  (char->ascii char)
 	  (+ (external-string-descriptor xstring) index)))
 	((string? xstring)
diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm
index c2461015d..6893278ac 100644
--- a/v7/src/runtime/sysmac.scm
+++ b/v7/src/runtime/sysmac.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sysmac.scm,v 14.17 2008/01/30 20:02:36 cph Exp $
+$Id: sysmac.scm,v 14.18 2008/02/10 06:14:17 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -47,6 +47,24 @@ USA.
 			       (primitive-definition (car name) (cdr name)))))
 		      (cdr form)))))))
 
+(define-syntax define-unary-primitive
+  (sc-macro-transformer
+   (lambda (form env)
+     env
+     (if (syntax-match? '(SYMBOL SYMBOL) (cdr form))
+	 `(DEFINE-INTEGRABLE (,(cadr form) X)
+	    ((ucode-primitive ,(caddr form)) X))
+	 (ill-formed-syntax form)))))
+
+(define-syntax define-binary-primitive
+  (sc-macro-transformer
+   (lambda (form env)
+     env
+     (if (syntax-match? '(SYMBOL SYMBOL) (cdr form))
+	 `(DEFINE-INTEGRABLE (,(cadr form) X Y)
+	    ((ucode-primitive ,(caddr form)) X Y))
+	 (ill-formed-syntax form)))))
+
 (define-syntax ucode-type
   (sc-macro-transformer
    (lambda (form environment)
diff --git a/v7/src/runtime/uproc.scm b/v7/src/runtime/uproc.scm
index c0f84eb4d..383c30660 100644
--- a/v7/src/runtime/uproc.scm
+++ b/v7/src/runtime/uproc.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uproc.scm,v 1.22 2008/01/30 20:02:37 cph Exp $
+$Id: uproc.scm,v 1.23 2008/02/10 06:14:18 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -92,7 +92,7 @@ USA.
 (define (procedure-arity procedure)
   (let loop ((p procedure) (e 0))
     (cond ((%primitive-procedure? p)
-	   (let ((arity (primitive-procedure-arity p)))
+	   (let ((arity ((ucode-primitive primitive-procedure-arity) p)))
 	     (cond ((fix:< arity 0)
 		    (cons 0 #f))
 		   ((fix:<= e arity)
diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm
index 386f92c29..f18c8ac98 100644
--- a/v7/src/runtime/vector.scm
+++ b/v7/src/runtime/vector.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: vector.scm,v 14.28 2008/01/30 20:02:37 cph Exp $
+$Id: vector.scm,v 14.29 2008/02/10 06:14:19 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -30,10 +30,35 @@ USA.
 
 (declare (usual-integrations))
 
-(define-primitives
-  vector? vector-length vector-ref vector-set!
-  list->vector vector subvector->list
-  subvector-move-right! subvector-move-left! subvector-fill!)
+(define-integrable vector
+  (ucode-primitive vector))
+
+(define-integrable (vector? object)
+  ((ucode-primitive vector?) object))
+
+(define-integrable (vector-length v)
+  ((ucode-primitive vector-length) v))
+
+(define-integrable (vector-ref v i)
+  ((ucode-primitive vector-ref) v i))
+
+(define-integrable (vector-set! v i x)
+  ((ucode-primitive vector-set!) v i x))
+
+(define-integrable (list->vector list)
+  ((ucode-primitive list->vector) list))
+
+(define-integrable (subvector->list v s e)
+  ((ucode-primitive subvector->list) v s e))
+
+(define-integrable (subvector-fill! v s e x)
+  ((ucode-primitive subvector-fill!) v s e x))
+
+(define-integrable (subvector-move-left! v1 s1 e1 v2 s2)
+  ((ucode-primitive subvector-move-left!) v1 s1 e1 v2 s2))
+
+(define-integrable (subvector-move-right! v1 s1 e1 v2 s2)
+  ((ucode-primitive subvector-move-right!) v1 s1 e1 v2 s2))
 
 (define-integrable (guarantee-vector object procedure)
   (if (not (vector? object))