Commit 0cf947cc authored by dtc's avatar dtc
Browse files

Wrap pseudo-atomic around object allocation and initialisation to

avoid possible heap corruption due to interruption. Exploit the
with-fixed-allocation macro where appropriate.
parent 640eac17
......@@ -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))
......@@ -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)
......
......@@ -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))
......
......@@ -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))))
......@@ -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.
......
......@@ -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
......
......@@ -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)
......
......@@ -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)