From 0cf947cc3e2b54efdf8c055c346358a8dbed5d31 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Wed, 19 Nov 1997 03:00:39 +0000
Subject: [PATCH] Wrap pseudo-atomic around object allocation and
 initialisation to avoid possible heap corruption due to interruption. Exploit
 the with-fixed-allocation macro where appropriate.

---
 assembly/x86/alloc.lisp |  14 ++--
 assembly/x86/arith.lisp |  24 +++---
 assembly/x86/array.lisp |  11 +--
 compiler/x86/alloc.lisp | 160 +++++++++++++++++++++-------------------
 compiler/x86/array.lisp |   9 ++-
 compiler/x86/call.lisp  |  67 +++++++++--------
 compiler/x86/float.lisp |  91 ++++++++++++-----------
 compiler/x86/move.lisp  |  16 ++--
 compiler/x86/sap.lisp   |   6 +-
 9 files changed, 210 insertions(+), 188 deletions(-)

diff --git a/assembly/x86/alloc.lisp b/assembly/x86/alloc.lisp
index 4cd98cb44..e5d16bc9d 100644
--- a/assembly/x86/alloc.lisp
+++ b/assembly/x86/alloc.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/alloc.lisp,v 1.3 1997/11/04 09:10:35 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/alloc.lisp,v 1.4 1997/11/19 02:57:16 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -35,8 +35,8 @@
   (inst ret)
   BIGNUM
 
-  (fixed-allocation ebx bignum-type (+ bignum-digits-offset 1))
-  (storew eax ebx bignum-digits-offset other-pointer-type)
+  (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
+    (storew eax ebx bignum-digits-offset other-pointer-type))
 
   (inst ret))
 
@@ -64,11 +64,11 @@
   (inst mov ebx eax)
 
   ;; Two word bignum
-  (fixed-allocation ebx bignum-type (+ bignum-digits-offset 2))
-  (storew eax ebx bignum-digits-offset other-pointer-type)
+  (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 2))
+    (storew eax ebx bignum-digits-offset other-pointer-type))
   (inst ret)
   
   ONE-WORD-BIGNUM
-  (fixed-allocation ebx bignum-type (+ bignum-digits-offset 1))
-    (storew eax ebx bignum-digits-offset other-pointer-type)
+  (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
+    (storew eax ebx bignum-digits-offset other-pointer-type))
   (inst ret))
diff --git a/assembly/x86/arith.lisp b/assembly/x86/arith.lisp
index 5bc13ad32..8520202ad 100644
--- a/assembly/x86/arith.lisp
+++ b/assembly/x86/arith.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/arith.lisp,v 1.5 1997/11/04 09:10:36 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/arith.lisp,v 1.6 1997/11/19 02:57:16 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -78,8 +78,8 @@
 
   (move ecx res)
 
-  (fixed-allocation res bignum-type (1+ bignum-digits-offset))
-  (storew ecx res bignum-digits-offset other-pointer-type)
+  (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+    (storew ecx res bignum-digits-offset other-pointer-type))
   
   OKAY)
 
@@ -98,8 +98,8 @@
   
   (move ecx res)
   
-  (fixed-allocation res bignum-type (1+ bignum-digits-offset))
-  (storew ecx res bignum-digits-offset other-pointer-type)
+  (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+    (storew ecx res bignum-digits-offset other-pointer-type))
   OKAY)
 
 (define-generic-arith-routine (* 30)
@@ -119,15 +119,15 @@
   (inst cmp x ecx)
   (inst jmp :e SINGLE-WORD-BIGNUM)
 
-  (fixed-allocation res bignum-type (+ bignum-digits-offset 2))
-  (storew eax res bignum-digits-offset other-pointer-type)
-  (storew ecx res (1+ bignum-digits-offset) other-pointer-type)
+  (with-fixed-allocation (res bignum-type (+ bignum-digits-offset 2))
+    (storew eax res bignum-digits-offset other-pointer-type)
+    (storew ecx res (1+ bignum-digits-offset) other-pointer-type))
   (inst jmp DONE)
 
   SINGLE-WORD-BIGNUM
   
-  (fixed-allocation res bignum-type (1+ bignum-digits-offset))
-  (storew eax res bignum-digits-offset other-pointer-type)
+  (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+    (storew eax res bignum-digits-offset other-pointer-type))
   (inst jmp DONE)
 
   OKAY
@@ -167,8 +167,8 @@
   (inst shr res 2)			; sign bit is data - remove type bits
   (move ecx res)
 
-  (fixed-allocation res bignum-type (1+ bignum-digits-offset))
-  (storew ecx res bignum-digits-offset other-pointer-type)
+  (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+    (storew ecx res bignum-digits-offset other-pointer-type))
   
   OKAY)
 
diff --git a/assembly/x86/array.lisp b/assembly/x86/array.lisp
index 1fc804b98..49a996f9a 100644
--- a/assembly/x86/array.lisp
+++ b/assembly/x86/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.4 1997/11/05 14:59:40 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/array.lisp,v 1.5 1997/11/19 02:57:17 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -37,10 +37,11 @@
 		      (* vector-data-offset word-bytes)))
   (inst add result words)
   (inst and result (lognot vm:lowtag-mask))
-  (allocation result result)
-  (inst lea result (make-ea :byte :base result :disp other-pointer-type))
-  (storew type result 0 other-pointer-type)
-  (storew length result vector-length-slot other-pointer-type)
+  (pseudo-atomic
+   (allocation result result)
+   (inst lea result (make-ea :byte :base result :disp other-pointer-type))
+   (storew type result 0 other-pointer-type)
+   (storew length result vector-length-slot other-pointer-type))
   (inst ret))
 
 
diff --git a/compiler/x86/alloc.lisp b/compiler/x86/alloc.lisp
index 5f6e429de..ce37fb673 100644
--- a/compiler/x86/alloc.lisp
+++ b/compiler/x86/alloc.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.5 1997/11/18 10:53:17 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.6 1997/11/19 03:00:32 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -50,24 +50,26 @@
 			     temp))))
 		     (storew reg ,list ,slot vm:list-pointer-type))))
 	     (let ((cons-cells (if star (1- num) num)))
-	       (allocation res (* (pad-data-block cons-size) cons-cells) node)
-	       (inst lea res (make-ea :byte :base res :disp list-pointer-type))
-	       (move ptr res)
-	       (dotimes (i (1- cons-cells))
-		 (store-car (tn-ref-tn things) ptr)
-		 (setf things (tn-ref-across things))
-		 (inst add ptr (pad-data-block cons-size))
-		 (storew ptr ptr (- cons-cdr-slot cons-size)
-			 list-pointer-type))
-	       (store-car (tn-ref-tn things) ptr)
-	       (cond (star
-		      (setf things (tn-ref-across things))
-		      (store-car (tn-ref-tn things) ptr cons-cdr-slot))
-		     (t
-		      (storew nil-value ptr cons-cdr-slot
-			      list-pointer-type)))
-	       (assert (null (tn-ref-across things)))))
-	   (move result res)))))
+	       (pseudo-atomic
+		(allocation res (* (pad-data-block cons-size) cons-cells) node)
+		(inst lea res
+		      (make-ea :byte :base res :disp list-pointer-type))
+		(move ptr res)
+		(dotimes (i (1- cons-cells))
+		  (store-car (tn-ref-tn things) ptr)
+		  (setf things (tn-ref-across things))
+		  (inst add ptr (pad-data-block cons-size))
+		  (storew ptr ptr (- cons-cdr-slot cons-size)
+			  list-pointer-type))
+		(store-car (tn-ref-tn things) ptr)
+		(cond (star
+		       (setf things (tn-ref-across things))
+		       (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+		      (t
+		       (storew nil-value ptr cons-cdr-slot
+			       list-pointer-type)))
+		(assert (null (tn-ref-across things)))))
+	     (move result res))))))
 
 (define-vop (list list-or-list*)
   (:variant nil))
@@ -93,19 +95,19 @@
     (inst shr unboxed word-shift)
     (inst add unboxed lowtag-mask)
     (inst and unboxed (lognot lowtag-mask))
-    ;; now loading code into static space cause it can't move
-    (load-symbol-value temp lisp::*static-space-free-pointer*)
-    (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
-    (inst add temp boxed)
-    (inst add temp unboxed)
-    (store-symbol-value temp lisp::*static-space-free-pointer*)
-    (inst shl boxed (- type-bits word-shift))
-    (inst or boxed code-header-type)
-    (storew boxed result 0 other-pointer-type)
-    (storew unboxed result code-code-size-slot other-pointer-type)
-    ;; (move temp nil-value)
-    (inst mov temp nil-value)
-    (storew temp result code-entry-points-slot other-pointer-type)
+    (pseudo-atomic
+     ;; now loading code into static space cause it can't move
+     (load-symbol-value temp lisp::*static-space-free-pointer*)
+     (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
+     (inst add temp boxed)
+     (inst add temp unboxed)
+     (store-symbol-value temp lisp::*static-space-free-pointer*)
+     (inst shl boxed (- type-bits word-shift))
+     (inst or boxed code-header-type)
+     (storew boxed result 0 other-pointer-type)
+     (storew unboxed result code-code-size-slot other-pointer-type)
+     (inst mov temp nil-value)
+     (storew temp result code-entry-points-slot other-pointer-type))
     (storew temp result code-debug-info-slot other-pointer-type)))
 
 
@@ -126,13 +128,14 @@
     (inst and unboxed (lognot lowtag-mask))
     (inst mov result boxed)
     (inst add result unboxed)
-    (allocation result result node)
-    (inst lea result (make-ea :byte :base result :disp other-pointer-type))
-    (inst shl boxed (- type-bits word-shift))
-    (inst or boxed code-header-type)
-    (storew boxed result 0 other-pointer-type)
-    (storew unboxed result code-code-size-slot other-pointer-type)
-    (storew nil-value result code-entry-points-slot other-pointer-type)
+    (pseudo-atomic
+     (allocation result result node)
+     (inst lea result (make-ea :byte :base result :disp other-pointer-type))
+     (inst shl boxed (- type-bits word-shift))
+     (inst or boxed code-header-type)
+     (storew boxed result 0 other-pointer-type)
+     (storew unboxed result code-code-size-slot other-pointer-type)
+     (storew nil-value result code-entry-points-slot other-pointer-type))
     (storew nil-value result code-debug-info-slot other-pointer-type)))
 
 
@@ -143,11 +146,11 @@
   (:results (result :scs (descriptor-reg) :from :argument))
   (:node-var node)
   (:generator 37
-    (fixed-allocation result fdefn-type fdefn-size node)
-    (storew name result fdefn-name-slot other-pointer-type)
-    (storew nil-value result fdefn-function-slot other-pointer-type)
-    (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign) result
-	    fdefn-raw-addr-slot other-pointer-type)))
+    (with-fixed-allocation (result fdefn-type fdefn-size node)
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew nil-value result fdefn-function-slot other-pointer-type)
+      (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
+	      result fdefn-raw-addr-slot other-pointer-type))))
 
 
 (define-vop (make-closure)
@@ -157,13 +160,15 @@
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 10
-   (let ((size (+ length closure-info-offset)))
-     (allocation result (pad-data-block size) node)
-     (inst lea result (make-ea :byte :base result :disp function-pointer-type))
-     (storew (logior (ash (1- size) type-bits) closure-header-type)
-	     result 0 function-pointer-type))
-   (loadw temp function closure-function-slot function-pointer-type)
-   (storew temp result closure-function-slot function-pointer-type)))
+   (pseudo-atomic
+    (let ((size (+ length closure-info-offset)))
+      (allocation result (pad-data-block size) node)
+      (inst lea result
+	    (make-ea :byte :base result :disp function-pointer-type))
+      (storew (logior (ash (1- size) type-bits) closure-header-type)
+	      result 0 function-pointer-type))
+    (loadw temp function closure-function-slot function-pointer-type)
+    (storew temp result closure-function-slot function-pointer-type))))
 
 ;;; The compiler likes to be able to directly make value cells.
 ;;; 
@@ -172,7 +177,8 @@
   (:results (result :scs (descriptor-reg) :from :eval))
   (:node-var node)
   (:generator 10
-    (fixed-allocation result value-cell-header-type value-cell-size node)
+    (with-fixed-allocation
+	(result value-cell-header-type value-cell-size node))
     (storew value result value-cell-value-slot other-pointer-type)))
 
 
@@ -192,10 +198,11 @@
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 50
-    (allocation result (pad-data-block words) node)
-    (inst lea result (make-ea :byte :base result :disp lowtag))
-    (when type
-      (storew (logior (ash (1- words) type-bits) type) result 0 lowtag))))
+    (pseudo-atomic
+     (allocation result (pad-data-block words) node)
+     (inst lea result (make-ea :byte :base result :disp lowtag))
+     (when type
+       (storew (logior (ash (1- words) type-bits) type) result 0 lowtag)))))
 
 (define-vop (var-alloc)
   (:args (extra :scs (any-reg)))
@@ -215,9 +222,10 @@
     (inst lea header			; (w-1 << 8) | type
 	  (make-ea :dword :base header :disp (+ (ash -2 type-bits) type)))
     (inst and bytes (lognot lowtag-mask))
-    (allocation result bytes node)
-    (inst lea result (make-ea :byte :base result :disp lowtag))
-    (storew header result 0 lowtag)))
+    (pseudo-atomic
+     (allocation result bytes node)
+     (inst lea result (make-ea :byte :base result :disp lowtag))
+     (storew header result 0 lowtag))))
 
 
 
@@ -229,20 +237,20 @@
   (:results (result :scs (descriptor-reg) :from :argument))
   (:node-var node)
   (:generator 37
-    (fixed-allocation result symbol-header-type symbol-size node)
-    (storew name result symbol-name-slot other-pointer-type)
-    (storew unbound-marker-type result symbol-value-slot other-pointer-type)
-    ;; Setup a random hash value for the symbol.  Perhaps the object
-    ;; address could be used for even faster and smaller code!
-    (inst imul temp
-	  (make-fixup (extern-alien-name "fast_random_state") :foreign)
-	  1103515245)
-    (inst add temp 12345)
-    (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
-	  temp)
-    ;; Want a positive fixnum for the hash value, discard the LS bits.
-    (inst shr temp 1)
-    (inst and temp #xfffffffc)
-    (storew temp result symbol-hash-slot other-pointer-type)
-    (storew nil-value result symbol-plist-slot other-pointer-type)
-    (storew nil-value result symbol-package-slot other-pointer-type)))
+    (with-fixed-allocation (result symbol-header-type symbol-size node)
+      (storew name result symbol-name-slot other-pointer-type)
+      (storew unbound-marker-type result symbol-value-slot other-pointer-type)
+      ;; Setup a random hash value for the symbol.  Perhaps the object
+      ;; address could be used for even faster and smaller code!
+      (inst imul temp
+	    (make-fixup (extern-alien-name "fast_random_state") :foreign)
+	    1103515245)
+      (inst add temp 12345)
+      (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
+	    temp)
+      ;; Want a positive fixnum for the hash value, discard the LS bits.
+      (inst shr temp 1)
+      (inst and temp #xfffffffc)
+      (storew temp result symbol-hash-slot other-pointer-type)
+      (storew nil-value result symbol-plist-slot other-pointer-type)
+      (storew nil-value result symbol-package-slot other-pointer-type))))
diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp
index 110b22d4e..45f205a05 100644
--- a/compiler/x86/array.lisp
+++ b/compiler/x86/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.8 1997/11/05 14:59:52 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.9 1997/11/19 03:00:33 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -45,9 +45,10 @@
     (inst shl header type-bits)
     (inst or  header type)
     (inst shr header 2)
-    (allocation result bytes node)
-    (inst lea result (make-ea :dword :base result :disp other-pointer-type))
-    (storew header result 0 other-pointer-type)))
+    (pseudo-atomic
+     (allocation result bytes node)
+     (inst lea result (make-ea :dword :base result :disp other-pointer-type))
+     (storew header result 0 other-pointer-type))))
 
 
 ;;;; Additional accessors and setters for the array header.
diff --git a/compiler/x86/call.lisp b/compiler/x86/call.lisp
index 58e3c27d1..c598f77d5 100644
--- a/compiler/x86/call.lisp
+++ b/compiler/x86/call.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/call.lisp,v 1.6 1997/11/18 10:53:19 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/call.lisp,v 1.7 1997/11/19 03:00:35 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1436,36 +1436,41 @@
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 20
-    (move src context)
-    (move ecx count)
-    ;; Check to see if there are no arguments, and just return NIL if so.
-    (inst mov result nil-value)
-    (inst jecxz done)
-    (inst lea dst (make-ea :dword :index ecx :scale 2))
-    (allocation dst dst node)
-    (inst lea dst (make-ea :byte :base dst :disp list-pointer-type))
-    ;; Convert the count into a raw value, so we can use the LOOP inst.
-    (inst shr ecx 2)
-    ;; Set decrement mode (successive args at lower addresses)
-    (inst std)
-    ;; Set up the result.
-    (move result dst)
-    ;; Jump into the middle of the loop, 'cause that's were we want to start.
-    (inst jmp enter)
-    LOOP
-    ;; Compute a pointer to the next cons.
-    (inst add dst (* cons-size word-bytes))
-    ;; Store a pointer to this cons in the CDR of the previous cons.
-    (storew dst dst -1 list-pointer-type)
-    ENTER
-    ;; Grab one value and stash it in the car of this cons.
-    (inst lods eax)
-    (storew eax dst 0 list-pointer-type)
-    ;; Go back for more.
-    (inst loop loop)
-    ;; NIL out the last cons.
-    (storew nil-value dst 1 vm:list-pointer-type)
-    DONE))
+    (let ((enter (gen-label))
+	  (loop (gen-label))
+	  (done (gen-label)))
+      (move src context)
+      (move ecx count)
+      ;; Check to see if there are no arguments, and just return NIL if so.
+      (inst mov result nil-value)
+      (inst jecxz done)
+      (inst lea dst (make-ea :dword :index ecx :scale 2))
+      (pseudo-atomic
+       (allocation dst dst node)
+       (inst lea dst (make-ea :byte :base dst :disp list-pointer-type))
+       ;; Convert the count into a raw value, so we can use the LOOP inst.
+       (inst shr ecx 2)
+       ;; Set decrement mode (successive args at lower addresses)
+       (inst std)
+       ;; Set up the result.
+       (move result dst)
+       ;; Jump into the middle of the loop, 'cause that's were we want
+       ;; to start.
+       (inst jmp enter)
+       (emit-label loop)
+       ;; Compute a pointer to the next cons.
+       (inst add dst (* cons-size word-bytes))
+       ;; Store a pointer to this cons in the CDR of the previous cons.
+       (storew dst dst -1 list-pointer-type)
+       (emit-label enter)
+       ;; Grab one value and stash it in the car of this cons.
+       (inst lods eax)
+       (storew eax dst 0 list-pointer-type)
+       ;; Go back for more.
+       (inst loop loop)
+       ;; NIL out the last cons.
+       (storew nil-value dst 1 vm:list-pointer-type))
+      (emit-label done))))
 
 ;;; Return the location and size of the more arg glob created by Copy-More-Arg.
 ;;; Supplied is the total number of arguments supplied (originally passed in
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index 717750e5a..83f77e6ad 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.15 1997/11/16 14:00:05 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.16 1997/11/19 03:00:36 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -300,9 +300,9 @@
   (:node-var node)
   (:note "float to pointer coercion")
   (:generator 13
-     (fixed-allocation y vm:single-float-type vm:single-float-size node)
-     (with-tn@fp-top(x)
-       (inst fst (ea-for-sf-desc y)))))
+     (with-fixed-allocation (y vm:single-float-type vm:single-float-size node)
+       (with-tn@fp-top(x)
+	 (inst fst (ea-for-sf-desc y))))))
 (define-move-vop move-from-single :move
   (single-reg) (descriptor-reg))
 
@@ -322,9 +322,9 @@
   (:node-var node)
   (:note "float to pointer coercion")
   (:generator 13
-     (fixed-allocation y vm:double-float-type vm:double-float-size node)
-     (with-tn@fp-top(x)
-       (inst fstd (ea-for-df-desc y)))))
+     (with-fixed-allocation (y vm:double-float-type vm:double-float-size node)
+       (with-tn@fp-top(x)
+	 (inst fstd (ea-for-df-desc y))))))
 (define-move-vop move-from-double :move
   (double-reg) (descriptor-reg))
 
@@ -369,16 +369,18 @@
   (:node-var node)
   (:note "complex float to pointer coercion")
   (:generator 13
-     (fixed-allocation y vm:complex-single-float-type
-		       vm:complex-single-float-size node)
-     (let ((real-tn (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
-				    :offset (tn-offset x))))
-       (with-tn@fp-top(real-tn)
-	 (inst fst (ea-for-csf-real-desc y))))
-     (let ((imag-tn (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
-				    :offset (1+ (tn-offset x)))))
-       (with-tn@fp-top(imag-tn)
-	 (inst fst (ea-for-csf-imag-desc y))))))
+     (with-fixed-allocation (y vm:complex-single-float-type
+			       vm:complex-single-float-size node)
+       (let ((real-tn (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg)
+				      :offset (tn-offset x))))
+	 (with-tn@fp-top(real-tn)
+	   (inst fst (ea-for-csf-real-desc y))))
+       (let ((imag-tn (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'single-reg)
+				      :offset (1+ (tn-offset x)))))
+	 (with-tn@fp-top(imag-tn)
+	   (inst fst (ea-for-csf-imag-desc y)))))))
 (define-move-vop move-from-complex-single :move
   (complex-single-reg) (descriptor-reg))
 
@@ -388,16 +390,18 @@
   (:node-var node)
   (:note "complex float to pointer coercion")
   (:generator 13
-     (fixed-allocation y vm:complex-double-float-type
-		       vm:complex-double-float-size node)
-     (let ((real-tn (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
-				    :offset (tn-offset x))))
-       (with-tn@fp-top(real-tn)
-	 (inst fstd (ea-for-cdf-real-desc y))))
-     (let ((imag-tn (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
-				    :offset (1+ (tn-offset x)))))
-       (with-tn@fp-top(imag-tn)
-	 (inst fstd (ea-for-cdf-imag-desc y))))))
+     (with-fixed-allocation (y vm:complex-double-float-type
+			       vm:complex-double-float-size node)
+       (let ((real-tn (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (tn-offset x))))
+	 (with-tn@fp-top(real-tn)
+	   (inst fstd (ea-for-cdf-real-desc y))))
+       (let ((imag-tn (make-random-tn :kind :normal
+				      :sc (sc-or-lose 'double-reg)
+				      :offset (1+ (tn-offset x)))))
+	 (with-tn@fp-top(imag-tn)
+	   (inst fstd (ea-for-cdf-imag-desc y)))))))
 (define-move-vop move-from-complex-double :move
   (complex-double-reg) (descriptor-reg))
 
@@ -1363,22 +1367,23 @@
 		   '((note-this-location vop :internal-error)
 		     ;; Catch any pending FPE exceptions.
 		     (inst wait)))
-		;; normal mode (for now) is "round to best"
-		(with-tn@fp-top(x)
-		  ,@(unless round-p
-		    '((inst fnstcw scw)	; save current control word
-		      (move rcw scw)	; into 16-bit register
-		      (inst or rcw (ash #b11 10)) ; CHOP
-		      (move stack-temp rcw)
-		      (inst fldcw stack-temp)))
-		  (sc-case y
-		    (signed-stack
-		     (inst fist y))
-		    (signed-reg
-		     (inst fist stack-temp)
-		     (inst mov y stack-temp)))
-		  ,@(unless round-p
-		     '((inst fldcw scw))))))))
+		(,(if round-p 'progn 'pseudo-atomic)
+		 ;; normal mode (for now) is "round to best"
+		 (with-tn@fp-top(x)
+		   ,@(unless round-p
+		     '((inst fnstcw scw)	; save current control word
+		       (move rcw scw)	; into 16-bit register
+		       (inst or rcw (ash #b11 10)) ; CHOP
+		       (move stack-temp rcw)
+		       (inst fldcw stack-temp)))
+		   (sc-case y
+		     (signed-stack
+		      (inst fist y))
+		     (signed-reg
+		      (inst fist stack-temp)
+		      (inst mov y stack-temp)))
+		   ,@(unless round-p
+		      '((inst fldcw scw)))))))))
   (frob %unary-truncate single-reg single-float nil)
   (frob %unary-truncate double-reg double-float nil)
   (frob %unary-round single-reg single-float t)
diff --git a/compiler/x86/move.lisp b/compiler/x86/move.lisp
index 9fc9a6232..1b8de8433 100644
--- a/compiler/x86/move.lisp
+++ b/compiler/x86/move.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/move.lisp,v 1.5 1997/11/18 10:53:23 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/move.lisp,v 1.6 1997/11/19 03:00:38 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -314,8 +314,9 @@
 
        (assemble (*elsewhere*)
           (emit-label bignum)
-	  (fixed-allocation y bignum-type (+ bignum-digits-offset 1) node)
-	  (storew x y bignum-digits-offset other-pointer-type)
+	  (with-fixed-allocation
+	      (y bignum-type (+ bignum-digits-offset 1) node)
+	    (storew x y bignum-digits-offset other-pointer-type))
 	  (inst jmp done)))))
 ;;;
 (define-move-vop move-from-signed :move
@@ -379,10 +380,11 @@
 	 (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) vm:type-bits)
 			     bignum-type))
 	 (emit-label l1)
-	 (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
-	 (storew y alloc)
-	 (inst lea y (make-ea :byte :base alloc :disp other-pointer-type))
-	 (storew x y bignum-digits-offset other-pointer-type)
+	 (pseudo-atomic
+	  (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
+	  (storew y alloc)
+	  (inst lea y (make-ea :byte :base alloc :disp other-pointer-type))
+	  (storew x y bignum-digits-offset other-pointer-type))
 	 (inst jmp done)))))
 ;;;
 (define-move-vop move-from-unsigned :move
diff --git a/compiler/x86/sap.lisp b/compiler/x86/sap.lisp
index 0bbfd165d..30f8ac1e3 100644
--- a/compiler/x86/sap.lisp
+++ b/compiler/x86/sap.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.5 1997/11/05 14:59:59 dtc Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/sap.lisp,v 1.6 1997/11/19 03:00:39 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -44,8 +44,8 @@
   (:note "SAP to pointer coercion") 
   (:node-var node)
   (:generator 20
-    (fixed-allocation res sap-type sap-size node)
-    (storew sap res sap-pointer-slot other-pointer-type)))
+    (with-fixed-allocation (res sap-type sap-size node)
+      (storew sap res sap-pointer-slot other-pointer-type))))
 	   
 ;;;
 (define-move-vop move-from-sap :move
-- 
GitLab