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

Removed the define-for-each-primitive-object because we do it all inline

now.
parent b56beb13
No related branches found
No related tags found
No related merge requests found
;;; -*- 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.
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