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))))))