X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fmacros.lisp;h=29601b552b5a3cd4157f6dd42c6149a41ba38319;hb=69d60b456b07a0256f08df0d02484f361ce5737c;hp=933b11c6d36f160a32a73fea6d7a837a7b8efbb8;hpb=78fa16bf55be44cc16845be84d98023e83fb14bc;p=sbcl.git

diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index 933b11c..29601b5 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -11,31 +11,6 @@
 
 (in-package "SB!VM")
 
-;;; We can load/store into fp registers through the top of stack
-;;; %st(0) (fr0 here). Loads imply a push to an empty register which
-;;; then changes all the reg numbers. These macros help manage that.
-
-;;; Use this when we don't have to load anything. It preserves old tos
-;;; value, but probably destroys tn with operation.
-(defmacro with-tn@fp-top((tn) &body body)
-  `(progn
-    (unless (zerop (tn-offset ,tn))
-      (inst fxch ,tn))
-    ,@body
-    (unless (zerop (tn-offset ,tn))
-      (inst fxch ,tn))))
-
-;;; Use this to prepare for load of new value from memory. This
-;;; changes the register numbering so the next instruction had better
-;;; be a FP load from memory; a register load from another register
-;;; will probably be loading the wrong register!
-(defmacro with-empty-tn@fp-top((tn) &body body)
-  `(progn
-    (inst fstp ,tn)
-    ,@body
-    (unless (zerop (tn-offset ,tn))
-      (inst fxch ,tn))))		; save into new dest and restore st(0)
-
 ;;;; instruction-like macros
 
 (defmacro move (dst src)
@@ -57,8 +32,7 @@
 (defmacro storew (value ptr &optional (slot 0) (lowtag 0))
   (once-only ((value value))
     `(cond ((and (integerp ,value) 
-		 (not (typep ,value 
-			     '(or (signed-byte 32) (unsigned-byte 32)))))
+		 (not (typep ,value '(signed-byte 32))))
 	    (multiple-value-bind (lo hi) (dwords-for-quad ,value)
 	      (inst mov (make-ea-for-object-slot-half
 			 ,ptr ,slot ,lowtag) lo)
@@ -150,6 +124,14 @@
 ;;; node-var then it is used to make an appropriate speed vs size
 ;;; decision.
 
+(defun allocation-dynamic-extent (alloc-tn size)
+  (inst sub rsp-tn size)
+  ;; see comment in x86/macros.lisp implementation of this
+  (inst and rsp-tn #.(lognot lowtag-mask))
+  (aver (not (location= alloc-tn rsp-tn)))
+  (inst mov alloc-tn rsp-tn)
+  (values))
+
 ;;; This macro should only be used inside a pseudo-atomic section,
 ;;; which should also cover subsequent initialization of the
 ;;; object.
@@ -157,29 +139,29 @@
   (declare (ignore ignored))
   (inst push size)
   (inst lea r13-tn (make-ea :qword
-			    :disp (make-fixup (extern-alien-name "alloc_tramp")
-					      :foreign)))
+			    :disp (make-fixup "alloc_tramp" :foreign)))
   (inst call r13-tn)
   (inst pop alloc-tn)
   (values))
 
-(defun allocation (alloc-tn size &optional ignored)
+(defun allocation (alloc-tn size &optional ignored dynamic-extent)
   (declare (ignore ignored))
-  (let ((not-inline (gen-label))
-	(done (gen-label))
+  (when dynamic-extent
+    (allocation-dynamic-extent alloc-tn size)
+    (return-from allocation (values)))
+  (let ((NOT-INLINE (gen-label))
+	(DONE (gen-label))
 	;; Yuck.
 	(in-elsewhere (eq *elsewhere* sb!assem::**current-segment**))
 	(free-pointer
 	 (make-ea :qword :disp 
 		  #!+sb-thread (* n-word-bytes thread-alloc-region-slot)
-		  #!-sb-thread (make-fixup (extern-alien-name "boxed_region")
-					   :foreign)
+		  #!-sb-thread (make-fixup "boxed_region" :foreign)
 		  :scale 1))		; thread->alloc_region.free_pointer
 	(end-addr 
 	 (make-ea :qword :disp
 		  #!+sb-thread (* n-word-bytes (1+ thread-alloc-region-slot))
-		  #!-sb-thread (make-fixup (extern-alien-name "boxed_region")
-					   :foreign 8)
+		  #!-sb-thread (make-fixup "boxed_region" :foreign 8)
 		  :scale 1)))		; thread->alloc_region.end_addr
     (cond (in-elsewhere
 	   (allocation-tramp alloc-tn size))
@@ -209,8 +191,7 @@
   (declare (ignore ignored))
   (inst push size)
   (inst lea r13-tn (make-ea :qword
-			    :disp (make-fixup (extern-alien-name "alloc_tramp")
-					      :foreign)))
+			    :disp (make-fixup "alloc_tramp" :foreign)))
   (inst call r13-tn)
   (inst pop alloc-tn)
   (values))
@@ -219,14 +200,17 @@
 ;;; header having the specified WIDETAG value. The result is placed in
 ;;; RESULT-TN.
 (defmacro with-fixed-allocation ((result-tn widetag size &optional inline)
-				 &rest forms)
-  `(pseudo-atomic
-    (allocation ,result-tn (pad-data-block ,size) ,inline)
-    (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
-	    ,result-tn)
-    (inst lea ,result-tn
-	  (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
-    ,@forms))
+				 &body forms)
+  (unless forms
+    (bug "empty &body in WITH-FIXED-ALLOCATION"))
+  (once-only ((result-tn result-tn) (size size))
+    `(pseudo-atomic
+      (allocation ,result-tn (pad-data-block ,size) ,inline)
+      (storew (logior (ash (1- ,size) n-widetag-bits) ,widetag)
+	      ,result-tn)
+      (inst lea ,result-tn
+	    (make-ea :qword :base ,result-tn :disp other-pointer-lowtag))
+      ,@forms)))
 
 ;;;; error code
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
@@ -285,6 +269,12 @@
 ;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
 ;;; the C flag after the shift to see whether you were interrupted.
 
+;;; FIXME: THIS NAME IS BACKWARDS!
+(defmacro maybe-pseudo-atomic (really-p &body body)
+  `(if ,really-p
+       (progn ,@body)
+       (pseudo-atomic ,@body)))
+
 (defmacro pseudo-atomic (&rest forms)
   (with-unique-names (label)
     `(let ((,label (gen-label)))