diff --git a/assembly/sparc/alloc.lisp b/assembly/sparc/alloc.lisp index d728770d0e71b73f0b3dfc734dce04a21eb85b17..8addc66d5f37dd5f5cee85071a8ff410abc09c07 100644 --- a/assembly/sparc/alloc.lisp +++ b/assembly/sparc/alloc.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/alloc.lisp,v 1.1 1990/11/22 11:49:39 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/alloc.lisp,v 1.2 1992/03/11 21:40:59 wlott Exp $ ;;; ;;; Stuff to handle allocating simple objects. ;;; @@ -46,6 +46,8 @@ defined for ~S." (args) (primitive-object-name obj))) (when alloc-vop + (when (and variable-length (not header)) + (error "Can't allocate variable-length objects with no header.")) `(define-assembly-routine (,alloc-vop (:cost 35) @@ -63,27 +65,29 @@ ,@(when (or need-unbound-marker header variable-length) '((:temp temp non-descriptor-reg nl1-offset))) (:res result descriptor-reg a0-offset)) - (pseudo-atomic (ndescr) - (inst add result alloc-tn ,lowtag) - ,@(cond ((and header variable-length) - `((inst add temp extra-words (fixnum (1- ,size))) - (inst add alloc-tn alloc-tn temp) - (inst sll temp temp (- type-bits word-shift)) - (inst or temp temp ,header) - (storew temp result 0 ,lowtag) - (inst add alloc-tn (+ (fixnum 1) lowtag-mask)) - (inst and alloc-tn (lognot lowtag-mask)))) - (variable-length - (error ":REST-P T with no header in ~S?" - (primitive-object-name obj))) - (header - `((inst add alloc-tn (pad-data-block ,size)) - (inst li temp - ,(logior (ash (1- size) type-bits) - (symbol-value header))) - (storew temp result 0 ,lowtag))) - (t - `((inst add alloc-tn (pad-data-block ,size))))) - ,@(when need-unbound-marker - `((inst li temp unbound-marker-type))) - ,@(init-forms))))))) + (let ((alloc ,(if variable-length + 0 + `(pad-data-block ,size)))) + (pseudo-atomic (:extra alloc) + ,@(if (logbitp 2 (eval lowtag)) + `((inst or result alloc-tn ,lowtag)) + `((inst andn result alloc-tn lowtag-mask) + (inst or result ,lowtag))) + ,@(cond (variable-length + `((inst add temp extra-words (* (1+ ,size) word-bytes)) + (inst andn temp 7) + (inst add alloc-tn temp) + (inst sll temp extra-words (- type-bits word-shift)) + (inst add temp (+ (ash (1- ,size) type-bits) + header)) + (storew temp result 0 ,lowtag))) + (header + `((inst li temp + ,(logior (ash (1- size) type-bits) + (symbol-value header))) + (storew temp result 0 ,lowtag))) + (t + nil)) + ,@(when need-unbound-marker + `((inst li temp unbound-marker-type))) + ,@(init-forms)))))))) diff --git a/assembly/sparc/array.lisp b/assembly/sparc/array.lisp index c7e972aa764737a8c1b22d36ffd6f39c23bcbaee..69a0513b2d321ca184e683d4213321e928dba3ce 100644 --- a/assembly/sparc/array.lisp +++ b/assembly/sparc/array.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.2 1990/11/30 16:45:44 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.3 1992/03/11 21:41:02 wlott Exp $ ;;; ;;; This file contains the support routines for arrays and vectors. ;;; @@ -29,12 +29,11 @@ (:temp ndescr non-descriptor-reg nl0-offset) (:temp vector descriptor-reg a3-offset)) - (pseudo-atomic (ndescr) + (pseudo-atomic () (inst or vector alloc-tn vm:other-pointer-type) - (inst add alloc-tn alloc-tn (+ (1- (ash 1 vm:lowtag-bits)) - (* vm:vector-data-offset vm:word-bytes))) - (inst add alloc-tn alloc-tn words) - (inst and alloc-tn alloc-tn (lognot vm:lowtag-mask)) + (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes)) + (inst andn ndescr 7) + (inst add alloc-tn ndescr) (inst srl ndescr type vm:word-shift) (storew ndescr vector 0 vm:other-pointer-type) (storew length vector vm:vector-length-slot vm:other-pointer-type))