X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fassembly%2Fx86%2Falloc.lisp;h=b30039671438b4b0b70181a3ddea7c7827fcbcb6;hb=2dece4b7232e2248fb8ae64bb47b82232a64e5c8;hp=e0558e79b889e84f698f439c70f50fab01695c58;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/assembly/x86/alloc.lisp b/src/assembly/x86/alloc.lisp
index e0558e7..b300396 100644
--- a/src/assembly/x86/alloc.lisp
+++ b/src/assembly/x86/alloc.lisp
@@ -28,8 +28,8 @@
   (inst ret)
   BIGNUM
 
-  (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
-    (storew eax ebx bignum-digits-offset other-pointer-type))
+  (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1))
+    (storew eax ebx bignum-digits-offset other-pointer-lowtag))
 
   (inst ret))
 
@@ -57,11 +57,31 @@
   (inst mov ebx eax)
 
   ;; Two word bignum
-  (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 2))
-    (storew eax ebx bignum-digits-offset other-pointer-type))
+  (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 2))
+    (storew eax ebx bignum-digits-offset other-pointer-lowtag))
   (inst ret)
 
   ONE-WORD-BIGNUM
-  (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
-    (storew eax ebx bignum-digits-offset other-pointer-type))
+  (with-fixed-allocation (ebx bignum-widetag (+ bignum-digits-offset 1))
+    (storew eax ebx bignum-digits-offset other-pointer-lowtag))
   (inst ret))
+
+#+sb-assembling
+(defun frob-allocation-assembly-routine (obj lowtag arg-tn)
+  `(define-assembly-routine (,(intern (format nil "ALLOCATE-~A-TO-~A" obj arg-tn)))
+     ((:temp ,arg-tn descriptor-reg ,(intern (format nil "~A-OFFSET" arg-tn))))
+     (pseudo-atomic
+      (allocation ,arg-tn (pad-data-block ,(intern (format nil "~A-SIZE" obj))))
+      (inst lea ,arg-tn (make-ea :byte :base ,arg-tn :disp ,lowtag)))
+     (inst ret)))
+
+#+sb-assembling
+(macrolet ((frob-cons-routines ()
+             (let ((routines nil))
+               (dolist (tn-offset *dword-regs*
+                        `(progn ,@routines))
+                 (push (frob-allocation-assembly-routine 'cons
+                                                         list-pointer-lowtag
+                                                         (intern (aref *dword-register-names* tn-offset)))
+                       routines)))))
+  (frob-cons-routines))