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