Index: /branches/ia32/level-0/X86/x86-array.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-array.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-array.lisp	(revision 8365)
@@ -0,0 +1,243 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  #+x8632-target
+  (require "X8632-ARCH")
+  #+x8664-target
+  (require "X8664-ARCH")
+  (require "X86-LAPMACROS"))
+
+
+
+
+
+;; rewrite in LAP someday (soon).
+(defun %init-misc (val uvector)
+  (dotimes (i (uvsize uvector) uvector)
+    (setf (uvref uvector i) val)))
+
+
+;;; Make a new vector of size newsize whose subtag matches that of oldv-arg.
+;;; Blast the contents of the old vector into the new one as quickly as
+;;; possible; leave remaining elements of new vector undefined (0).
+;;; Return new-vector.
+(defun %extend-vector (start oldv newsize)
+  (declare (fixnum start))
+  (let* ((new (%alloc-misc newsize (typecode oldv)))
+         (oldsize (uvsize oldv)))
+    (declare (fixnum oldsize))
+    (do* ((i 0 (1+ i))
+          (j start (1+ j)))
+         ((= i oldsize) new)
+      (declare (fixnum i j))
+      (setf (uvref new j) (uvref oldv i)))))
+    
+
+
+
+
+;;; argument is a vector header or an array header.  Or else.
+(defx86lapfunction %array-header-data-and-offset ((a arg_z))
+  (let ((offset arg_y)
+        (temp temp1))
+    (movq (% rsp) (% temp0))
+    (movl ($ '0) (%l offset))
+    (movq (% a) (% temp))
+    @loop
+    (movq (@ target::arrayH.data-vector (% temp)) (% a))
+    (extract-subtag a imm0)
+    (addq (@ target::arrayH.displacement (% temp)) (% offset))
+    (rcmp (% imm0) ($ target::subtag-vectorH))
+    (movq (% a) (% temp))
+    (jle @loop)
+    (push (% a))
+    (push (% offset))
+    (set-nargs 2)
+    (jmp-subprim  .SPvalues)))
+
+
+
+(defx86lapfunction %boole-clr ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq ($ 0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-set ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq ($ -1) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-c1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-c2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-and ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-ior ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-xor ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+n  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (xorq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-eqv ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (xorq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-nand ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-nor ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-andc1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-andc2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (andq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-orc1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defx86lapfunction %boole-orc2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z))
+  (movq (@ idx (% rsp)) (% temp0))
+  (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0))
+  (notq (% imm0))
+  (orq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0))
+  (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0)))
+  (single-value-return 3))
+
+(defparameter *simple-bit-boole-functions* ())
+
+(setq *simple-bit-boole-functions*
+      (vector
+       #'%boole-clr
+       #'%boole-set
+       #'%boole-1
+       #'%boole-2
+       #'%boole-c1
+       #'%boole-c2
+       #'%boole-and
+       #'%boole-ior
+       #'%boole-xor
+       #'%boole-eqv
+       #'%boole-nand
+       #'%boole-nor
+       #'%boole-andc1
+       #'%boole-andc2
+       #'%boole-orc1
+       #'%boole-orc2))
+
+(defun %simple-bit-boole (op b1 b2 result)
+  (let* ((f (svref *simple-bit-boole-functions* op)))
+    (dotimes (i (ash (the fixnum (+ (length result) 63)) -6) result)
+      (funcall f i b1 b2 result))))
+
+(defx86lapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z))
+  (check-nargs 3)
+  (jmp-subprim .SParef2))
+
+(defx86lapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z))
+  (check-nargs 4)
+  (pop (% temp0))
+  (discard-reserved-frame)
+  (jmp-subprim .SParef3))
+
+(defx86lapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z))
+  (check-nargs 4)
+  (pop (% temp0))
+  (discard-reserved-frame)
+  (jmp-subprim .SPaset2))
+
+(defx86lapfunction %aset3 ((array 8) (i 0) (j arg_x) (k arg_y) (newval arg_z))
+  (check-nargs 5)
+  (pop (% temp0))
+  (pop (% temp1))
+  (discard-reserved-frame)
+  (jmp-subprim .SPaset3))
+
+
+
+
+
+  
+
Index: /branches/ia32/level-0/X86/x86-clos.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-clos.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-clos.lisp	(revision 8365)
@@ -0,0 +1,261 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 2006, Clozure Associates and contributors
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+;;; It's easier to keep this is LAP; we want to play around with its
+;;; constants.
+
+
+;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL.
+;;; The map is a vector of (UNSIGNED-BYTE 8); this should
+;;; be used when there are fewer than 255 slots in the class.
+(defx86lapfunction %small-map-slot-id-lookup ((slot-id arg_z))
+  (movq (@ 'map (% fn)) (% temp1))
+  (svref slot-id slot-id.index arg_x)
+  (vector-length temp1 imm0)
+  (xorl (%l imm1) (%l imm1))
+  (rcmpq (% arg_x) (% imm0))
+  (movq (@ 'table (% fn)) (% temp0))
+  (ja @have-table-index)
+  (movq (% arg_x) (% imm1))
+  (shrq ($ x8664::word-shift) (% imm1))
+  (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
+  (shlq ($ x8664::word-shift) (% imm1))
+  @have-table-index
+  (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z))
+  (single-value-return))
+
+;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32).
+(defx86lapfunction %large-map-slot-id-lookup ((slot-id arg_z))
+  (movq (@ 'map (% fn)) (% temp1))
+  (svref slot-id slot-id.index arg_x)
+  (vector-length temp1 imm0)
+  (xorl (%l imm1) (%l imm1))
+  (rcmpq (% arg_x) (% imm0))
+  (movq (@ 'table (% fn)) (% temp0))
+  (ja @have-table-index)
+  (movq (% arg_x) (% imm1))
+  (shrq ($ 1) (% imm1))
+  (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
+  @have-table-index
+  (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z))
+  (movq (@ 'map (% fn)) (% temp1))
+  (svref slot-id slot-id.index arg_x)
+  (vector-length temp1 imm0)
+  (xorl (%l imm1) (%l imm1))
+  (rcmpq (% arg_x) (% imm0))
+  (movq (@ 'table (% fn)) (% temp0))
+  (ja @missing)
+  (movq (% arg_x) (% imm1))
+  (shrq ($ x8664::word-shift) (% imm1))
+  (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
+  (testl (%l imm1) (%l imm1))
+  (je @missing)
+  (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z))
+  (movq (@ 'class (% fn)) (% arg_x))
+  (set-nargs 3)
+  (jmp (@ '%maybe-std-std-value-using-class (% fn)))
+  @missing                              ; (%slot-id-ref-missing instance id)
+  (set-nargs 2)
+  (jmp (@'%slot-id-ref-missing (% fn))))
+
+(defx86lapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z))  
+  (movq (@ 'map (% fn)) (% temp1))
+  (svref slot-id slot-id.index arg_x)
+  (vector-length temp1 imm0)
+  (xorl (%l imm1) (%l imm1))
+  (rcmpq (% arg_x) (% imm0))
+  (movq (@ 'table (% fn)) (% temp0))
+  (ja @missing)
+  (movq (% arg_x) (% imm1))
+  (shrq ($ 1) (% imm1))
+  (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
+  (testl (%l imm1) (%l imm1))
+  (je @missing)
+  (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z))
+  (movq (@ 'class (% fn)) (% arg_x))
+  (set-nargs 3)
+  (jmp (@ '%maybe-std-std-value-using-class (% fn)))
+  @missing                              ; (%slot-id-ref-missing instance id)
+  (set-nargs 2)
+  (jmp (@'%slot-id-ref-missing (% fn))))
+
+  
+(defx86lapfunction %small-set-slot-id-value ((instance arg_x)
+                                             (slot-id arg_y)
+                                             (new-value arg_z))
+  (movq (@ 'map (% fn)) (% temp1))
+  (svref slot-id slot-id.index imm1)
+  (vector-length temp1 imm0)
+  (rcmpq (% imm1) (% imm0))
+  (movq (@ 'table (% fn)) (% temp0))
+  (ja @missing)
+  (shrq ($ x8664::word-shift) (% rdx))
+  (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
+  (testl (%l imm1) (%l imm1))
+  (je @missing)
+  (popq (% ra0))
+  (pushq ($ 0))                         ; reserve frame
+  (pushq ($ 0))
+  (pushq (@ 'class (% fn)))
+  (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_y))
+  (set-nargs 4)
+  (pushq (% ra0))
+  (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn)))
+  @missing                              ; (%slot-id-set-missing instance id new-value)
+  (set-nargs 3)
+  (jmp (@ '%slot-id-set-missing (% fn))))
+
+
+(defx86lapfunction %large-set-slot-id-value ((instance arg_x)
+                                             (slot-id arg_y)
+                                             (new-value arg_z))
+  (movq (@ 'map (% fn)) (% temp1))
+  (svref slot-id slot-id.index imm1)
+  (vector-length temp1 imm0)
+  (rcmpq (% imm1) (% imm0))
+  (movq (@ 'table (% fn)) (% temp0))
+  (ja @missing)
+  (shrq ($ x8664::word-shift) (% rdx))
+  (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1))
+  (testl (%l imm1) (%l imm1))
+  (je @missing)
+  (popq (% ra0))
+  (pushq ($ 0))                         ; reserve frame
+  (pushq ($ 0))
+  (pushq (@ 'class (% fn)))
+  (pushq (% ra0))
+  (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_y))
+  (set-nargs 4)
+  (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn)))
+  @missing                              ; (%slot-id-set-missing instance id new-value)
+  (set-nargs 3)
+  (jmp (@'%slot-id-ref-missing (% fn))))
+
+
+;;; All of the generic function trampoline functions have to be
+;;; exactly the same size (x8664::gf-code-size) in words.  The
+;;; largest of these - the general-case *GF-PROTO* - is currently
+;;; "really" a little under 15 words, so X8664::GF-CODE-SIZE is
+;;; just a little bigger than that.
+(defparameter *gf-proto*
+  (nfunction
+   gag
+   (lambda (&lap &lexpr args)
+     (x86-lap-function 
+      gag 
+      ()
+      (:fixed-constants (class-wrapper slots dispatch-table dcode hash))
+      (:code-size x8664::gf-code-size)
+      (movq (@ (% rsp)) (% ra0))
+      (save-frame-variable-arg-count)
+      (push-argregs)
+      (movzwl (% nargs) (%l nargs))
+      (pushq (%q nargs))
+      (movq (% rsp) (% arg_z))
+      (ref-global.l ret1valaddr imm0)
+      (cmpq (% ra0) (% imm0))
+      (je @multiple)
+      (ref-global.l lexpr-return1v ra0)
+      (jmp @call)
+      @multiple
+      (pushq (@ (+ x8664::nil-value (x8664::%kernel-global 'lexpr-return))))
+      (movq (% imm0) (% ra0))
+      @call
+      (push (% ra0))
+      (movq (@ 'dispatch-table (% fn)) (% arg_y))
+      (set-nargs 2)
+      (jmp (@ 'dcode (% fn)))  ; dcode function
+      ))))
+
+;;; is a winner - saves ~15%
+(defx86lapfunction gag-one-arg ((arg arg_z))
+  (:fixed-constants (class-wrapper slots dispatch-table dcode hash))
+  (:code-size x8664::gf-code-size)
+  (check-nargs 1)
+  (movq (@ 'dispatch-table (% fn)) (% arg_y))
+  (set-nargs 2)
+  (jmp (@ 'dcode (% fn))))
+
+(defx86lapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z))
+  (:fixed-constants (class-wrapper slots dispatch-table dcode hash))
+  (:code-size x8664::gf-code-size)
+  (check-nargs 2)
+  (movq (@ 'dispatch-table (% fn)) (% arg_x))
+  (set-nargs 3)
+  (jmp (@ 'dcode (% fn))))
+
+
+(defx86lapfunction funcallable-trampoline ()
+  (:fixed-constants (class-wrapper slots dispatch-table dcode hash))
+  (:code-size x8664::gf-code-size)
+  (jmp (@ 'dcode (% fn))))
+
+
+;;; This is in LAP so that it can reference itself in the error message.
+;;; (It needs to be cloned, so %fn will be unique to each copy.)
+;;; It can't work for this to reference any of its own constants.
+(defx86lapfunction unset-fin-trampoline ()
+  (:code-size x8664::gf-code-size)
+  (save-frame-variable-arg-count)
+  (call-subprim .SPheap-rest-arg)
+  (pop (% arg_z))
+  (movq ($ '#.$XNOFINFUNCTION) (% arg_x))
+  (movq (% fn) (% arg_y))
+  (set-nargs 3)
+  (call-subprim .SPksignalerr)
+  ;(movq ($ x8664::nil-value) (% arg_z))
+  (leave)
+  (single-value-return))
+
+
+
+(defparameter *cm-proto*
+  (nfunction
+   gag
+   (lambda (&lap &lexpr args)
+     (x86-lap-function 
+      gag 
+      ()
+      (:fixed-constants (thing dcode gf bits))
+      (movq (@ (% rsp)) (% ra0))
+      (save-frame-variable-arg-count)
+      (push-argregs)
+      (movzwl (% nargs) (%l nargs))
+      (pushq (%q nargs))
+      (movq (% rsp) (% arg_z))
+      (ref-global ret1valaddr imm0)
+      (cmpq (% ra0) (% imm0))
+      (je @multiple)
+      (ref-global lexpr-return1v ra0)
+      (jmp @call)
+      @multiple
+      (pushq (@ (+ x8664::nil-value (x8664::%kernel-global 'lexpr-return))))
+      (movq (% imm0) (% ra0))
+      @call
+      (push (% ra0))
+      (movq (@ 'thing (% fn)) (% arg_y))
+      (set-nargs 2)
+      (jmp (@ 'dcode (% fn)))))))
+
+
+
+
Index: /branches/ia32/level-0/X86/x86-def.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-def.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-def.lisp	(revision 8365)
@@ -0,0 +1,686 @@
+;;; -*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 2006, Clozure Associates and contributors
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(defx86lapfunction %function-vector-to-function ((arg arg_z))
+  (trap-unless-typecode= arg x8664::subtag-function)
+  (addb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b))
+  (single-value-return))
+
+(defx86lapfunction %function-to-function-vector  ((arg arg_z))
+  (trap-unless-fulltag= arg x8664::fulltag-function)
+  (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b))
+  (single-value-return))
+
+(defx86lapfunction %function-code-words ((fun arg_z))
+  (trap-unless-fulltag= fun x8664::fulltag-function)
+  (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %nth-immediate ((fun arg_y) (n arg_z))
+  (trap-unless-fulltag= fun x8664::fulltag-function)
+  (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l))
+  (lea (@ (% n) (% imm0) 8) (% imm0))
+  (movq (@ (- x8664::node-size x8664::fulltag-function) (% fun) (% imm0))
+        (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %set-nth-immediate ((fun arg_x) (n arg_y) (new arg_z))
+  (trap-unless-fulltag= fun x8664::fulltag-function)
+  (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l))
+  (lea (@ (% n) (% imm0) 8) (% arg_y))
+  (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (%b arg_x))
+  (jmp-subprim .SPgvset))
+
+(defx86lapfunction %function-code-byte ((fun arg_y) (pc arg_z))
+  (unbox-fixnum pc imm0)
+  (movzbl (@ (% fun) (% imm0)) (% imm0.l))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+
+;;; Returns 3 values: mask of registers used in the function, stack location
+;;; from which they'd be restored, relative PC at which they're saved. If
+;;; the mask is 0, the values NIL NIL NIL are returned. If either the stack
+;;; location or relative PC is #xff, both of those values will be returned
+;;; as NIL.
+(defx86lapfunction %function-register-usage ((f arg_z))
+  (check-nargs 1)
+  (trap-unless-fulltag= f x8664::fulltag-function)
+  (movzbl (@ -1 (% f)) (% imm0.l))
+  (shll ($ 8) (% imm0.l))
+  (box-fixnum imm0 arg_x)
+  (movq (% rsp) (% temp0))
+  (set-nargs 3)
+  (je @no-regs)
+  (movzbl (@ -2 (% f)) (% imm0.l))
+  (movzbl (@ -3 (% f)) (% imm1.l))
+  (cmpb ($ #xff) (% imm0.b))
+  (je @unencodable)
+  (cmpb ($ #xff) (% imm1.b))
+  (je @unencodable)
+  (box-fixnum imm0 arg_y)
+  (box-fixnum imm1 arg_z)
+  (push (% arg_x))
+  (push (% arg_y))
+  (push (% arg_z))
+  (jmp-subprim .SPvalues)
+  @unencodable
+  (push (% arg_x))
+  (pushq ($ nil))
+  (pushq ($ nil))
+  (jmp-subprim .SPvalues)
+  @no-regs
+  (pushq ($ nil))
+  (pushq ($ nil))
+  (pushq ($ nil))
+  (jmp-subprim .SPvalues))
+  
+        
+
+(defx86lapfunction %make-code-executable ((codev arg_z))
+  (single-value-return))
+
+;;; Make a new function, with PROTO's code and the specified immediates.
+;;; IMMEDIATES should contain lfun-bits as the last element.
+(defun %clone-x86-function (proto &rest immediates)
+  (declare (dynamic-extent immediates))
+  (let* ((protov (%function-to-function-vector proto))
+         (code-words (%function-code-words proto))
+         (numimms (length immediates))
+         (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms)))))
+    (declare (fixnum code-words numimms))
+    (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift)))
+    (do* ((k code-words (1+ k))
+          (imms immediates (cdr imms)))
+         ((null imms) (%function-vector-to-function newv))
+      (declare (fixnum k) (list imms))
+      (setf (%svref newv k) (car imms)))))
+
+(defun replace-function-code (target proto)
+  (let* ((target-words (%function-code-words target))
+         (proto-words (%function-code-words proto)))
+    (declare (fixnum target-words proto-words))
+    (if (= target-words proto-words)
+      (progn
+        (%copy-ivector-to-ivector (%function-to-function-vector proto)
+                                  0
+                                  (%function-to-function-vector target)
+                                  0
+                                  (the fixnum (ash target-words
+                                                   target::word-shift)))
+        target)
+      (error "Code size mismatch: target = ~s, proto = ~s"
+             target-words proto-words))))
+         
+
+(defx86lapfunction %get-kernel-global-from-offset ((offset arg_z))
+  (check-nargs 1)
+  (unbox-fixnum offset imm0)
+  (movq (@ target::nil-value (% imm0)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z))
+  (check-nargs 2)
+  (unbox-fixnum offset imm0)
+  (movq (% arg_z) (@ target::nil-value (% imm0)))
+  (single-value-return))
+
+
+(defx86lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y)
+						       (ptr arg_z))
+  (check-nargs 2)
+  (unbox-fixnum offset imm0)
+  (movq (@ target::nil-value (% imm0)) (% imm0))
+  (movq (% imm0) (@ x8664::macptr.address (% ptr)))
+  (single-value-return))
+
+
+
+
+(defx86lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z))
+  (:arglist (fixnum &optional offset))
+  (check-nargs 1 2)
+  (cmpw ($ x8664::fixnumone) (% nargs))
+  (jne @2-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @2-args
+  (unbox-fixnum offset imm0)
+  (movq (@ (% fixnum) (% imm0)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z))
+  (:arglist (fixnum &optional offset))
+  (check-nargs 1 2)
+  (cmpw ($ x8664::fixnumone) (% nargs))
+  (jne @2-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @2-args
+  (unbox-fixnum offset imm0)
+  (movq (@ (% fixnum) (% imm0)) (% imm0))
+  (jmp-subprim .SPmakeu64))
+
+(defx86lapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
+  (:arglist (fixnum offset &optional newval))
+  (check-nargs 2 3)
+  (cmpw ($ '2) (% nargs))
+  (jne @3-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @3-args
+  (unbox-fixnum offset imm0)
+  (movq (% new-value) (@ (% fixnum) (% imm0)))
+  (movq (% new-value) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z))
+  (:arglist (fixnum offset &optional newval))
+  (check-nargs 2 3)
+  (save-simple-frame)
+  (cmpw ($ '2) (% nargs))
+  (jne @3-args)
+  (movq (% offset) (% fixnum))
+  (xorl (%l offset) (%l offset))
+  @3-args
+  (call-subprim .SPgetu64)
+  (unbox-fixnum offset imm1)
+  (movq (% imm0) (@ (% fixnum) (% imm1)))
+  (restore-simple-frame)
+  (single-value-return))
+
+
+(defx86lapfunction %current-frame-ptr ()
+  (check-nargs 0)
+  (movq (% rbp) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %current-tsp ()
+  (check-nargs 0)
+  (movq (@ (% :rcontext) x8664::tcr.save-tsp) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %%frame-backlink ((p arg_z))
+  (check-nargs 1)
+  (movq (@ (% arg_z)) (% arg_z))
+  (single-value-return))
+
+;;; Look for "lea -nnnn(%rip),%fn" AT the tra; if that's present, use
+;;; the dispacement -nnnn to find the function.  The end of the
+;;; encoded displacement is
+;;; x8664::recover-fn-from-rip-disp-offset (= 7) bytes from the tra.
+(defx86lapfunction %return-address-function ((r arg_z))
+  (extract-lisptag r imm0)
+  (cmpb ($ x8664::tag-tra) (% imm0.b))
+  (jne @fail)
+  (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r)))
+  (jne @fail)
+  (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r)))
+  (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0))
+  (jne @fail)
+  (lea (@ x8664::recover-fn-from-rip-length (% imm0) (% r)) (% arg_z))
+  (single-value-return)
+  @fail
+  (movl ($ x8664::nil-value) (% arg_z.l))
+  (single-value-return))
+
+(defx86lapfunction %return-address-offset ((r arg_z))
+  (extract-lisptag r imm0)
+  (cmpb ($ x8664::tag-tra) (% imm0.b))
+  (jne @fail)
+  (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r)))
+  (jne @fail)
+  (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r)))
+  (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0))
+  (jne @fail)
+  (negq (% imm0))
+  (leaq (@ (- (ash x8664::recover-fn-from-rip-length x8664::fixnumshift)) (% imm0) 8) (% arg_z))
+  (single-value-return)
+  @fail
+  (movl ($ x8664::nil-value) (% arg_z.l))
+  (single-value-return))
+
+;;; It's always been the case that the function associated with a
+;;; frame pointer is the caller of the function that "uses" that frame.
+(defun %cfp-lfun (p)
+  (let* ((ra (%fixnum-ref p x8664::lisp-frame.return-address)))
+    (if (eq ra (%get-kernel-global ret1valaddr))
+      (setq ra (%fixnum-ref p x8664::lisp-frame.xtra)))
+    (values (%return-address-function ra) (%return-address-offset ra))))
+
+
+
+(defx86lapfunction %uvector-data-fixnum ((uv arg_z))
+  (check-nargs 1)
+  (trap-unless-fulltag= arg_z x8664::fulltag-misc)
+  (addq ($ x8664::misc-data-offset) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %catch-top ((tcr arg_z))
+  (check-nargs 1)
+  (movl ($ x8664::nil-value) (%l arg_y))
+  (movq (@ (% :rcontext) x8664::tcr.catch-top) (% arg_z))
+  (testb (%b arg_z) (%b arg_z))
+  (cmoveq (% arg_y) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %catch-tsp ((catch arg_z))
+  (check-nargs 1)
+  (lea (@  (- (+ target::fulltag-misc
+                                 (ash 1 (1+ target::word-shift)))) (% arg_z))
+       (% arg_z))
+  (single-value-return))
+
+
+
+;;; Same as %address-of, but doesn't cons any bignums
+;;; It also left shift fixnums just like everything else.
+(defx86lapfunction %fixnum-address-of ((x arg_z))
+  (check-nargs 1)
+  (box-fixnum x arg_z)
+  (single-value-return))
+
+(defx86lapfunction %save-standard-binding-list ((bindings arg_z))
+  (movq (@ (% :rcontext) x8664::tcr.vs-area) (% imm0))
+  (movq (@ x8664::area.high (% imm0)) (% imm1))
+  (subq ($ x8664::node-size) (% imm1))
+  (movq (% bindings) (@ (% imm1)))
+  (single-value-return))
+
+(defx86lapfunction %saved-bindings-address ()
+  (movq (@ (% :rcontext) x8664::tcr.vs-area) (% imm0))
+  (movq (@ x8664::area.high (% imm0)) (% imm1))
+  (lea (@ (- x8664::node-size) (% imm1)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %get-object ((macptr arg_y) (offset arg_z))
+  (check-nargs 2)
+  (trap-unless-typecode= macptr x8664::subtag-macptr)
+  (macptr-ptr macptr imm0)
+  (trap-unless-lisptag= offset target::tag-fixnum imm1)
+  (unbox-fixnum offset imm1)
+  (movq (@ (% imm0) (% imm1)) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z))
+  (check-nargs 3)
+  (trap-unless-typecode= macptr target::subtag-macptr)
+  (macptr-ptr macptr imm0)
+  (trap-unless-lisptag= offset target::tag-fixnum imm1)
+  (unbox-fixnum offset imm1)
+  (movq (% arg_z) (@ (% imm0) (% imm1)))
+  (single-value-return))
+
+(defx86lapfunction %apply-lexpr-with-method-context ((magic arg_x)
+                                                     (function arg_y)
+                                                     (args arg_z))
+  ;; Somebody's called (or tail-called) us.
+  ;; Put magic arg in x8664::next-method-context (= x8664::temp0).
+  ;; Put function in x8664::xfn until we're ready to jump to it.
+  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
+  ;;   but preserves x866::xfn/x8664::next-method-context.
+  ;; Jump to the function in x8664::xfn.
+  (popq (% ra0))
+  (movq (% magic) (% next-method-context))
+  (movq (% function) (% xfn))
+  (set-nargs 0)
+  (movq (@ (% args)) (% imm0))          ;lexpr-count
+  (movw (% imm0.w) (% nargs))
+  (leaq (@ x8664::node-size (% arg_z) (% imm0)) (% imm1))
+  (subw ($ '3) (% imm0.w))
+  (jbe @reg-only)
+  ;; Some args will be pushed; reserve a frame
+  (pushq ($ x8664::reserved-frame-marker))
+  (pushq ($ x8664::reserved-frame-marker))
+  @pushloop
+  (pushq (@ (- x8664::node-size) (% imm1)))
+  (subq ($ x8664::node-size) (% imm1))
+  (subq ($ x8664::node-size) (% imm0))
+  (jne @pushloop)
+  @three
+  (movq (@ (* x8664::node-size 3) (% arg_z)) (% arg_x))
+  @two
+  (movq (@ (* x8664::node-size 2) (% arg_z)) (% arg_y))
+  @one
+  (movq (@ (* x8664::node-size 1) (% arg_z)) (% arg_z))
+  (jmp @go)
+  @reg-only
+  (testw (% nargs) (% nargs))
+  (je @go)
+  (rcmpw (% nargs) ($ '2))
+  (je @two)
+  (jb @one)
+  (jmp @three)
+  @go
+  (push (% ra0))
+  (jmp (% xfn)))
+
+(defx86lapfunction %apply-with-method-context ((magic arg_x)
+                                               (function arg_y)
+                                               (args arg_z))
+  ;; Somebody's called (or tail-called) us.
+  ;; Put magic arg in x8664::next-method-context (= x8664::temp0).
+  ;; Put function in x8664::xfn (= x8664::temp1).
+  ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z,
+  ;;   but preserves x8664::xfn/x8664::next-method-context.
+  ;; Jump to the function in x8664::xfn.
+  (pop (% ra0))  
+  (movq (% magic) (% x8664::next-method-context))
+  (movq (% function) (% x8664::xfn))
+  (movq (% args) (% arg_y))             ; in case of error
+  (set-nargs 0)
+  (xorl (% imm0.l) (% imm0.l))
+  (push (% imm0))                       ; reserve frame (might discard
+  (push (% imm0))                       ; it if nothing is passed on stack.)
+  (cmp-reg-to-nil arg_z)
+  (je @done)
+  @loop
+  (extract-fulltag arg_z imm1)
+  (cmpb ($ x8664::fulltag-cons) (%b imm1))
+  (jne @bad)
+  (%car arg_z arg_x)
+  (%cdr arg_z arg_z)
+  (lea (@ x8664::node-size (% imm0)) (% imm0))
+  (cmp-reg-to-nil arg_z)
+  (push (% arg_x))
+  (jne @loop)
+  @done
+  (addw (% imm0.w) (% nargs))
+  (jne @pop)
+  @discard-and-go
+  (discard-reserved-frame)
+  (jmp @go)
+  @pop
+  (cmpw ($ '1) (% nargs))
+  (pop (% arg_z))
+  (je @discard-and-go)
+  (cmpw ($ '2) (% nargs))
+  (pop (% arg_y))
+  (je @discard-and-go)
+  (cmpw ($ '3) (% nargs))
+  (pop (% arg_x))
+  (je @discard-and-go)
+  @go
+  (push (% ra0))
+  (jmp (% xfn))
+  @bad
+  (addq (% imm0) (% rsp))
+  (movq (% arg_y) (% arg_z))
+  (movq ($ (ash $XNOSPREAD x8664::fixnumshift)) (% arg_y))
+  (set-nargs 2)
+  (jmp-subprim .SPksignalerr))
+
+
+;;; The idea here is to call METHOD in the same stack frame in
+;;; which the lexpr was originally called.  The lexpr can't
+;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE
+;;; must have been tail-called, and the frame built on lexpr
+;;; entry must be in %rbp.
+(defx86lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z))
+  (addq ($ x8664::node-size) (% rsp))   ; discard extra return address
+  (movq (% method) (% xfn))
+  (movq (% args) (% rsp))
+  (pop (%q nargs))
+  (movq (@ x8664::lisp-frame.return-address (% rbp)) (% ra0))
+  (movq (@ 0 (% rbp)) (% rbp))
+  (rcmpw (% nargs) ($ '3))
+  (jbe @pop-regs)
+  ;; More than 3 args; some must have been pushed by caller,
+  ;; so retain the reserved frame.
+  (pop (% arg_z))
+  (pop (% arg_y))
+  (pop (% arg_x))
+  (jmp @popped)
+  @pop-regs
+  (je @pop3)
+  (rcmpw (% nargs) ($ '1))
+  (jb @discard)
+  (ja @pop2)
+  (pop (% arg_z))
+  (jmp @discard)
+  @pop3
+  (pop (% arg_z))
+  (pop (% arg_y))
+  (pop (% arg_x))
+  (jmp @discard)
+  @pop2
+  (pop (% arg_z))
+  (pop (% arg_y))
+  @discard
+  (discard-reserved-frame)
+  @popped
+  (push (% ra0))
+  (jmp (% xfn)))
+
+
+
+(defun closure-function (fun)
+  (while (and (functionp fun)  (not (compiled-function-p fun)))
+    (setq fun (%nth-immediate fun 0))
+    (when (vectorp fun)
+      (setq fun (svref fun 0))))
+  fun)
+
+;;; For use by (setf (apply ...) ...)
+;;; (apply+ f butlast last) = (apply f (append butlast (list last)))
+
+(defun apply+ (&lap function arg1 arg2 &rest other-args)
+  (x86-lap-function apply+ ()
+   (:arglist (function arg1 arg2 &rest other-args))
+   (check-nargs 3 nil)
+   (cmpw ($ '3) (% nargs))
+   (pop (% ra0))
+   (ja @no-frame)
+   (pushq ($ x8664::reserved-frame-marker))
+   (pushq ($ x8664::reserved-frame-marker))
+@no-frame         
+   (push (% arg_x))
+   (movq (% arg_z) (% temp0))           ; last
+   (movq (% arg_y) (% arg_z))           ; butlast
+   (subw ($ '2) (% nargs))              ; remove count for butlast & last
+   ;; Do .SPspreadargz inline here
+   (xorl (%l imm0) (%l imm0))
+   (movq (% arg_z) (% arg_y))           ; save in case of error
+   (cmp-reg-to-nil arg_z)
+   (je @done)
+   @loop
+   (extract-fulltag arg_z imm1)
+   (cmpb ($ x8664::fulltag-cons) (%b imm1))
+   (jne @bad)
+   (%car arg_z arg_x)
+   (%cdr arg_z arg_z)
+   (addl ($ '1) (%l imm0))
+   (cmp-reg-to-nil arg_z)   
+   (push (% arg_x))
+   (jne @loop)
+   @done
+   ;; nargs was at least 1 when we started spreading, and can't have gotten
+   ;; any smaller. 
+   (addw (%w imm0) (% nargs))
+   (movq (% temp0) (% arg_z))
+   (pop (% arg_y))
+   (pop (% arg_x))
+   (addw ($ '1) (% nargs))
+   (cmpw ($ '3) (% nargs))
+   (jne @no-discard)
+   (discard-reserved-frame)
+   @no-discard
+   (load-constant funcall temp0)
+   (push (% ra0))
+   (jmp-subprim .SPfuncall)
+   @bad                                 ; error spreading list.
+   (add (% imm0) (% rsp))               ; discard whatever's been pushed
+   (movq (% arg_y) (% arg_z))
+   (movl ($ '#.$XNOSPREAD) (%l arg_y))
+   (set-nargs 2)
+   (jmp-subprim .SPksignalerr) ))
+
+
+
+;;; This needs to:
+;;; (a) load FP arg regs from the FP-REGS argument
+;;; (b) call the .SPffcall subprimitive, which will discard the foreign stack frame
+;;;     allocated by WITH-VARIABLE-C-FRAME in %FF-CALL
+;;; (c) re-establish the same foreign stack frame and store the result regs
+;;;     (%rax/%xmm0) there
+(defx86lapfunction %do-ff-call ((nfp 0) (frame arg_x) (fp-regs arg_y) (entry arg_z))
+  (popq (% ra0))
+  (popq (% rax))
+  (movq (% rbp) (@  (% rsp)))
+  (movq (% rsp) (% rbp))
+  (movq (% ra0) (@ 8 (% rbp)))
+  (macptr-ptr fp-regs temp0)
+  (sarq ($ x8664::fixnumshift) (% rax))
+  (movq (@ (% temp0)) (% fp0))
+  (movq (@ 8 (% temp0)) (% fp1))
+  (movq (@ 16 (% temp0)) (% fp2))
+  (movq (@ 24 (% temp0)) (% fp3))
+  (movq (@ 32 (% temp0)) (% fp4))
+  (movq (@ 40 (% temp0)) (% fp5))
+  (movq (@ 48 (% temp0)) (% fp6))
+  (movq (@ 56 (% temp0)) (% fp7))
+  (call-subprim .SPffcall)
+  (movq (@ (% :rcontext) x8664::tcr.foreign-sp) (% mm5))
+  (movq (% mm5) (@ (% frame)))
+  (movq (% frame) (@ (% :rcontext) x8664::tcr.foreign-sp))
+  (movq (% rax) (@ 8 (% frame)))
+  (movq (% fp0) (@ 16 (% frame)))
+  (movl ($ nil) (%l arg_z))
+  (restore-simple-frame)
+  (single-value-return))
+  
+
+(defun %ff-call (entry &rest specs-and-vals)
+  (declare (dynamic-extent specs-and-vals))
+  (let* ((len (length specs-and-vals))
+         (total-words 0))
+    (declare (fixnum len total-words))
+    (let* ((result-spec (or (car (last specs-and-vals)) :void))
+           (nargs (ash (the fixnum (1- len)) -1))
+           (n-fp-args 0))
+      (declare (fixnum nargs n-fp-args))
+      (ecase result-spec
+        ((:address :unsigned-doubleword :signed-doubleword
+                   :single-float :double-float
+                   :signed-fullword :unsigned-fullword
+                   :signed-halfword :unsigned-halfword
+                   :signed-byte :unsigned-byte
+                   :void)
+         (do* ((i 0 (1+ i))
+               (specs specs-and-vals (cddr specs))
+               (spec (car specs) (car specs)))
+              ((= i nargs))
+           (declare (fixnum i))
+           (case spec
+             ((:address :unsigned-doubleword :signed-doubleword
+                        :single-float :double-float
+                        :signed-fullword :unsigned-fullword
+                        :signed-halfword :unsigned-halfword
+                        :signed-byte :unsigned-byte)
+              (incf total-words))
+             (t (if (typep spec 'unsigned-byte)
+                  (incf total-words spec)
+                  (error "unknown arg spec ~s" spec)))))
+         ;; It's necessary to ensure that the C frame is the youngest thing on
+         ;; the foreign stack here.
+         (%stack-block ((fp-args (* 8 8)))
+           (with-macptrs ((argptr))
+             (with-variable-c-frame
+                 total-words frame
+                 (%setf-macptr-to-object argptr frame)
+                 (let* ((gpr-offset 16)
+                        (other-offset (+ gpr-offset (* 6 8))))
+                   (declare (fixnum gpr-offset other-offset))
+                   (do* ((i 0 (1+ i))
+                         (ngpr-args 0)
+                         (specs specs-and-vals (cddr specs))
+                         (spec (car specs) (car specs))
+                         (val (cadr specs) (cadr specs)))
+                        ((= i nargs))
+                     (declare (fixnum i))
+                     (case spec
+                       (:address
+                        (incf ngpr-args)
+                        (cond ((<= ngpr-args 6)
+                               (setf (%get-ptr argptr gpr-offset) val)
+                               (incf gpr-offset 8))
+                              (t
+                               (setf (%get-ptr argptr other-offset) val)
+                               (incf other-offset 8))))
+                       ((:signed-doubleword :signed-fullword :signed-halfword
+                                            :signed-byte)
+                        (incf ngpr-args)
+                        (cond ((<= ngpr-args 6)
+                               (setf (%%get-signed-longlong argptr gpr-offset) val)
+                               (incf gpr-offset 8))
+                              (t
+                               (setf (%%get-signed-longlong argptr other-offset) val)
+                               (incf other-offset 8))))
+                       ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword
+                                              :unsigned-byte)
+                        (incf ngpr-args)
+                        (cond ((<= ngpr-args 6)
+                               (setf (%%get-unsigned-longlong argptr gpr-offset) val)
+                               (incf gpr-offset 8))
+                              (t
+                               (setf (%%get-unsigned-longlong argptr other-offset) val)
+                               (incf other-offset 8))))
+                       (:double-float
+                        (cond ((< n-fp-args 8)
+                               (setf (%get-double-float fp-args (* n-fp-args 8)) val)
+                               (incf n-fp-args))
+                              (t
+                               (setf (%get-double-float argptr other-offset) val)
+                               (incf other-offset 8))))
+                       (:single-float
+                        (cond ((< n-fp-args 8)
+                               (setf (%get-single-float fp-args (* n-fp-args 8))
+                                     val)
+                               (incf n-fp-args))
+                              (t 
+                               (setf (%get-single-float argptr other-offset) val)
+                               (incf other-offset 8))))
+                       (t
+                        (let* ((p 0))
+                          (declare (fixnum p))
+                          (dotimes (i (the fixnum spec))
+                            (setf (%get-ptr argptr other-offset) (%get-ptr val p))
+                            (incf p 8)
+                            (incf other-offset 8)))))))
+                 (%do-ff-call (min n-fp-args 8) frame fp-args entry)
+                 (ecase result-spec
+                   (:void nil)
+                   (:address (%get-ptr argptr 8))
+                   (:unsigned-byte (%get-unsigned-byte argptr 8))
+                   (:signed-byte (%get-signed-byte argptr 8))
+                   (:unsigned-halfword (%get-unsigned-word argptr 8))
+                   (:signed-halfword (%get-signed-word argptr 8))
+                   (:unsigned-fullword (%get-unsigned-long argptr 8))
+                   (:signed-fullword (%get-signed-long argptr 8))
+                   (:unsigned-doubleword (%get-natural argptr 8))
+                   (:signed-doubleword (%get-signed-natural argptr 8))
+                   (:single-float (%get-single-float argptr 16))
+                   (:double-float (%get-double-float argptr 16)))))))))))
+                                 
+
+;;; end of x86-def.lisp
Index: /branches/ia32/level-0/X86/x86-float.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-float.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-float.lisp	(revision 8365)
@@ -0,0 +1,457 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 2005 Clozure Associates
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  (require "NUMBER-MACROS")
+  (require :number-case-macro))
+
+
+;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit)
+;;;                   lo -  low 28 bits mantissa
+;;;                   exp  - take low 11 bits
+;;;                   sign - sign(sign) => result
+;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg
+;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg
+;;; no error checks, no tweaks, no nuthin 
+
+;;; sign is -1, 1, maybe zero
+
+
+
+(defx86lapfunction %make-float-from-fixnums ((float 16 )(hi 8) #|(ra 0)|#(lo arg_x) (exp arg_y) (sign arg_z))
+  (mov (% sign) (% imm1))
+  (sar ($ 63) (% imm1))
+  (shl ($ 63) (% imm1))
+  (movq (@ hi (% rsp)) (% imm0))                        ;hi
+  (andl ($ (ash (1- (ash 1 24)) x8664::fixnumshift)) (%l imm0))
+  (shl ($ (- 28 x8664::fixnumshift)) (% imm0))
+  (or (% imm0) (% imm1))
+  (unbox-fixnum lo imm0)
+  (andl ($ (1- (ash 1 28))) (%l imm0))
+  (or (% imm0) (% imm1))
+  (mov (% exp) (% imm0))
+  (shl ($ (- ieee-double-float-exponent-offset x8664::fixnumshift)) (% imm0))
+  (or (% imm0) (% imm1))
+  (movq (@ float (% rsp)) (% arg_z))
+  (mov (% imm1) (@ x8664::double-float.value (% arg_z)))
+  (single-value-return 4))
+
+
+;;; Maybe we should trap - or something - on NaNs.
+(defx86lapfunction %%double-float-abs! ((n arg_y)(val arg_z))
+  (mov (@ x8664::double-float.value (% n)) (% imm0))
+  (btr ($ 63) (% imm0))
+  (mov (% imm0) (@ x8664::double-float.value (% val)))
+  (single-value-return))
+
+
+(defx86lapfunction %short-float-abs ((n arg_z))
+  (btr ($ 63) (% n))
+  (single-value-return))
+
+
+(defx86lapfunction %double-float-negate! ((src arg_y) (res arg_z))
+  (movq (@ x8664::double-float.value (% src)) (% imm0))
+  (btcq ($ 63) (% imm0))
+  (movq (% imm0) (@ x8664::double-float.value (% res)))
+  (single-value-return))
+
+
+(defx86lapfunction %short-float-negate ((src arg_z))
+  (btcq ($ 63) (% arg_z))
+  (single-value-return))
+
+
+
+(defx86lapfunction dfloat-significand-zeros ((dfloat arg_z))
+  (movq (@ target::double-float.value (% dfloat)) (% imm1))
+  (shl ($ (1+ IEEE-double-float-exponent-width)) (% imm1))
+  (bsrq (% imm1) (% imm0))
+  (xorq ($ (1- target::nbits-in-word)) (% imm0))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+;;; This exploits the fact that the single float is already
+;;; shifted left 32 bits.  We don't want to count the tag
+;;; bit as significant, so bash the argument into a fixnum
+;;; first.
+(defx86lapfunction sfloat-significand-zeros ((sfloat arg_z))
+  (xorb (%b sfloat) (%b sfloat))
+  (shl ($ (1+ IEEE-single-float-exponent-width)) (% sfloat))
+  (bsrq (% sfloat) (% imm0))
+  (xorq ($ (1- target::nbits-in-word)) (% imm0))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z))
+  (unbox-fixnum int imm0)
+  (get-double-float float fp1)
+  (shl ($ IEEE-double-float-exponent-offset) (% imm0))
+  (movd (% imm0) (% fp2))
+  (mulsd (% fp2) (% fp1))
+  (put-double-float fp1 result)
+  (single-value-return))
+
+(defx86lapfunction %%scale-sfloat! ((float arg_y)(int arg_z))
+  (unbox-fixnum int imm0)
+  (shl ($ IEEE-double-float-exponent-offset) (% imm0))
+  (movd (% imm0) (% fp2))
+  (get-single-float float fp1)
+  (mulss (% fp2) (% fp1))
+  (put-single-float fp1 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z))
+  (get-double-float f1 fp1)
+  (put-double-float fp1 f2)
+  (single-value-return))
+
+(defx86lapfunction %short-float->double-float ((src arg_y) (result arg_z))
+  (get-single-float src fp1)
+  (cvtss2sd (% fp1) (% fp1))
+  (put-double-float fp1 result)
+  (single-value-return))
+
+(defx86lapfunction %double-float->short-float ((src arg_z))
+  (get-double-float src fp1)
+  (cvtsd2ss (% fp1) (% fp1))
+  (put-single-float fp1 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %int-to-sfloat ((int arg_z))
+  (int-to-single int imm0 fp1)
+  (put-single-float fp1 arg_z)
+  (single-value-return))
+  
+
+(defx86lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z))
+  (int-to-double int imm0 fp1)
+  (put-double-float fp1 arg_z)
+  (single-value-return))
+
+
+
+
+;;; Manipulate the MXCSR.  It'll fit in a fixnum, but we have to
+;;; load and store it through memory.  On x8664, we can hide the
+;;; 32-bit MXCSR value in a fixnum on the stack; on a 32-bit x86,
+;;; we might need to use a scratch location in the TCR or something.
+
+;;; Return the MXCSR as a fixnum
+(defx86lapfunction %get-mxcsr ()
+  (pushq ($ '0))
+  (stmxcsr (@ 4 (% rsp)))
+  (pop (% arg_z))
+  (shr ($ (- 32 x8664::fixnumshift)) (% arg_z))
+  (single-value-return))
+
+;;; Store the fixnum in arg_z in the MXCSR.  Just to be
+;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK,
+;;; so that only known control and status bits are written to.
+(defx86lapfunction %set-mxcsr ((val arg_z))
+  (mov (% val) (% temp0))
+  (andl ($ '#.x86::mxcsr-write-mask) (%l temp0))
+  (shl ($ (- 32 x8664::fixnumshift)) (% temp0))
+  (push (% temp0))
+  (ldmxcsr (@ 4 (% rsp)))
+  (add ($ '1) (% rsp))
+  (single-value-return))
+
+
+;;; Get the bits that contain exception masks and rounding mode.
+
+(defun %get-mxcsr-control ()
+  (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr))))
+
+;;; Get the bits that describe current exceptions.
+(defun %get-mxcsr-status ()
+  (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr))))
+
+;;; Set the bits that describe current exceptions, presumably to clear them.
+(defun %set-mxcsr-status (arg)
+  (%set-mxcsr
+   (logior (logand x86::mxcsr-status-mask arg)
+           (logandc2 (%get-mxcsr) x86::mxcsr-status-mask)))
+  arg)
+
+;;; Set the bits that mask/unmask exceptions and control rounding.
+;;; Clear the bits which describe current exceptions.
+(defun %set-mxcsr-control (arg)
+  (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg)))
+
+;;; Return the MXCSR value in effect after the last ff-call.
+(defx86lapfunction %get-post-ffi-mxcsr ()
+  (xor (% arg_z) (% arg_z))
+  (movl (@ (% :rcontext) x8664::tcr.ffi-exception) (%l imm0))
+  (movl (%l arg_z) (@ (% :rcontext) x8664::tcr.ffi-exception))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+;;; Return the status bits from the last ff-call that represent
+;;; unmasked exceptions
+(defun %ffi-exception-status ()
+  (logior (%get-mxcsr-control)
+          (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr)))))
+
+
+  
+
+;;; See if the binary double-float operation OP set any enabled
+;;; exception bits in the mxcsr
+(defun %df-check-exception-2 (operation op0 op1 fp-status)
+  (declare (type (unsigned-byte 6) fp-status))
+  (unless (zerop fp-status)
+    (%set-mxcsr-status 0)
+    ;; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status
+			   operation 
+			   (%copy-double-float op0 (%make-dfloat)) 
+			   (%copy-double-float op1 (%make-dfloat)))))
+
+(defun %sf-check-exception-2 (operation op0 op1 fp-status)
+  (declare (type (unsigned-byte 6) fp-status))
+  (unless (zerop fp-status)
+    (%set-mxcsr-status 0)
+    ;; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status 
+			   operation
+			   #+32-bit-target
+			   (%copy-short-float op0 (%make-sfloat))
+			   #+64-bit-target op0
+			   #+32-bit-target
+			   (%copy-short-float op1 (%make-sfloat))
+			   #+64-bit-target op1)))
+
+(defun %df-check-exception-1 (operation op0 fp-status)
+  (declare (fixnum fp-status))
+  (unless (zerop fp-status)
+    (%set-mxcsr-status 0)
+    ;; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status 
+                           operation 
+                           (%copy-double-float op0 (%make-dfloat)))))
+
+(defun %sf-check-exception-1 (operation op0 fp-status)
+  (declare (type (unsigned-byte 6) fp-status))
+  (unless (zerop fp-status)
+    (%set-mxcsr-status 0)
+    ;; Ensure that operands are heap-consed
+    (%fp-error-from-status fp-status 
+			   operation
+			   #+32-bit-target
+			   (%copy-short-float op0 (%make-sfloat))
+			   #+64-bit-target op0)))
+
+
+(defun fp-condition-from-mxcsr (status-bits control-bits)
+  (declare (fixnum status-bits control-bits))
+  (cond 
+   ((and (logbitp x86::mxcsr-ie-bit status-bits)
+         (not (logbitp x86::mxcsr-im-bit control-bits)))
+    'floating-point-invalid-operation)
+   ((and (logbitp x86::mxcsr-oe-bit status-bits)
+         (not (logbitp x86::mxcsr-om-bit control-bits)))
+    'floating-point-overflow)
+   ((and (logbitp x86::mxcsr-ue-bit status-bits)
+         (not (logbitp x86::mxcsr-um-bit control-bits)))
+    'floating-point-underflow)
+   ((and (logbitp x86::mxcsr-ze-bit status-bits)
+         (not (logbitp x86::mxcsr-zm-bit control-bits)))
+    'division-by-zero)
+   ((and (logbitp x86::mxcsr-pe-bit status-bits)
+         (not (logbitp x86::mxcsr-pm-bit control-bits)))
+    'floating-point-inexact)))
+
+(defun %fp-error-from-status (status-bits  operation op0 &optional op1)
+  (declare (type (unsigned-byte 6) status-bits))
+  (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control))))
+    (if condition-class
+      (let* ((operands (if op1 (list op0 op1) (list op0))))
+        (error (make-instance condition-class
+                              :operation operation
+                              :operands operands))))))
+
+
+
+;;; Don't we already have about 20 versions of this ?
+(defx86lapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z))
+  (macptr-ptr ptr imm0)
+  (unbox-fixnum byte-offset imm1)
+  (movsd (@ (% imm0) (% imm1)) (% fp1))
+  (put-double-float fp1 dest)
+  (single-value-return))
+
+
+(defvar *rounding-mode-alist*
+  '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3)))
+
+(defun get-fpu-mode (&optional (mode nil mode-p))
+  (let* ((flags (%get-mxcsr-control)))
+    (declare (fixnum flags))
+    (let* ((rounding-mode
+            (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0)
+                         (if (logbitp x86::mxcsr-rc1-bit flags) 2 0))
+                      *rounding-mode-alist*)))
+           (overflow (not (logbitp x86::mxcsr-om-bit flags)))
+           (underflow (not (logbitp x86::mxcsr-um-bit flags)))
+           (division-by-zero (not (logbitp x86::mxcsr-zm-bit flags)))
+           (invalid (not (logbitp x86::mxcsr-im-bit flags)))
+           (inexact (not (logbitp x86::mxcsr-pm-bit flags))))
+    (if mode-p
+      (ecase mode
+        (:rounding-mode rounding-mode)
+        (:overflow overflow)
+        (:underflow underflow)
+        (:division-by-zero division-by-zero)
+        (:invalid invalid)
+        (:inexact inexact))
+      `(:rounding-mode ,rounding-mode
+        :overflow ,overflow
+        :underflow ,underflow
+        :division-by-zero ,division-by-zero
+        :invalid ,invalid
+        :inexact ,inexact)))))
+
+;;; did we document this?
+(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p)
+                          (overflow t overflow-p)
+                          (underflow t underflow-p)
+                          (division-by-zero t zero-p)
+                          (invalid t invalid-p)
+                          (inexact t inexact-p))
+  (let* ((current (%get-mxcsr-control))
+         (new current))
+    (declare (fixnum current new))
+    (when rounding-p
+      (let* ((rc-bits (or
+                       (cdr (assoc rounding-mode *rounding-mode-alist*))
+                       (error "Unknown rounding mode: ~s" rounding-mode))))
+        (declare (fixnum rc-bits))
+        (if (logbitp 0 rc-bits)
+          (bitsetf x86::mxcsr-rc0-bit new)
+          (bitclrf x86::mxcsr-rc0-bit new))
+        (if (logbitp 1 rc-bits)
+          (bitsetf x86::mxcsr-rc1-bit new)
+          (bitclrf x86::mxcsr-rc1-bit new))))
+    (when invalid-p
+      (if invalid
+        (bitclrf x86::mxcsr-im-bit new)
+        (bitsetf x86::mxcsr-im-bit new)))
+    (when overflow-p
+      (if overflow
+        (bitclrf x86::mxcsr-om-bit new)
+        (bitsetf x86::mxcsr-om-bit new)))
+    (when underflow-p
+      (if underflow
+        (bitclrf x86::mxcsr-um-bit new)
+        (bitsetf x86::mxcsr-um-bit new)))
+    (when zero-p
+      (if division-by-zero
+        (bitclrf x86::mxcsr-zm-bit new)
+        (bitsetf x86::mxcsr-zm-bit new)))
+    (when inexact-p
+      (if inexact
+        (bitclrf x86::mxcsr-pm-bit new)
+        (bitsetf x86::mxcsr-pm-bit new)))
+    (unless (= current new)
+      (%set-mxcsr-control new))
+    (%get-mxcsr)))
+
+
+
+;;; Copy a single float pointed at by the macptr in single
+;;; to a double float pointed at by the macptr in double
+
+(defx86lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z))
+  (check-nargs 2)
+  (macptr-ptr single imm0)
+  (movss (@ (% imm0)) (% fp1))
+  (cvtss2sd (% fp1) (% fp1))
+  (macptr-ptr double imm0)
+  (movsd (% fp1) (@ (% imm0)))
+  (single-value-return))
+
+;;; Copy a double float pointed at by the macptr in double
+;;; to a single float pointed at by the macptr in single.
+(defx86lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z))
+  (check-nargs 2)
+  (macptr-ptr double imm0)
+  (movsd (@ (% imm0)) (% fp1))
+  (cvtsd2ss (% fp1) (% fp1))
+  (macptr-ptr single imm0)
+  (movss (% fp1) (@ (% imm0)))
+  (single-value-return))
+
+
+(defx86lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z))
+  (check-nargs 2)
+  (macptr-ptr macptr imm0)
+  (get-double-float src fp1)
+  (cvtsd2ss (% fp1) (% fp1))
+  (movss (% fp1) (@ (% imm0)))
+  (single-value-return))
+
+(defx86lapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z))
+  (shl ($ (- 32 x8664::fixnumshift)) (% arg_z))
+  (movb ($ x8664::subtag-single-float) (% arg_z.b))
+  (single-value-return))
+
+(defx86lapfunction single-float-bits ((f arg_z))
+  (shr ($ (- 32 x8664::fixnumshift)) (% f))
+  (single-value-return))
+
+(defun double-float-bits (f)
+  (values (uvref f target::double-float.val-high-cell)
+          (uvref f target::double-float.val-low-cell)))
+
+(defun double-float-from-bits (high low)
+  (let* ((f (%make-dfloat)))
+    (setf (uvref f target::double-float.val-high-cell) high
+          (uvref f target::double-float.val-low-cell) low)
+    f))
+
+;;; Return T if n is negative, else NIL.
+(defx86lapfunction %double-float-sign ((n arg_z))
+  (movl (@ x8664::double-float.val-high (% n)) (% imm0.l))
+  (testl (% imm0.l) (% imm0.l))
+  (movl ($ x8664::t-value) (% imm0.l))
+  (movl ($ x8664::nil-value) (% arg_z.l))
+  (cmovlq (% imm0) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %short-float-sign ((n arg_z))
+  (testq (% n) (% n))
+  (movl ($ x8664::t-value) (% imm0.l))
+  (movl ($ x8664::nil-value) (% arg_z.l))
+  (cmovlq (% imm0) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %double-float-sqrt! ((n arg_y) (result arg_z))
+  (get-double-float n fp0)
+  (sqrtsd (% fp0) (% fp0))
+  (put-double-float fp0 result)
+  (single-value-return))
+
+(defx86lapfunction %single-float-sqrt ((n arg_z))
+  (get-single-float n fp0)
+  (sqrtss (% fp0) (% fp0))
+  (put-single-float fp0 arg_z)
+  (single-value-return))
+
+;;; end of x86-float.lisp
Index: /branches/ia32/level-0/X86/x86-hash.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-hash.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-hash.lisp	(revision 8365)
@@ -0,0 +1,103 @@
+;;; -*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 2006, Clozure Associates and contributors
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+;;; level-0;ppc;ppc-hash.lisp
+
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  (require "HASHENV" "ccl:xdump;hashenv"))
+
+
+
+
+;;; This should stay in LAP so that it's fast
+;;; Equivalent to cl:mod when both args are positive fixnums
+
+
+(defx86lapfunction fast-mod ((number arg_y) (divisor arg_z))
+  (xorq (% imm1) (% imm1))
+  (mov (% number) (% imm0))
+  (div (% divisor))
+  (mov (% imm1) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %dfloat-hash ((key arg_z))
+  (movq (@ x8664::double-float.value (% key)) (% imm0))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %sfloat-hash ((key arg_z))
+  (mov (% key) (% imm1))
+  (movl ($ #x-80000000) (%l imm0))
+  (shr ($ 32) (% imm1))
+  (xorq (% arg_y) (% arg_y))
+  (shr ($ (- 32 x8664::fixnumshift)) (% key))
+  (rcmp (%l imm0) (%l imm1))
+  (cmoveq (% arg_y) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %macptr-hash ((key arg_z))
+  (movq (@ target::macptr.address (% key)) (% imm0))
+  (movq (% imm0) (% imm1))
+  (shlq ($ 24) (% imm1))
+  (addq (% imm1) (% imm0))
+  (movq ($ (lognot target::fixnummask)) (% arg_z))
+  (andq (% imm0) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %bignum-hash ((key arg_z))
+  (let ((header imm0)
+        (offset imm1)
+        (ndigits temp0))
+    (getvheader key header)
+    (header-length header ndigits)
+    (xorq (% offset) (% offset))
+    (let ((immhash header))
+      @loop
+      (rolq ($ 13) (% immhash))
+      (addl (@ x8664::misc-data-offset (% key) (% offset)) (%l immhash))
+      (addq ($ 4) (% offset))
+      (subq ($ '1) (% ndigits))
+      (jne  @loop)
+      (box-fixnum immhash arg_z))
+    (single-value-return)))
+
+
+(defx86lapfunction %get-fwdnum ()
+  (ref-global target::fwdnum arg_z)
+  (single-value-return))
+
+
+(defx86lapfunction %get-gc-count ()
+  (ref-global target::gc-count arg_z)
+  (single-value-return))
+
+
+;;; Setting a key in a hash-table vector needs to 
+;;; ensure that the vector header gets memoized as well
+(defx86lapfunction %set-hash-table-vector-key ((vector arg_x) (index arg_y) (value arg_z))
+  (jmp-subprim .SPset-hash-key))
+
+;;; Strip the tag bits to turn x into a fixnum
+(defx86lapfunction strip-tag-to-fixnum ((x arg_z))
+  (andb ($ (lognot x8664::fixnummask)) (%b x))
+  (single-value-return))
+
+;;; end of x86-hash.lisp
Index: /branches/ia32/level-0/X86/x86-io.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-io.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-io.lisp	(revision 8365)
@@ -0,0 +1,31 @@
+;;; -*- Mode: Lisp; Package: CCL; -*-
+;;;
+;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+
+
+(in-package "CCL")
+
+;;; not very smart yet
+
+(defx86lapfunction %get-errno ()
+  (movq (@ (% :rcontext) x8664::tcr.errno-loc) (% imm1))
+  (movslq (@ (% imm1)) (% imm0))
+  (movss (% fp0) (@ (% imm1)))
+  (negq (% imm0))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+; end
Index: /branches/ia32/level-0/X86/x86-misc.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-misc.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-misc.lisp	(revision 8365)
@@ -0,0 +1,753 @@
+;;; -*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+;;; level-0;x86;x86-misc.lisp
+
+
+(in-package "CCL")
+
+;;; Copy N bytes from pointer src, starting at byte offset src-offset,
+;;; to ivector dest, starting at offset dest-offset.
+;;; It's fine to leave this in lap.
+;;; Depending on alignment, it might make sense to move more than
+;;; a byte at a time.
+;;; Does no arg checking of any kind.  Really.
+
+(defx86lapfunction %copy-ptr-to-ivector ((src (* 2 x8664::node-size) )
+                                         (src-byte-offset (* 1 x8664::node-size))
+                                         #|(ra 0)|#
+                                         (dest arg_x)
+                                         (dest-byte-offset arg_y)
+                                         (nbytes arg_z))
+  (let ((rsrc temp0)
+        (rsrc-byte-offset temp1))
+    (testq (% nbytes) (% nbytes))
+    (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset))         ; boxed src-byte-offset
+    (movq (@ src (% rsp)) (% rsrc))     ; src macptr
+    (jmp @test)
+    @loop
+    (unbox-fixnum rsrc-byte-offset imm0)
+    (addq ($ '1) (% rsrc-byte-offset))
+    (addq (@ x8664::macptr.address (% rsrc)) (% imm0))
+    (movb (@ (% imm0)) (%b imm0))
+    (unbox-fixnum dest-byte-offset imm1)
+    (addq ($ '1) (% dest-byte-offset))
+    (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1)))
+    (subq ($ '1) (% nbytes))
+    @test
+    (jne @loop)
+    (movq (% dest) (% arg_z))
+    (single-value-return 4)))
+
+(defx86lapfunction %copy-ivector-to-ptr ((src (* 2 x8664::node-size))
+                                         (src-byte-offset (* 1 x8664::node-size))
+                                         #|(ra 0)|#
+                                         (dest arg_x)
+                                         (dest-byte-offset arg_y)
+                                         (nbytes arg_z))
+  (let ((rsrc temp0)
+        (rsrc-byte-offset temp1))
+    (testq (% nbytes) (% nbytes))
+    (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset))
+    (movq (@ src (% rsp)) (% rsrc))
+    (jmp @test)
+    @loop
+    (unbox-fixnum rsrc-byte-offset imm0)
+    (addq ($ '1) (% rsrc-byte-offset))
+    (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0))
+    (unbox-fixnum dest-byte-offset imm1)
+    (addq ($ '1) (% dest-byte-offset))
+    (addq (@ x8664::macptr.address (%q dest)) (% imm1))
+    (movb (%b imm0) (@ (% imm1)))
+    (subq ($ '1) (% nbytes))
+    @test
+    (jne @loop)
+    (movq (% dest) (% arg_z))
+    (single-value-return 4)))
+
+
+
+(defx86lapfunction %copy-ivector-to-ivector ((src-offset 16) 
+                                             (src-byte-offset 8)
+                                             #|(ra 0)|#
+                                             (dest arg_x)
+                                             (dest-byte-offset arg_y)
+                                             (nbytes arg_z))
+  (let ((rsrc temp0)
+        (rsrc-byte-offset temp1))
+    (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset))
+    (movq (@ src-offset (% rsp)) (% rsrc))
+    (cmpq (% dest) (% rsrc))
+    (jne @front)
+    (cmpq (% src-byte-offset) (% dest-byte-offset))
+    (jg @back)
+    @front
+    (testq (% nbytes) (% nbytes))
+    (jmp @front-test)
+    @front-loop
+    (unbox-fixnum rsrc-byte-offset imm0)
+    (addq ($ '1) (% rsrc-byte-offset))
+    (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0))
+    (unbox-fixnum dest-byte-offset imm1)
+    (addq ($ '1) (% dest-byte-offset))
+    (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1)))
+    (subq ($ '1) (% nbytes))
+    @front-test
+    (jne @front-loop)
+    (movq (% dest) (% arg_z))
+    (single-value-return 4)
+    @back
+    (addq (% nbytes) (% rsrc-byte-offset))
+    (addq (% nbytes) (% dest-byte-offset))
+    (testq (% nbytes) (% nbytes))
+    (jmp @back-test)
+    @back-loop
+    (subq ($ '1) (% rsrc-byte-offset))
+    (unbox-fixnum rsrc-byte-offset imm0)
+    (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0))
+    (subq ($ '1) (% dest-byte-offset))
+    (unbox-fixnum dest-byte-offset imm1)
+    (subq ($ '1) (% nbytes))
+    (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1)))
+    @back-test
+    (jne @back-loop)
+    (movq (% dest) (% arg_z))
+    (single-value-return 4)))
+  
+
+(defx86lapfunction %copy-gvector-to-gvector ((src (* 2 x8664::node-size))
+					     (src-element (* 1 x8664::node-size))
+                                             #|(ra 0)|#
+					     (dest arg_x)
+					     (dest-element arg_y)
+					     (nelements arg_z))
+  (let ((rsrc temp0)
+        (rsrc-element imm1)
+        (val temp1))
+    (movq (@ src-element (% rsp)) (% rsrc-element))
+    (movq (@ src (% rsp)) (% rsrc))
+    (cmpq (% rsrc) (% dest))
+    (jne @front)
+    (rcmp (% rsrc-element) (% dest-element))
+    (jl @back)
+    @front
+    (testq (% nelements) (% nelements))
+    (jmp @front-test)
+    @front-loop
+    (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val))
+    (addq ($ '1) (% rsrc-element))
+    (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element)))
+    (addq ($ '1) (% dest-element))
+    (subq ($ '1) (% nelements))
+    @front-test
+    (jne @front-loop)
+    (movq (% dest) (% arg_z))
+    (single-value-return 4)
+    @back
+    (addq (% nelements) (% rsrc-element))
+    (addq (% nelements) (% dest-element))
+    (testq (% nelements) (% nelements))
+    (jmp @back-test)
+    @back-loop
+    (subq ($ '1) (% rsrc-element))
+    (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val))
+    (subq ($ '1) (% dest-element))
+    (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element)))
+    (subq ($ '1) (% nelements))
+    @back-test
+    (jne @back-loop)
+    (movq (% dest) (% arg_z))
+    (single-value-return 4)))
+
+(defx86lapfunction %heap-bytes-allocated ()
+  (movq (@ (% :rcontext) x8664::tcr.save-allocptr) (% temp1))
+  (movq (@ (% :rcontext) x8664::tcr.last-allocptr) (% temp0))
+  (cmpq ($ -16) (% temp1))
+  (movq (@ (% :rcontext) x8664::tcr.total-bytes-allocated) (% imm0))
+  (jz @go)
+  (movq (% temp0) (% temp2))
+  (subq (% temp1) (% temp0))
+  (testq (% temp2) (% temp2))
+  (jz @go)
+  (add (% temp0) (% imm0))
+  @go
+  (jmp-subprim .SPmakeu64))
+
+
+(defx86lapfunction values ()
+  (:arglist (&rest values))
+  (save-frame-variable-arg-count)
+  (push-argregs)
+  (jmp-subprim .SPnvalret))
+
+(defx86lapfunction rdtsc ()
+  (:byte #x0f)                          ;two-byte rdtsc opcode
+  (:byte #x31)                          ;is #x0f #x31
+  (shlq ($ 32) (% rdx))
+  (orq (% rdx) (% rax))
+  (imul ($ (* 2 target::node-size)) (% rax) (% arg_z))
+  (shrq ($ 1) (% arg_z))
+  (single-value-return))
+
+;;; Return all 64 bits of the time-stamp counter as an unsigned integer.
+(defx86lapfunction rdtsc64 ()
+  (:byte #x0f)                          ;two-byte rdtsc opcode
+  (:byte #x31)                          ;is #x0f #x31
+  (shlq ($ 32) (% rdx))
+  (orq (% rdx) (% rax))
+  (jmp-subprim .SPmakeu64))
+
+;;; It would be nice if (%setf-macptr macptr (ash (the fixnum value)
+;;; ash::fixnumshift)) would do this inline.
+
+(defx86lapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z))
+  (check-nargs 2)
+  (trap-unless-typecode= macptr x8664::subtag-macptr)
+  (movq (% object) (@ x8664::macptr.address (% macptr)))
+  (single-value-return))
+
+(defx86lapfunction %fixnum-from-macptr ((macptr arg_z))
+  (check-nargs 1)
+  (trap-unless-typecode= arg_z x8664::subtag-macptr)
+  (movq (@ x8664::macptr.address (% arg_z)) (% imm0))
+  (trap-unless-lisptag= imm0 x8664::tag-fixnum imm1)
+  (movq (% imm0) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z))
+  (trap-unless-typecode= ptr x8664::subtag-macptr)
+  (macptr-ptr ptr imm1)
+  (unbox-fixnum offset imm0)
+  (movq (@ (% imm1) (% imm0)) (% imm0))
+  (jmp-subprim .SPmakeu64))
+
+
+(defx86lapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z))
+  (trap-unless-typecode= ptr x8664::subtag-macptr)
+  (macptr-ptr ptr imm1)
+  (unbox-fixnum offset imm0)
+  (movq (@ (% imm1) (% imm0)) (% imm0))
+  (jmp-subprim .SPmakes64))
+
+
+
+
+(defx86lapfunction %%set-unsigned-longlong ((ptr arg_x)
+                                            (offset arg_y)
+                                            (val arg_z))
+  (save-simple-frame)
+  (trap-unless-typecode= ptr x8664::subtag-macptr)
+  (call-subprim .SPgetu64)
+  (macptr-ptr ptr ptr)
+  (unbox-fixnum offset imm1)
+  (movq (% imm0) (@ (% ptr) (% imm1)))
+  (restore-simple-frame)
+  (single-value-return))
+
+
+(defx86lapfunction %%set-signed-longlong ((ptr arg_x)
+                                          (offset arg_y)
+                                          (val arg_z))
+  (save-simple-frame)
+  (trap-unless-typecode= ptr x8664::subtag-macptr)
+  (call-subprim .SPgets64)
+  (macptr-ptr ptr ptr)
+  (unbox-fixnum offset imm1)
+  (movq (% imm0) (@ (% ptr) (% imm1)))
+  (restore-simple-frame)
+  (single-value-return))
+
+(defx86lapfunction interrupt-level ()
+  (movq (@ (% :rcontext) x8664::tcr.tlb-pointer) (% imm1))
+  (movq (@ x8664::interrupt-level-binding-index (% imm1)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction set-interrupt-level ((new arg_z))
+  (movq (@ (% :rcontext) x8664::tcr.tlb-pointer) (% imm1))
+  (trap-unless-fixnum new)
+  (movq (% new) (@ x8664::interrupt-level-binding-index (% imm1)))
+  (single-value-return))
+
+(defx86lapfunction %current-tcr ()
+  (movq (@ (% :rcontext) x8664::tcr.linear) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %tcr-toplevel-function ((tcr arg_z))
+  (check-nargs 1)
+  (cmpq (% tcr) (@ (% :rcontext) x8664::tcr.linear))
+  (movq (% rsp) (% imm0))
+  (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0))
+  (movq (@ x8664::area.high (% temp0)) (% imm1))
+  (jz @room)
+  (movq (@ x8664::area.active (% temp0)) (% imm0))
+  @room
+  (cmpq (% imm1) (% imm0))
+  (movl ($ x8664::nil-value) (%l arg_z))
+  (cmovneq (@ (- x8664::node-size) (% imm1)) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z))
+  (check-nargs 2)
+  (cmpq (% tcr) (@ (% :rcontext) x8664::tcr.linear))
+  (movq (% rsp) (% imm0))
+  (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0))
+  (movq (@ x8664::area.high (% temp0)) (% imm1))
+  (jz @room)
+  (movq (@ x8664::area.active (% temp0)) (% imm0))
+  @room
+  (cmpq (% imm1) (% imm0))
+  (leaq (@ (- x8664::node-size) (% imm1)) (% imm1))
+  (movq ($ 0) (@ (% imm1)))
+  (jne @have-room)
+  (movq (% imm1) (@ x8664::area.active (% temp0)))
+  (movq (% imm1) (@ x8664::tcr.save-vsp (% tcr)))
+  @have-room
+  (movq (% fun) (@ (% imm1)))
+  (single-value-return))
+
+;;; This needs to be done out-of-line, to handle EGC memoization.
+(defx86lapfunction %store-node-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z))
+  (movq (@ offset (% rsp)) (% temp0))
+  (save-simple-frame)
+  (call-subprim .SPstore-node-conditional)
+  (restore-simple-frame)
+  (single-value-return 3))
+
+(defx86lapfunction %store-immediate-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z))
+  (movq (@ offset (% rsp)) (% temp0))
+  (unbox-fixnum temp0 imm1)
+  @again
+  (movq (@ (% object) (% imm1)) (% rax))
+  (cmpq (% rax) (% old))
+  (jne @lose)
+  (lock)
+  (cmpxchgq (% new) (@ (% object) (% imm1)))
+  (jne @again)
+  (movl ($ x8664::t-value) (%l arg_z))
+  (single-value-return 3)
+  @lose
+  (movl ($ x8664::nil-value) (%l arg_z))
+  (single-value-return 3))
+
+(defx86lapfunction set-%gcable-macptrs% ((ptr x8664::arg_z))
+  @again
+  (movq (@ (+ x8664::nil-value (x8664::kernel-global gcable-pointers)))
+        (% rax))
+  (movq (% rax) (@ x8664::xmacptr.link (% ptr)))
+  (lock)
+  (cmpxchgq (% ptr) (@ (+ x8664::nil-value (x8664::kernel-global gcable-pointers))))
+  (jne @again)
+  (single-value-return))
+
+;;; Atomically increment or decrement the gc-inhibit-count kernel-global
+;;; (It's decremented if it's currently negative, incremented otherwise.)
+(defx86lapfunction %lock-gc-lock ()
+  @again
+  (movq (@ (+ x8664::nil-value (x8664::kernel-global gc-inhibit-count))) (% rax))
+  (lea (@ '-1 (% rax)) (% temp0))
+  (lea (@ '1 (% rax)) (% arg_z))
+  (testq (% rax) (% rax))
+  (cmovsq (% temp0) (% arg_z))
+  (lock)
+  (cmpxchgq (% arg_z) (@ (+ x8664::nil-value (x8664::kernel-global gc-inhibit-count))))
+  (jnz @again)
+  (single-value-return))
+
+;;; Atomically decrement or increment the gc-inhibit-count kernel-global
+;;; (It's incremented if it's currently negative, incremented otherwise.)
+;;; If it's incremented from -1 to 0, try to GC (maybe just a little.)
+(defx86lapfunction %unlock-gc-lock ()
+  @again
+  (movq (@ (+ x8664::nil-value (x8664::kernel-global gc-inhibit-count)))
+        (% rax))
+  (lea (@ '1 (% rax)) (% arg_x))
+  (cmpq ($ -1) (% rax))
+  (lea (@ '-1 (% rax)) (% arg_z))
+  (cmovleq (% arg_x) (% arg_z))
+  (lock)
+  (cmpxchgq (% arg_z) (@ (+ x8664::nil-value (x8664::kernel-global gc-inhibit-count))))
+  (jne @again)
+  (cmpq ($ '-1) (% rax))
+  (jne @done)
+  ;; The GC tried to run while it was inhibited.  Unless something else
+  ;; has just inhibited it, it should be possible to GC now.
+  (mov ($ arch::gc-trap-function-immediate-gc) (% imm0))
+  (uuo-gc-trap)
+  @done
+  (single-value-return))
+
+;;; Return true iff we were able to increment a non-negative
+;;; lock._value
+(defx86lapfunction %try-read-lock-rwlock ((lock arg_z))
+  (check-nargs 1)
+  @try
+  (movq (@ x8664::lock._value (% lock)) (% rax))
+  (movq (% rax) (% imm1))
+  (addq ($ '1) (% imm1))
+  (jle @fail)
+  (lock)
+  (cmpxchgq (% imm1) (@ x8664::lock._value (% lock)))
+  (jne @try)
+  (single-value-return)                                 ; return the lock
+@fail
+  (movl ($ x8664::nil-value) (%l arg_z))
+  (single-value-return))
+
+
+
+(defx86lapfunction unlock-rwlock ((lock arg_z))
+  (cmpq ($ 0) (@ x8664::lock._value (% lock)))
+  (jle @unlock-write)
+  @unlock-read
+  (movq (@ x8664::lock._value (% lock)) (% rax))
+  (lea (@ '-1 (% imm0)) (% imm1))
+  (lock)
+  (cmpxchgq (% imm1) (@ x8664::lock._value (% lock)))
+  (jne @unlock-read)
+  (single-value-return)
+  @unlock-write
+  ;;; If we aren't the writer, return NIL.
+  ;;; If we are and the value's about to go to 0, clear the writer field.
+  (movq (@ x8664::lock.writer (% lock)) (% imm0))
+  (cmpq (% imm0) (@ (% :rcontext) x8664::tcr.linear))
+  (jne @fail)
+  (cmpq ($ '-1) (@ x8664::lock._value (% lock)))
+  (jne @still-owner)
+  (movsd (% fpzero) (@ x8664::lock.writer (% lock)))
+  @still-owner
+  (addq ($ '1) (@ x8664::lock._value (% lock)))
+  (single-value-return)
+  @fail
+  (movl ($ x8664::nil-value) (%l arg_z))
+  (single-value-return))
+
+(defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
+  (check-nargs 3)
+  (unbox-fixnum disp imm1)
+  @again
+  (movq (@ (% node) (% imm1)) (% rax))
+  (lea (@ (% rax) (% by)) (% arg_z))
+  (lock)
+  (cmpxchgq (% arg_z) (@ (% node) (% imm1)))
+  (jne @again)
+  (single-value-return))
+
+(defx86lapfunction %atomic-incf-ptr ((ptr arg_z))
+  (macptr-ptr ptr ptr)
+  @again
+  (movq (@ (% ptr)) (% rax))
+  (lea (@ 1 (% rax)) (% imm1))
+  (lock)
+  (cmpxchgq (% imm1) (@ (% ptr)))
+  (jne @again)
+  (box-fixnum imm1 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z))
+  (macptr-ptr ptr ptr)
+  @again
+  (movq (@ (% ptr)) (% rax))
+  (unbox-fixnum by imm1)
+  (add (% rax) (% imm1))
+  (lock)
+  (cmpxchgq (% imm1) (@ (% ptr)))
+  (jnz @again)
+  (box-fixnum imm1 arg_z)
+  (single-value-return))
+
+
+(defx86lapfunction %atomic-decf-ptr ((ptr arg_z))
+  (macptr-ptr ptr ptr)
+  @again
+  (movq (@ (% ptr)) (% rax))
+  (lea (@ -1 (% rax)) (% imm1))
+  (lock)
+  (cmpxchgq (% imm1) (@ (% ptr)))
+  (jnz @again)
+  (box-fixnum imm1 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %atomic-decf-ptr-if-positive ((ptr arg_z))
+  (macptr-ptr ptr ptr)                  ;must be fixnum-aligned
+  @again
+  (movq (@ (% ptr)) (% rax))
+  (testq (% rax) (% rax))
+  (lea (@ -1 (% rax)) (% imm1))
+  (jz @done)
+  (lock)
+  (cmpxchgq (% imm1) (@ (% ptr)))
+  (jnz @again)
+  @done
+  (box-fixnum imm1 arg_z)
+  (single-value-return))
+
+
+(defx86lapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z))
+  (macptr-ptr arg_y imm1)
+  (unbox-fixnum newval imm0)
+  (lock)
+  (xchgq (% imm0) (@ (% imm1)))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
+;;; was equal to OLDVAL.  Return the old value
+(defx86lapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
+  (macptr-ptr ptr ptr)                  ;  must be fixnum-aligned
+  @again
+  (movq (@ (% ptr)) (% imm0))
+  (box-fixnum imm0 temp0)
+  (cmpq (% temp0) (% expected-oldval))
+  (jne @done)
+  (unbox-fixnum newval imm1)
+  (lock)
+  (cmpxchgq (% imm1) (@ (% ptr)))
+  (jne @again)
+  @done
+  (movq (% temp0) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
+  (let ((address imm1))
+    (macptr-ptr ptr address)
+    @again
+    (movq (@ (% address)) (% imm0))
+    (cmpq (% imm0) (% expected-oldval))
+    (jne @done)
+    (lock)
+    (cmpxchgq (% newval) (@ (% address)))
+    (jne @again)
+    @done
+    (movq (% imm0) (% arg_z))
+    (single-value-return)))
+
+
+(defx86lapfunction %macptr->dead-macptr ((macptr arg_z))
+  (check-nargs 1)
+  (movb ($ x8664::subtag-dead-macptr) (@ x8664::misc-subtag-offset (% macptr)))
+  (single-value-return))
+
+#+are-you-kidding
+(defx86lapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0)
+                                     (parent arg_x) (function arg_y) (arglist arg_z))
+  (check-nargs 7)
+
+  ; Throw through catch-count catch frames
+  (lwz imm0 12 vsp)                      ; catch-count
+  (vpush parent)
+  (vpush function)
+  (vpush arglist)
+  (bla .SPnthrowvalues)
+
+  ; Pop tsp-count TSP frames
+  (lwz tsp-count 16 vsp)
+  (cmpi cr0 tsp-count 0)
+  (b @test)
+@loop
+  (subi tsp-count tsp-count '1)
+  (cmpi cr0 tsp-count 0)
+  (lwz tsp 0 tsp)
+@test
+  (bne cr0 @loop)
+
+  ; Pop dynamic bindings until we get to db-link
+  (lwz imm0 12 vsp)                     ; db-link
+  (lwz imm1 x8664::tcr.db-link :rcontext)
+  (cmp cr0 imm0 imm1)
+  (beq cr0 @restore-regs)               ; .SPunbind-to expects there to be something to do
+  (bla .SPunbind-to)
+
+@restore-regs
+  ; restore the saved registers from srv
+  (lwz srv 20 vsp)
+@get0
+  (svref imm0 1 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @get1)
+  (lwz save0 0 imm0)
+@get1
+  (svref imm0 2 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @get2)
+  (lwz save1 0 imm0)
+@get2
+  (svref imm0 3 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @get3)
+  (lwz save2 0 imm0)
+@get3
+  (svref imm0 4 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @get4)
+  (lwz save3 0 imm0)
+@get4
+  (svref imm0 5 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @get5)
+  (lwz save4 0 imm0)
+@get5
+  (svref imm0 6 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @get6)
+  (lwz save5 0 imm0)
+@get6
+  (svref imm0 7 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @get7)
+  (lwz save6 0 imm0)
+@get7
+  (svref imm0 8 srv)
+  (cmpwi cr0 imm0 x8664::nil-value)
+  (beq @got)
+  (lwz save7 0 imm0)
+@got
+
+  (vpop arg_z)                          ; arglist
+  (vpop temp0)                          ; function
+  (vpop parent)                         ; parent
+  (extract-lisptag imm0 parent)
+  (cmpi cr0 imm0 x8664::tag-fixnum)
+  (if (:cr0 :ne)
+    ; Parent is a fake-stack-frame. Make it real
+    (progn
+      (svref sp %fake-stack-frame.sp parent)
+      (stwu sp (- x8664::lisp-frame.size) sp)
+      (svref fn %fake-stack-frame.fn parent)
+      (stw fn x8664::lisp-frame.savefn sp)
+      (svref temp1 %fake-stack-frame.vsp parent)
+      (stw temp1 x8664::lisp-frame.savevsp sp)
+      (svref temp1 %fake-stack-frame.lr parent)
+      (extract-lisptag imm0 temp1)
+      (cmpi cr0 imm0 x8664::tag-fixnum)
+      (if (:cr0 :ne)
+        ;; must be a macptr encoding the actual link register
+        (macptr-ptr loc-pc temp1)
+        ;; Fixnum is offset from start of function vector
+        (progn
+          (svref temp2 0 fn)        ; function vector
+          (unbox-fixnum temp1 temp1)
+          (add loc-pc temp2 temp1)))
+      (stw loc-pc x8664::lisp-frame.savelr sp))
+    ;; Parent is a real stack frame
+    (mr sp parent))
+  (set-nargs 0)
+  (bla .SPspreadargz)
+  (ba .SPtfuncallgen))
+
+
+
+  
+(defx86lapfunction %%save-application ((flags arg_y) (fd arg_z))
+  (unbox-fixnum flags imm0)
+  (orq ($ arch::gc-trap-function-save-application) (% imm0))
+  (unbox-fixnum fd imm1)
+  (uuo-gc-trap)
+  (single-value-return))
+
+
+
+(defx86lapfunction %misc-address-fixnum ((misc-object arg_z))
+  (check-nargs 1)
+  (lea (@ x8664::misc-data-offset (% misc-object)) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
+  (check-nargs 3)
+  (macptr-ptr ptr imm1) ; address in macptr
+  (lea (@ 17 (% imm1)) (% imm0))     ; 2 for delta + 15 for alignment
+  (andb ($ -16) (%b  imm0))   ; Clear low four bits to align
+  (subq (% imm0) (% imm1))  ; imm1 = -delta
+  (negw (%w imm1))
+  (movw (%w imm1) (@  -2 (% imm0)))     ; save delta halfword
+  (unbox-fixnum subtype imm1)  ; subtype at low end of imm1
+  (shlq ($ (- x8664::num-subtag-bits x8664::fixnum-shift)) (% len ))
+  (orq (% len) (% imm1))
+  (movq (% imm1) (@ (% imm0)))       ; store subtype & length
+  (lea (@ x8664::fulltag-misc (% imm0)) (% arg_z)) ; tag it, return it
+  (single-value-return))
+
+(defx86lapfunction %%make-disposable ((ptr arg_y) (vector arg_z))
+  (check-nargs 2)
+  (lea (@ (- x8664::fulltag-misc) (% vector)) (% imm0)) ; imm0 is addr = vect less tag
+  (movzwq (@ -2 (% imm0)) (% imm1))     ; get delta
+  (subq (% imm1) (% imm0))              ; vector addr (less tag)  - delta is orig addr
+  (movq (% imm0) (@ x8664::macptr.address (% ptr)))
+  (single-value-return))
+
+
+(defx86lapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
+  (lea (@ x8664::misc-data-offset (% vect)) (% imm0))
+  (movq (% imm0) (@ x8664::macptr.address (% ptr)))
+  (single-value-return))
+
+(defx86lapfunction get-saved-register-values ()
+  (movq (% rsp) (% temp0))
+  (push (% save0))
+  (push (% save1))
+  (push (% save2))
+  (push (% save3))
+  (set-nargs 4)
+  (jmp-subprim .SPvalues))
+
+
+(defx86lapfunction %current-db-link ()
+  (movq (@ (% :rcontext) x8664::tcr.db-link) (% arg_z))
+  (single-value-return))
+
+(defx86lapfunction %no-thread-local-binding-marker ()
+  (movq ($ x8664::subtag-no-thread-local-binding) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction break-event-pending-p ()
+  (xorq (% imm0) (% imm0))
+  (ref-global x8664::intflag imm1)
+  (set-global imm0 x8664::intflag)
+  (testq (% imm1) (% imm1))
+  (setne (%b imm0))
+  (andl ($ x8664::t-offset) (%l imm0))
+  (lea (@ x8664::nil-value (% imm0)) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction debug-trap-with-string ((arg arg_z))
+  (check-nargs 1)
+  (uuo-error-debug-trap-with-string)
+  (single-value-return))
+
+(defx86lapfunction %safe-get-ptr ((src arg_y) (dest arg_z))
+  (check-nargs 2)
+  (save-simple-frame)
+  (macptr-ptr src imm0)
+  (leaq (@ (:^ done) (% fn)) (% ra0))
+  (movq (% imm0) (@ (% :rcontext) x8664::tcr.safe-ref-address))
+  (movq (@ (% imm0)) (% imm0))
+  (jmp done)
+  (:tra done)
+  (recover-fn-from-rip)
+  (movq ($ 0) (@ (% :rcontext) x8664::tcr.safe-ref-address))
+  (movq (% imm0) (@ x8664::macptr.address (% dest)))
+  (restore-simple-frame)
+  (single-value-return))
+
+;;; This was intentded to work around a bug in #_nanosleep in early
+;;; Leopard test releases.  It's probably not necessary any more; is
+;;; it still called ?
+
+
+;;; end of x86-misc.lisp
Index: /branches/ia32/level-0/X86/x86-numbers.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-numbers.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-numbers.lisp	(revision 8365)
@@ -0,0 +1,189 @@
+;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+
+
+(in-package "CCL")
+
+
+
+(defx86lapfunction %fixnum-signum ((number arg_z))
+  (movq ($ '-1) (% arg_x))
+  (movq ($ '1) (% arg_y))
+  (testq (% number) (% number))
+  (cmovsq (% arg_x) (% arg_z))
+  (cmovnsq (% arg_y) (% arg_z))
+  (single-value-return))
+
+;;; see %logcount.
+(defx86lapfunction %ilogcount ((number arg_z))
+  (let ((rshift imm0)
+        (temp imm1))
+    (unbox-fixnum number rshift)
+    (xorq (% arg_z) (% arg_z))
+    (testq (% rshift) (% rshift))
+    (jmp @test)
+    @next
+    (lea (@ -1 (% rshift)) (% temp))
+    (and (% temp) (% rshift))            ; sets flags
+    (lea (@ '1 (% arg_z)) (% arg_z))    ; doesn't set flags
+    @test
+    (jne @next)
+    (single-value-return)))
+
+(defx86lapfunction %iash ((number arg_y) (count arg_z))
+  (unbox-fixnum count imm1)
+  (unbox-fixnum number imm0)
+  (xorq (% rcx) (% rcx))                ;rcx = imm2
+  (testq (% count) (% count))
+  (jge @left)
+  (subb (% imm1.b) (% cl))
+  (sar (% cl) (% imm0))
+  (box-fixnum imm0 arg_z)
+  (single-value-return)
+  @left
+  (movb (% imm1.b) (% cl))
+  (shl (% cl) (% number))
+  (movq (% number) (% arg_z))
+  (single-value-return))
+
+(defparameter *double-float-zero* 0.0d0)
+(defparameter *short-float-zero* 0.0s0)
+
+
+(defx86lapfunction %fixnum-intlen ((number arg_z))
+  (unbox-fixnum arg_z imm0)
+  (movq (% imm0) (% imm1))
+  (notq (% imm1))
+  (testq (% imm0) (% imm0))
+  (cmovsq (% imm1) (% imm0))
+  (bsrq (% imm0) (% imm0))
+  (setne (% imm1.b))
+  (addb (% imm1.b) (% imm0.b))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+
+;;; Caller guarantees that result fits in a fixnum.
+
+(defx86lapfunction %truncate-double-float->fixnum ((arg arg_z))
+  (get-double-float arg fp1)
+  (cvttsd2si (% fp1) (% imm0))
+  (box-fixnum imm0 arg_z)  
+  (single-value-return))
+
+
+(defx86lapfunction %truncate-short-float->fixnum ((arg arg_z))
+  (get-single-float arg fp1)
+  (cvttss2si (% fp1) (% imm0))
+  (box-fixnum imm0 arg_z)  
+  (single-value-return))
+
+;;; DOES round to even
+
+(defx86lapfunction %round-nearest-double-float->fixnum ((arg arg_z))
+  (get-double-float arg fp1)
+  (cvtsd2si (% fp1) (% imm0))
+  (box-fixnum imm0 arg_z)  
+  (single-value-return))
+
+
+(defx86lapfunction %round-nearest-short-float->fixnum ((arg arg_z))
+  (get-single-float arg fp1)
+  (cvtss2si (% fp1) (% imm0))
+  (box-fixnum imm0 arg_z)  
+  (single-value-return))
+
+
+;;; We'll get a SIGFPE if divisor is 0.
+;;; Don't use %rbp.  Trust callback_for_interrupt() to preserve
+;;; the word below the stack pointer
+(defx86lapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
+  (unbox-fixnum divisor imm0)
+  (movq (% imm0) (@ -8 (% rsp)))
+  (unbox-fixnum dividend imm0)
+  (cqto)                                ; imm1 := sign_extend(imm0)
+  (idivq (@ -8 (% rsp)))
+  (movq (% rsp) (% temp0))
+  (box-fixnum imm1 arg_y)
+  (box-fixnum imm0 arg_z)
+  (pushq (% arg_z))
+  (pushq (% arg_y))
+  (set-nargs 2)
+  (jmp-subprim .SPvalues))
+
+(defx86lapfunction called-for-mv-p ()
+  (ref-global ret1valaddr imm0)
+  (movq (@ x8664::lisp-frame.return-address (% rbp)) (% imm1))
+  (cmpq (% imm0) (% imm1))
+  (movq ($ t) (% imm0))
+  (movq ($ nil) (% arg_z))
+  (cmoveq (% imm0) (% arg_z))
+  (single-value-return))
+
+
+;;; n1 and n2 must be positive (esp non zero)
+(defx86lapfunction %fixnum-gcd ((boxed-u arg_y) (boxed-v arg_z))
+  (let ((u imm0)
+        (v imm1)
+        (k imm2))
+    (xorl (% imm2.l) (% imm2.l))
+    (bsfq (% boxed-u) (% u))
+    (bsfq (% boxed-v) (% v))
+    (rcmp (% u) (% v))
+    (cmovlel (%l u) (%l k))
+    (cmovgl (%l v) (%l k))
+    (unbox-fixnum boxed-u u)
+    (unbox-fixnum boxed-v v)
+    (subb ($ x8664::fixnumshift) (%b k))
+    (jz @start)
+    (shrq (% cl) (% u))
+    (shrq (% cl) (% v))
+    @start
+    ;; At least one of u or v is odd at this point
+    @loop
+    ;; if u is even, shift it right one bit
+    (testb ($ 1) (%b u))
+    (jne @u-odd)
+    (shrq ($ 1) (% u))
+    (jmp @test)
+    @u-odd
+    ;; if v is even, shift it right one bit
+    (testb ($ 1) (%b v))
+    (jne @both-odd)
+    (shrq ($ 1) (% v))
+    (jmp @test-u)
+    @both-odd
+    (cmpq (% v) (% u))
+    (jb @v>u)
+    (subq (% v) (% u))
+    (shrq ($ 1) (% u))
+    (jmp @test)
+    @v>u
+    (subq (% u) (% v))
+    (shrq ($ 1) (% v))
+    @test-u
+    (testq (% u) (% u))
+    @test
+    (ja @loop)
+    (shlq (% cl) (% v))
+    (movb ($ 0) (% cl))
+    (box-fixnum v arg_z)
+    (single-value-return)))
+
+
+
+;;; End of x86-numbers.lisp
Index: /branches/ia32/level-0/X86/x86-pred.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-pred.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-pred.lisp	(revision 8365)
@@ -0,0 +1,187 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  (require "X86-LAPMACROS"))
+
+
+(defx86lapfunction eql ((x arg_y) (y arg_z))
+  "Return T if OBJ1 and OBJ2 represent either the same object or
+numbers with the same type and value."
+  (check-nargs 2)
+  @top
+  @tail
+  (cmpq (% x) (% y))
+  (je @win)
+  (extract-fulltag x imm0)
+  (extract-fulltag y imm1)
+  (cmpb (% imm0.b) (% imm1.b))
+  (jnz @lose)
+  (cmpb ($ x8664::fulltag-misc) (% imm0.b))
+  (jnz @lose)
+  (getvheader x imm0)
+  (getvheader y imm1)
+  (cmpb ($ x8664::subtag-macptr) (% imm0.b))
+  (je @macptr)                          ; will need to check %imm1.b
+  (cmpq (% imm0) (% imm1))
+  (jne @lose)
+  (cmpb ($ x8664::subtag-bignum) (% imm0.b))
+  (je @bignum)
+  (cmpb ($ x8664::subtag-double-float) (% imm0.b))
+  (je @double-float)
+  (cmpb ($ x8664::subtag-complex) (% imm0.b))
+  (je @complex)
+  (cmpb ($ x8664::subtag-ratio) (% imm0.b))
+  (je @ratio)
+  @lose
+  (movq ($ nil) (% arg_z))
+  (single-value-return)
+  @macptr
+  (cmpb ($ x8664::subtag-macptr) (% imm1.b))
+  (jne @lose)
+  @double-float
+  (movq  (@ x8664::misc-data-offset (% x)) (% imm0))
+  (movq  (@ x8664::misc-data-offset (% y)) (% imm1))
+  @test
+  (cmpq (% imm0) (% imm1))
+  (movl ($ x8664::t-value) (%l imm0))
+  (lea (@ (- x8664::t-offset) (% imm0)) (% arg_z))
+  (cmovel (%l imm0) (%l arg_z))
+  (single-value-return)
+  @win
+  (movq ($ t) (% arg_z))
+  (single-value-return)
+  @ratio
+  @complex
+  (save-simple-frame)
+  (pushq (@ x8664::ratio.denom (% x)))  ; aka complex.imagpart
+  (pushq (@ x8664::ratio.denom (% y)))
+  (movq (@ x8664::ratio.numer (% x)) (% x))       ; aka complex.realpart
+  (movq (@ x8664::ratio.numer (% y)) (% y))       ; aka complex.realpart
+  (:talign 3)
+  (call @top)
+  (recover-fn-from-rip)
+  (cmp-reg-to-nil arg_z)
+  (pop (% y))
+  (pop (% x))
+  (restore-simple-frame)
+  (jnz @tail)
+  ;; lose, again
+  (movq ($ nil) (% arg_z))
+  (single-value-return)
+  @bignum
+  ;; Way back when, we got x's header into imm0.  We know that y's
+  ;; header is identical.  Use the element-count from imm0 to control
+  ;; the loop.  There's no such thing as a 0-element bignum, so the
+  ;; loop must always execute at least once.
+  (header-length imm0 temp0)
+  (xorq (% imm1) (% imm1))
+  @bignum-next
+  (movl (@ x8664::misc-data-offset (% x) (% imm1)) (% imm0.l))
+  (cmpl (@ x8664::misc-data-offset (% y) (% imm1)) (% imm0.l))
+  (jne @lose)
+  (addq ($ 4) (% imm1))
+  (sub ($ '1) (% temp0))
+  (jnz @bignum-next)
+  (movq ($ t) (% arg_z))
+  (single-value-return))
+  
+
+
+(defx86lapfunction equal ((x arg_y) (y arg_z))
+  "Return T if X and Y are EQL or if they are structured components
+  whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
+  are the same length and have identical components. Other arrays must be
+  EQ to be EQUAL.  Pathnames are EQUAL if their components are."
+  (check-nargs 2)
+  @top
+  @tail
+  (cmpq (% x) (% y))
+  (je @win)
+  (extract-fulltag x imm0)
+  (extract-fulltag y imm1)
+  (cmpb (% imm0.b) (% imm1.b))
+  (jne @lose)
+  (cmpb ($ x8664::fulltag-cons) (% imm0.b))
+  (je @cons)
+  (cmpb ($ x8664::fulltag-misc) (% imm0.b))
+  (je @misc)
+  @lose
+  (movq ($ nil) (% arg_z))
+  (single-value-return)
+  @win
+  (movq ($ t) (% arg_z))
+  (single-value-return)
+  @cons
+  ;; Check to see if the CARs are EQ.  If so, we can avoid saving
+  ;; context, and can just tail call ourselves on the CDRs.
+  (%car x temp0)
+  (%car y temp1)
+  (cmpq (% temp0) (% temp1))
+  (jne @recurse)
+  (%cdr x x)
+  (%cdr y y)
+  (jmp @tail)
+  @recurse
+  (save-simple-frame)
+  (pushq (@ x8664::cons.cdr (% x)))
+  (pushq (@ x8664::cons.cdr (% y)))
+  (movq (% temp0) (% x))
+  (movq (% temp1) (% y))
+  (:talign 4)
+  (call @top)
+  (recover-fn-from-rip)
+  (cmp-reg-to-nil arg_z)
+  (pop (% y))
+  (pop (% x))
+  (restore-simple-frame)         
+  (jnz @top)
+  (movl ($ nil) (% arg_z.l))
+  (single-value-return)
+  @misc
+  ;; Both objects are uvectors of some sort.  Try EQL; if that fails,
+  ;; call HAIRY-EQUAL.
+  (save-simple-frame)
+  (pushq (% x))
+  (pushq (% y))
+  (call-symbol eql 2)
+  (cmp-reg-to-nil arg_z)
+  (jne @won-with-eql)
+  (popq (% y))
+  (popq (% x))
+  (restore-simple-frame)
+  (jump-symbol hairy-equal 2)
+  @won-with-eql
+  (restore-simple-frame)                ; discards pushed args
+  (movl ($ t) (% arg_z.l))
+  (single-value-return))
+
+(defx86lapfunction %lisp-lowbyte-ref ((thing arg_z))
+  (box-fixnum thing arg_z)
+  (andl ($ '#xff) (%l arg_z))
+  (single-value-return))
+
+
+      
+
+
+
+
+
+
+
Index: /branches/ia32/level-0/X86/x86-symbol.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-symbol.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-symbol.lisp	(revision 8365)
@@ -0,0 +1,143 @@
+;;;-*- Mode: Lisp; Package: CCL -*-
+;;;
+;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+(in-package "CCL")
+
+(eval-when (:compile-toplevel :execute)
+  (require "X8664-ARCH")
+  (require "X86-LAPMACROS"))
+
+;;; This assumes that macros & special-operators
+;;; have something that's not FUNCTIONP in their
+;;; function-cells.  It also assumes that NIL
+;;; isn't a true symbol, but that NILSYM is.
+(defx86lapfunction %function ((sym arg_z))
+  (check-nargs 1)
+  (let ((symaddr temp0))
+    (movq ($ (+ x8664::nil-value x8664::nilsym-offset)) (% symaddr))
+    (cmp-reg-to-nil sym)
+    (cmovneq (% sym) (% symaddr))
+    (trap-unless-fulltag= symaddr x8664::fulltag-symbol)
+    (movq (% sym) (% arg_y))
+    (movq (@ x8664::symbol.fcell (% symaddr)) (% arg_z))
+    (extract-fulltag arg_z imm0)
+    (cmpb ($ x8664::fulltag-function) (%b imm0))
+    (je.pt @ok)
+    (uuo-error-udf (% arg_y))
+    @ok
+    (single-value-return)))
+
+;;; Traps unless sym is NIL or some other symbol.  If NIL, return
+;;; nilsym
+(defx86lapfunction %symbol->symptr ((sym arg_z))
+  (let ((tag imm0 ))
+    (movq ($ (+ x8664::nil-value x8664::nilsym-offset)) (% tag))
+    (cmp-reg-to-nil sym)
+    (cmoveq (% sym) (% tag))
+    (je :done)
+    (trap-unless-fulltag= sym x8664::fulltag-symbol)
+    :done
+    (single-value-return)))
+
+;;; If symptr is NILSYM, return NIL; else typecheck and return symptr
+(defx86lapfunction %symptr->symbol ((symptr arg_z))
+  (movw ($ (ash 1 x8664::fulltag-symbol)) (% imm0.w))
+  (btw (%w symptr) (% imm0.w))
+  (jb.pt @ok)
+  (uuo-error-reg-not-tag (% symptr) ($ x8664::fulltag-symbol))
+  @ok
+  (cmpq ($ (+ x8664::nil-value x8664::nilsym-offset)) (% symptr))
+  (sete (% imm0.b))
+  (negb (% imm0.b))
+  (andl ($ x8664::nilsym-offset) (% imm0.l))
+  (subq (% imm0) (% symptr))
+  (single-value-return))
+
+
+;;; Given something whose fulltag is FULLTAG-SYMBOL, return the
+;;; underlying uvector.  This function and its inverse would
+;;; be good candidates for inlining.
+(defx86lapfunction %symptr->symvector ((symptr arg_z))
+  (subb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b))
+  (single-value-return))
+
+(defx86lapfunction %symvector->symptr ((symbol-vector arg_z))
+  (addb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b))
+  (single-value-return))
+    
+(defx86lapfunction %symptr-value ((symptr arg_z))
+  (jmp-subprim .SPspecref))
+
+(defx86lapfunction %set-symptr-value ((symptr arg_y) (val arg_z))
+  (jmp-subprim .SPspecset))
+
+;;; This gets a tagged symbol as an argument.
+;;; If there's no thread-local binding, it should return
+;;; the underlying symbol vector as a first return value.
+(defx86lapfunction %symptr-binding-address ((symptr arg_z))
+  (movq (@ x8664::symbol.binding-index (% symptr)) (% arg_y))
+  (rcmp (% arg_y) (@ (% :rcontext) x8664::tcr.tlb-limit))
+  (movq (@ (% :rcontext) x8664::tcr.tlb-pointer) (% arg_x))
+  (jae @sym)
+  (cmpb ($ x8664::no-thread-local-binding-marker) (@ (% arg_x) (% arg_y)))
+  (je @sym)
+  (shl ($ x8664::word-shift) (% arg_y))
+  (push (% arg_x))
+  (push (% arg_y))
+  (set-nargs 2)
+  (lea (@ '2 (% rsp)) (% temp0))
+  (jmp-subprim .SPvalues)
+  @sym
+  (subb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b))
+  (push (% arg_z))
+  (pushq ($ '#.x8664::symptr.vcell))
+  (set-nargs 2)
+  (lea (@ '2 (% rsp)) (% temp0))
+  (jmp-subprim .SPvalues))
+
+(defx86lapfunction %tcr-binding-location ((tcr arg_y) (sym arg_z))
+  (movq (@ x8664::symbol.binding-index (% sym)) (% arg_x))
+  (movl ($ nil) (% arg_z.l))
+  (rcmp (% arg_x) (@ x8664::tcr.tlb-limit (% tcr)))
+  (movq (@ x8664::tcr.tlb-pointer (% tcr)) (% arg_y))
+  (jae @done)
+  (lea (@ (% arg_y) (% arg_x)) (% arg_y))
+  ;; We're little-endian, so the tag is at the EA with no
+  ;; displacement
+  (cmpb ($ x8664::subtag-no-thread-local-binding) (@ (% arg_y)))
+  (cmovneq (% arg_y) (% arg_z))
+  @done
+  (single-value-return))
+
+  
+(defx86lapfunction %pname-hash ((str arg_y) (len arg_z))
+  (let ((accum imm0)
+        (offset imm1))
+    (xorq (% offset) (% offset))
+    (xorq (% accum) (% accum))
+    (cmpq ($ 0) (% len))
+    (jz.pn @done)
+    @loop8
+    (roll ($ 5) (%l accum))
+    (xorl (@ x8664::misc-data-offset (% str) (% offset) 4) (%l accum))
+    (addq ($ 1) (% offset))    
+    (subq ($ '1) (% len))
+    (jnz @loop8)
+    (shlq ($ 5) (% accum))
+    (shrq ($ (- 5 x8664::fixnumshift)) (% accum))
+    (movq (% accum) (% arg_z))
+    @done
+    (single-value-return)))
Index: /branches/ia32/level-0/X86/x86-utils.lisp
===================================================================
--- /branches/ia32/level-0/X86/x86-utils.lisp	(revision 8365)
+++ /branches/ia32/level-0/X86/x86-utils.lisp	(revision 8365)
@@ -0,0 +1,512 @@
+; -*- Mode: Lisp; Package: CCL; -*-
+;;;
+;;;   Copyright (C) 1994-2001 Digitool, Inc
+;;;   This file is part of OpenMCL.  
+;;;
+;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
+;;;   License , known as the LLGPL and distributed with OpenMCL as the
+;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
+;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
+;;;   conflict, the preamble takes precedence.  
+;;;
+;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
+;;;
+;;;   The LLGPL is also available online at
+;;;   http://opensource.franz.com/preamble.html
+
+
+(in-package "CCL")
+
+(defx86lapfunction %address-of ((arg arg_z))
+  ;; %address-of a fixnum is a fixnum, just for spite.
+  ;; %address-of anything else is the address of that thing as an integer.
+  (testb ($ x8664::fixnummask) (%b arg))
+  (je @done)
+  (movq (% arg) (% imm0))
+  (jmp-subprim .SPmakeu64)
+  @done
+  (single-value-return))
+
+;;; "areas" are fixnum-tagged and, for the most part, so are their
+;;; contents.
+
+;;; The nilreg-relative global all-areas is a doubly-linked-list header
+;;; that describes nothing.  Its successor describes the current/active
+;;; dynamic heap.  Return a fixnum which "points to" that area, after
+;;; ensuring that the "active" pointers associated with the current thread's
+;;; stacks are correct.
+
+
+
+(defx86lapfunction %normalize-areas ()
+  (let ((address temp0)
+        (temp temp1))
+
+    ; update active pointer for tsp area.
+    (movq (@ (% :rcontext) x8664::tcr.ts-area) (% address))
+    (movq (@ (% :rcontext) x8664::tcr.save-tsp) (% temp))
+    (movq (% temp) (@ x8664::area.active (% address)))
+    
+    ;; Update active pointer for vsp area.
+    (movq (@ (% :rcontext) x8664::tcr.vs-area) (% address))
+    (movq (% rsp) (@ x8664::area.active (% address)))
+
+    (ref-global all-areas arg_z)
+    (movq (@ x8664::area.succ (% arg_z)) (% arg_z))
+
+    (single-value-return)))
+
+(defx86lapfunction %active-dynamic-area ()
+  (ref-global all-areas arg_z)
+  (movq (@ x8664::area.succ (% arg_z)) (% arg_z))
+  (single-value-return))
+
+  
+(defx86lapfunction %object-in-stack-area-p ((object arg_y) (area arg_z))
+  (movq (@ x8664::area.active (% area)) (% imm0))
+  (movq (@ x8664::area.high (% area)) (% imm1))
+  (rcmp (% object) (% imm0))
+  (movq ($ nil) (% arg_z))
+  (movq ($ t) (% imm0))
+  (jb @done)
+  (rcmp (% object) (% imm1))
+  (cmovbq (% imm0) (% arg_z))
+  @done
+  (single-value-return))
+
+(defx86lapfunction %object-in-heap-area-p ((object arg_y) (area arg_z))
+  (rcmp (% object) (@ x8664::area.low (% area)))
+  (setae (%b imm0))
+  (rcmp (% object) (@ x8664::area.low (% area)))
+  (setb (%b imm1))
+  (andb (% imm1.b) (% imm0.b))
+  (andl ($ x8664::t-offset) (%l imm0))
+  (lea (@ x8664::nil-value (% imm0)) (% arg_z))
+  (single-value-return))
+
+
+
+
+(defx86lapfunction walk-static-area ((a arg_y) (f arg_z))
+  (let ((fun save0)
+        (obj save1)
+        (limit save2)
+        (prev save3))
+    (save-simple-frame)
+    (push (% fun))
+    (push (% obj))
+    (push (% limit))
+    (push (% prev))
+    (xorl (%l prev) (%l prev))
+    (movq (% f) (% fun))
+    (movq (@ x8664::area.active (% a)) (% limit))
+    (movq (@ x8664::area.low (% a)) (% obj))
+    (jmp @test)
+    @loop
+    (movb (@ (% obj)) (% imm0.b))
+    (andb ($ x8664::fulltagmask) (% imm0.b))
+    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b))
+    (jne @cons)
+    @misc
+    (lea (@ x8664::fulltag-misc (% obj)) (% obj))
+    (movq (% obj) (% prev))
+    (movq (% obj) (% arg_z))
+    (set-nargs 1)
+    (:talign 4)
+    (call (% fun))
+    (recover-fn-from-rip)
+    (getvheader obj imm1)
+    (movb (% imm1.b) (% imm0.b))
+    (andb ($ x8664::fulltagmask) (% imm0.b))
+    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
+    (je @64)
+    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
+    (je @64)
+    (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b))
+    (jne @not64)
+    @64
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (shlq ($ x8664::word-shift) (% imm1))
+    (jmp @uvector-next)
+    @not64
+    (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b))
+    (jne @not32)
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (shlq ($ 2) (% imm1))
+    (jmp @uvector-next)
+    @not32
+    (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b))
+    (jne @not-bit)
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (addq ($ 7) (% imm1))
+    (shrq ($ 3) (% imm1))
+    (jmp @uvector-next)
+    @not-bit
+    (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256)))
+    (jb @16)
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (jmp @uvector-next)
+    @16
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (shlq ($ 1) (% imm1))
+    (jmp @uvector-next)
+    @cons
+    (addq ($ x8664::fulltag-cons) (% obj))
+    (movq (% obj) (% prev))
+    (movq (% obj) (% arg_z))
+    (set-nargs 1)
+    (:talign 4)
+    (call (% fun))
+    (recover-fn-from-rip)
+    (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj))
+    (jmp @test)
+    ;; size of OBJ in bytes (without header or alignment padding)
+    ;; in imm1.
+    @uvector-next
+    (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1))
+    (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b))
+    (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj))
+    @test
+    (cmpq (% limit) (% obj))
+    (jb @loop)
+    (pop (% prev))
+    (pop (% limit))
+    (pop (% obj))
+    (pop (% fun))
+    (movl ($ x8664::nil-value) (% arg_z.l))
+    (restore-simple-frame)
+    (single-value-return)))
+
+
+
+;;; This walks the active "dynamic" area.  Objects might be moving around
+;;; while we're doing this, so we have to be a lot more careful than we 
+;;; are when walking a static area.
+;;; There are a couple of approaches to termination:
+;;;  a) Allocate a "sentinel" cons, and terminate when we run into it.
+;;;  b) Check the area limit (which is changing if we're consing) and
+;;;     terminate when we hit it.
+;;; (b) loses if the function conses.  (a) conses.  I can't think of anything
+;;; better than (a).
+;;; This, of course, assumes that any GC we're doing does in-place compaction
+;;; (or at least preserves the relative order of objects in the heap.)
+
+(defx86lapfunction %walk-dynamic-area ((a arg_y) (f arg_z))
+  (let ((fun save0)
+        (obj save1)
+        (limit save2)
+        (prev save3))
+    (save-simple-frame)
+    (push (% fun))
+    (push (% obj))
+    (push (% limit))
+    (push (% prev))
+    (movq (% f) (% fun))
+    (xorl (%l prev) (%l prev))
+    (ref-global tenured-area a)
+    (movq (@ x8664::area.low (% a)) (% obj))
+    (subq ($ (- x8664::cons.size x8664::fulltag-cons))
+          (@ (% :rcontext) x8664::tcr.save-allocptr))
+    (movq (@ (% :rcontext) x8664::tcr.save-allocptr) (% allocptr))
+    (cmpq (@ (% :rcontext) x8664::tcr.save-allocbase) (% allocptr))
+    (jg @ok)
+    (uuo-alloc)
+    @ok
+    (andb ($ (lognot x8664::fulltagmask))
+          (@ (% :rcontext) x8664::tcr.save-allocptr))
+    (movq (% allocptr) (% limit))
+    (jmp @test)
+    @loop
+    (movb (@ (% obj)) (% imm0.b))
+    (andb ($ x8664::fulltagmask) (% imm0.b))
+    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b))
+    (je @misc)
+    (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b))
+    (jne @cons)
+    @misc
+    (lea (@ x8664::fulltag-misc (% obj)) (% obj))
+    (movq (% obj) (% arg_z))
+    (movq (% obj) (% prev))
+    (set-nargs 1)
+    (:talign 4)
+    (call (% fun))
+    (recover-fn-from-rip)
+    (getvheader obj imm1)
+    (movb (% imm1.b) (% imm0.b))
+    (andb ($ x8664::fulltagmask) (% imm0.b))
+    (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b))
+    (je @64)
+    (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b))
+    (je @64)
+    (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b))
+    (jne @not64)
+    @64
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (shlq ($ x8664::word-shift) (% imm1))
+    (jmp @uvector-next)
+    @not64
+    (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b))
+    (jne @not32)
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (shlq ($ 2) (% imm1))
+    (jmp @uvector-next)
+    @not32
+    (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b))
+    (jne @not-bit)
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (addq ($ 7) (% imm1))
+    (shrq ($ 3) (% imm1))
+    (jmp @uvector-next)
+    @not-bit
+    (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256)))
+    (jb @16)
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (jmp @uvector-next)
+    @16
+    (shrq ($ x8664::num-subtag-bits) (% imm1))
+    (shlq ($ 1) (% imm1))
+    (jmp @uvector-next)
+    @cons
+    (addq ($ x8664::fulltag-cons) (% obj))
+    (cmpq (% obj) (% limit))
+    (movq (% obj) (% arg_z))
+    (je @done)
+    (movq (% obj) (% prev))
+    (set-nargs 1)
+    (:talign 4)
+    (call (% fun))
+    (recover-fn-from-rip)
+    (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj))
+    (jmp @test)
+    ;; size of OBJ in bytes (without header or alignment padding)
+    ;; in imm1.
+    @uvector-next
+    (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1))
+    (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b))
+    (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj))
+    @test
+    (cmpq (% limit) (% obj))
+    (jb @loop)
+    @done
+    (pop (% prev))
+    (pop (% limit))
+    (pop (% obj))
+    (pop (% fun))
+    (movl ($ x8664::nil-value) (% arg_z.l))
+    (restore-simple-frame)
+    (single-value-return)))
+
+(defun walk-dynamic-area (area func)
+  (with-other-threads-suspended
+      (%walk-dynamic-area area func)))
+
+
+
+(defx86lapfunction %class-of-instance ((i arg_z))
+  (svref i instance.class-wrapper arg_z)
+  (svref arg_z %wrapper-class arg_z)
+  (single-value-return))
+
+(defx86lapfunction class-of ((x arg_z))
+  (check-nargs 1)
+  (movw ($ (logior (ash 1 x8664::tag-list)
+                   (ash 1 x8664::tag-imm-1)))
+        (%w imm1))
+  (extract-lisptag x imm0)
+  (btw (% imm0.w) (% imm1.w))
+  (cmovbl (% arg_z.l) (% imm0.l))
+  (movq (@ '*class-table* (% fn)) (% temp1))
+  (cmpb ($ x8664::tag-misc) (% imm0.b))
+  (jne @have-tag)
+  (extract-subtag x imm0)
+  @have-tag
+  (movq (@ x8664::symbol.vcell (% temp1)) (% temp1))
+  (movzbl (% imm0.b) (% imm0.l))
+  (movq (@ x8664::misc-data-offset (% temp1) (% imm0) 8) (% temp0))
+  (cmpb ($ x8664::fulltag-nil) (%b temp0))
+  (je @bad)
+  (extract-fulltag temp0 imm0)
+  (cmpb ($ x8664::fulltag-function) (%b imm0))
+  (jne @ret)
+  (set-nargs 1)
+  (jmp (% temp0))
+  @bad
+  (load-constant no-class-error fname)
+  (set-nargs 1)
+  (jmp  (@ x8664::symbol.fcell (% fname)))
+  @ret
+  (movq (% temp0) (% arg_z))  ; return frob from table
+  (single-value-return))
+
+(defx86lapfunction full-gccount ()
+  (ref-global tenured-area arg_z)
+  (testq (% arg_z) (% arg_z))
+  (cmoveq (@ (+ x8664::nil-value (x8664::%kernel-global 'gc-count))) (% arg_z))
+  (cmovneq (@ x8664::area.gc-count (% arg_z)) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction gc ()
+  (check-nargs 0)
+  (movq ($ arch::gc-trap-function-gc) (% imm0))
+  (uuo-gc-trap)
+  (movq ($ nil) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction egc ((arg arg_z))
+  "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return
+the previous enabled status. Although this function is thread-safe (in
+the sense that calls to it are serialized), it doesn't make a whole lot
+of sense to be turning the EGC on and off from multiple threads ..."
+  (check-nargs 1)
+  (clrq imm1)
+  (cmp-reg-to-nil arg)
+  (setne (% imm1.b))
+  (movq ($ arch::gc-trap-function-egc-control) (% imm0))
+  (uuo-gc-trap)
+  (single-value-return))
+
+
+
+
+(defx86lapfunction %configure-egc ((e0size arg_x)
+				   (e1size arg_y)
+				   (e2size arg_z))
+  (check-nargs 3)
+  (movq ($ arch::gc-trap-function-configure-egc) (% imm0))
+  (uuo-gc-trap)
+  (single-value-return))
+
+(defx86lapfunction purify ()
+  (check-nargs 0)
+  (movq ($ arch::gc-trap-function-purify) (% imm0))
+  (uuo-gc-trap)
+  (movq ($ nil) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction impurify ()
+  (check-nargs 0)
+  (movq ($ arch::gc-trap-function-impurify) (% imm0))
+  (uuo-gc-trap)
+  (movq ($ nil) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction lisp-heap-gc-threshold ()
+  "Return the value of the kernel variable that specifies the amount
+of free space to leave in the heap after full GC."
+  (check-nargs 0)
+  (movq ($ arch::gc-trap-function-get-lisp-heap-threshold) (% imm0))
+  (uuo-gc-trap)
+  #+x8632-target
+  (jmp-subprim .SPmakeu32)
+  #+x8664-target
+  (jmp-subprim .SPmakeu64))
+
+(defx86lapfunction set-lisp-heap-gc-threshold ((new arg_z))
+  "Set the value of the kernel variable that specifies the amount of free
+space to leave in the heap after full GC to new-value, which should be a
+non-negative fixnum. Returns the value of that kernel variable (which may
+be somewhat larger than what was specified)."
+  (check-nargs 1)
+  (save-simple-frame)
+  (call-subprim .SPgetu64)
+  (movq (% imm0) (% imm1))
+  (movq ($ arch::gc-trap-function-set-lisp-heap-threshold) (% imm0))
+  (uuo-gc-trap)
+  (restore-simple-frame)
+  (jmp-subprim .SPmakeu64))
+
+
+(defx86lapfunction use-lisp-heap-gc-threshold ()
+  "Try to grow or shrink lisp's heap space, so that the free space is (approximately) equal to the current heap threshold. Return NIL"
+  (check-nargs 0) 
+  (movq ($ arch::gc-trap-function-use-lisp-heap-threshold) (% imm0))
+  (uuo-gc-trap)
+  (movl ($ x8664::nil-value) (%l arg_z))
+  (single-value-return))
+
+
+
+;;; offset is a fixnum, one of the x8664::kernel-import-xxx constants.
+;;; Returns that kernel import, a fixnum.
+(defx86lapfunction %kernel-import ((offset arg_z))
+  (ref-global kernel-imports imm0)
+  (unbox-fixnum arg_z imm1)
+  (movq (@ (% imm0) (% imm1)) (% imm0))
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %get-unboxed-ptr ((macptr arg_z))
+  (macptr-ptr arg_z imm0)
+  (movq (@ (% imm0)) (% arg_z))
+  (single-value-return))
+
+
+(defx86lapfunction %revive-macptr ((p arg_z))
+  (movb ($ x8664::subtag-macptr) (@ x8664::misc-subtag-offset (% p)))
+  (single-value-return))
+
+(defx86lapfunction %macptr-type ((p arg_z))
+  (check-nargs 1)
+  (trap-unless-typecode= p x8664::subtag-macptr)
+  (svref p x8664::macptr.type-cell imm0)
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+  
+(defx86lapfunction %macptr-domain ((p arg_z))
+  (check-nargs 1)
+  (trap-unless-typecode= p x8664::subtag-macptr)
+  (svref p x8664::macptr.domain-cell imm0)
+  (box-fixnum imm0 arg_z)
+  (single-value-return))
+
+(defx86lapfunction %set-macptr-type ((p arg_y) (new arg_z))
+  (check-nargs 2)
+  (unbox-fixnum new imm1)
+  (trap-unless-typecode= p x8664::subtag-macptr)
+  (svset p x8664::macptr.type-cell imm1)
+  (single-value-return))
+
+(defx86lapfunction %set-macptr-domain ((p arg_y) (new arg_z))
+  (check-nargs 2)
+  (unbox-fixnum new imm1)
+  (trap-unless-typecode= p x8664::subtag-macptr)
+  (svset p x8664::macptr.domain-cell imm1)
+  (single-value-return))
+
+(defx86lapfunction true ()
+  (movzwl (% nargs) (%l nargs))
+  (subq ($ '3) (% nargs.q))
+  (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0))
+  (cmovaq (% imm0) (% rsp))
+  (movl ($ x8664::t-value) (%l arg_z))
+  (single-value-return))
+
+(defx86lapfunction false ()
+  (movzwl (% nargs) (%l nargs))
+  (subq ($ '3) (% nargs.q))
+  (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0))
+  (cmovaq (% imm0) (% rsp))
+  (movl ($ x8664::nil) (%l arg_z))
+  (single-value-return))
+
+
+
+;;; end