Skip to content
Snippets Groups Projects
Commit 93311551 authored by wlott's avatar wlott
Browse files

New PSEUDO-ATOMIC changes

parent a7f45043
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; 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. ;;; Stuff to handle allocating simple objects.
;;; ;;;
...@@ -46,6 +46,8 @@ ...@@ -46,6 +46,8 @@
defined for ~S." defined for ~S."
(args) (primitive-object-name obj))) (args) (primitive-object-name obj)))
(when alloc-vop (when alloc-vop
(when (and variable-length (not header))
(error "Can't allocate variable-length objects with no header."))
`(define-assembly-routine `(define-assembly-routine
(,alloc-vop (,alloc-vop
(:cost 35) (:cost 35)
...@@ -63,27 +65,29 @@ ...@@ -63,27 +65,29 @@
,@(when (or need-unbound-marker header variable-length) ,@(when (or need-unbound-marker header variable-length)
'((:temp temp non-descriptor-reg nl1-offset))) '((:temp temp non-descriptor-reg nl1-offset)))
(:res result descriptor-reg a0-offset)) (:res result descriptor-reg a0-offset))
(pseudo-atomic (ndescr) (let ((alloc ,(if variable-length
(inst add result alloc-tn ,lowtag) 0
,@(cond ((and header variable-length) `(pad-data-block ,size))))
`((inst add temp extra-words (fixnum (1- ,size))) (pseudo-atomic (:extra alloc)
(inst add alloc-tn alloc-tn temp) ,@(if (logbitp 2 (eval lowtag))
(inst sll temp temp (- type-bits word-shift)) `((inst or result alloc-tn ,lowtag))
(inst or temp temp ,header) `((inst andn result alloc-tn lowtag-mask)
(storew temp result 0 ,lowtag) (inst or result ,lowtag)))
(inst add alloc-tn (+ (fixnum 1) lowtag-mask)) ,@(cond (variable-length
(inst and alloc-tn (lognot lowtag-mask)))) `((inst add temp extra-words (* (1+ ,size) word-bytes))
(variable-length (inst andn temp 7)
(error ":REST-P T with no header in ~S?" (inst add alloc-tn temp)
(primitive-object-name obj))) (inst sll temp extra-words (- type-bits word-shift))
(header (inst add temp (+ (ash (1- ,size) type-bits)
`((inst add alloc-tn (pad-data-block ,size)) header))
(inst li temp (storew temp result 0 ,lowtag)))
,(logior (ash (1- size) type-bits) (header
(symbol-value header))) `((inst li temp
(storew temp result 0 ,lowtag))) ,(logior (ash (1- size) type-bits)
(t (symbol-value header)))
`((inst add alloc-tn (pad-data-block ,size))))) (storew temp result 0 ,lowtag)))
,@(when need-unbound-marker (t
`((inst li temp unbound-marker-type))) nil))
,@(init-forms))))))) ,@(when need-unbound-marker
`((inst li temp unbound-marker-type)))
,@(init-forms))))))))
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; 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. ;;; This file contains the support routines for arrays and vectors.
;;; ;;;
...@@ -29,12 +29,11 @@ ...@@ -29,12 +29,11 @@
(:temp ndescr non-descriptor-reg nl0-offset) (:temp ndescr non-descriptor-reg nl0-offset)
(:temp vector descriptor-reg a3-offset)) (:temp vector descriptor-reg a3-offset))
(pseudo-atomic (ndescr) (pseudo-atomic ()
(inst or vector alloc-tn vm:other-pointer-type) (inst or vector alloc-tn vm:other-pointer-type)
(inst add alloc-tn alloc-tn (+ (1- (ash 1 vm:lowtag-bits)) (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
(* vm:vector-data-offset vm:word-bytes))) (inst andn ndescr 7)
(inst add alloc-tn alloc-tn words) (inst add alloc-tn ndescr)
(inst and alloc-tn alloc-tn (lognot vm:lowtag-mask))
(inst srl ndescr type vm:word-shift) (inst srl ndescr type vm:word-shift)
(storew ndescr vector 0 vm:other-pointer-type) (storew ndescr vector 0 vm:other-pointer-type)
(storew length vector vm:vector-length-slot vm:other-pointer-type)) (storew length vector vm:vector-length-slot vm:other-pointer-type))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment