diff --git a/assembly/sparc/alloc.lisp b/assembly/sparc/alloc.lisp index 89a49cfcef01599d9e445a32b4650d2dfc5316ee..7f461e625863c0df4ff8832c8496e387b09a00e5 100644 --- a/assembly/sparc/alloc.lisp +++ b/assembly/sparc/alloc.lisp @@ -1,13 +1,15 @@ ;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). -;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/alloc.lisp,v 1.4 1992/12/13 15:24:14 wlott Exp $") ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/alloc.lisp,v 1.3 1992/03/21 22:18:56 wlott Exp $ +;;; ********************************************************************** ;;; ;;; Stuff to handle allocating simple objects. ;;; @@ -16,77 +18,4 @@ (in-package "SPARC") -(define-for-each-primitive-object (obj) - (let* ((options (primitive-object-options obj)) - (alloc-trans (getf options :alloc-trans)) - (alloc-vop (getf options :alloc-vop alloc-trans)) - (header (primitive-object-header obj)) - (lowtag (primitive-object-lowtag obj)) - (size (primitive-object-size obj)) - (variable-length (primitive-object-variable-length obj)) - (need-unbound-marker nil)) - (collect ((args) (init-forms)) - (when (and alloc-vop variable-length) - (args 'extra-words)) - (dolist (slot (primitive-object-slots obj)) - (let* ((name (slot-name slot)) - (offset (slot-offset slot))) - (ecase (getf (slot-options slot) :init :zero) - (:zero) - (:null - (init-forms `(storew null-tn result ,offset ,lowtag))) - (:unbound - (setf need-unbound-marker t) - (init-forms `(storew temp result ,offset ,lowtag))) - (:arg - (args name) - (init-forms `(storew ,name result ,offset ,lowtag)))))) - (when (and (null alloc-vop) (args)) - (error "Slots ~S want to be initialized, but there is no alloc vop ~ - 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) - ,@(when alloc-trans - `((:translate ,alloc-trans))) - (:policy :fast-safe)) - (,@(let ((arg-offsets (cdr register-arg-offsets))) - (mapcar #'(lambda (name) - (unless arg-offsets - (error "Too many args in ~S" alloc-vop)) - `(:arg ,name (descriptor-reg any-reg) - ,(pop arg-offsets))) - (args))) - ,@(when (or need-unbound-marker header variable-length) - '((:temp temp non-descriptor-reg nl1-offset))) - (:res result descriptor-reg a0-offset)) - (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)))))))) +;;; But we do everything inline now that we have a better pseudo-atomic.