alloc.lisp 3.29 KB
Newer Older
chiles's avatar
chiles committed
1 2 3 4
;;; -*- Package: RT -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
ram's avatar
ram committed
5 6 7
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/assembly/rt/alloc.lisp $")
ram's avatar
ram committed
9
;;;
chiles's avatar
chiles committed
10 11
;;; **********************************************************************
;;;
12
;;; $Header: src/assembly/rt/alloc.lisp $
chiles's avatar
chiles committed
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
;;;
;;; Stuff to handle allocating simple objects.
;;;
;;; Written by William Lott.
;;; Converted to the IBM RT by Bill Chiles.
;;;

(in-package "RT")


(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
	`(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)))
		(:temp alloc non-descriptor-reg nl0-offset)
67
		(:temp temp non-descriptor-reg ocfp-offset)
chiles's avatar
chiles committed
68
		(:res result descriptor-reg a0-offset))
wlott's avatar
wlott committed
69
	   (pseudo-atomic (temp)
chiles's avatar
chiles committed
70 71 72
	     (load-symbol-value alloc *allocation-pointer*)
	     (inst cal result alloc ,lowtag)
	     ,@(cond ((and header variable-length)
73
		      `((inst cal temp extra-words (fixnumize (1- ,size)))
chiles's avatar
chiles committed
74 75 76 77
			(inst cas alloc temp alloc)
			(inst sl temp (- type-bits word-shift))
			(inst oil temp ,header)
			(storew temp result 0 ,lowtag)
78
			(inst cal alloc alloc (+ (fixnumize 1) lowtag-mask))
chiles's avatar
chiles committed
79 80 81 82 83 84
			(inst li temp (lognot lowtag-mask))
			(inst n alloc temp)))
		     (variable-length
		      (error ":REST-P T with no header in ~S?"
			     (primitive-object-name obj)))
		     (header
85
		      `((inst cal alloc alloc (pad-data-block ,size))
chiles's avatar
chiles committed
86 87 88 89 90
			(inst li temp
			      ,(logior (ash (1- size) type-bits)
				       (symbol-value header)))
			(storew temp result 0 ,lowtag)))
		     (t
91
		      `((inst cal alloc alloc (pad-data-block ,size)))))
chiles's avatar
chiles committed
92 93
	     ,@(when need-unbound-marker
		 `((inst li temp unbound-marker-type)))
94
	     ,@(init-forms)
wlott's avatar
wlott committed
95 96 97
	     (store-symbol-value alloc *allocation-pointer*))
	   (load-symbol-value temp *internal-gc-trigger*)
	   (inst tlt temp alloc))))))