Newer
Older
;;;
;;; **********************************************************************
;;; 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/compiler/mips/alloc.lisp,v 1.18 1992/08/02 20:24:36 wlott Exp $")
;;; **********************************************************************
;;;
;;; Allocation VOPs for the MIPS port.
;;;
;;; Written by William Lott.
;;;
(in-package "MIPS")
;;;; LIST and LIST*
(define-vop (list-or-list*)
(:args (things :more t))
(:temporary (:scs (descriptor-reg) :type list) ptr)
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
res)
(:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
(:generator 0
(cond ((zerop num)
(move result null-tn))
((and star (= num 1))
(move result (tn-ref-tn things)))
(t
(macrolet
((store-car (tn list &optional (slot cons-car-slot))
`(let ((reg
(sc-case ,tn
((any-reg descriptor-reg) ,tn)
(zero zero-tn)
(null null-tn)
(control-stack
(load-stack-tn temp ,tn)
temp))))
(storew reg ,list ,slot list-pointer-type))))
(pseudo-atomic (pa-flag
:extra (* (pad-data-block cons-size)
cons-cells))
(inst or res alloc-tn list-pointer-type)
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(setf things (tn-ref-across things))
(inst addu ptr ptr (pad-data-block cons-size))
(storew ptr ptr
(- cons-cdr-slot cons-size)
list-pointer-type))
(cond (star
(setf things (tn-ref-across things))
(store-car (tn-ref-tn things) ptr cons-cdr-slot))
(t
(storew null-tn ptr
cons-cdr-slot list-pointer-type)))
(assert (null (tn-ref-across things)))
(move result res))))))))
(define-vop (list list-or-list*)
(:variant nil))
(define-vop (list* list-or-list*)
(:variant t))
;;;; Special purpose inline allocators.
(define-vop (allocate-code-object)
(:args (boxed-arg :scs (any-reg))
(unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
(:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
(inst li ndescr (lognot lowtag-mask))
(inst addu boxed boxed-arg (fixnum (1+ code-trace-table-offset-slot)))
(inst srl unboxed unboxed-arg word-shift)
(inst addu unboxed unboxed lowtag-mask)
(pseudo-atomic (pa-flag)
(inst or result alloc-tn other-pointer-type)
(inst addu alloc-tn boxed)
(inst addu alloc-tn unboxed)
(inst sll ndescr boxed (- type-bits word-shift))
(inst or ndescr code-header-type)
(storew ndescr result 0 other-pointer-type)
(storew unboxed result code-code-size-slot other-pointer-type)
(storew null-tn result code-entry-points-slot other-pointer-type)
(storew null-tn result code-debug-info-slot other-pointer-type))))
(define-vop (make-fdefn)
(:policy :fast-safe)
(:translate make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
(:results (result :scs (descriptor-reg) :from :argument))
(:generator 37
(with-fixed-allocation (result pa-flag temp fdefn-type fdefn-size)
(storew name result fdefn-name-slot other-pointer-type)
(storew null-tn result fdefn-function-slot other-pointer-type)
(inst li temp (make-fixup "undefined_tramp" :foreign))
(storew temp result fdefn-raw-addr-slot other-pointer-type))))
;;;; Automatic allocators for primitive objects.
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
(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-vop (,alloc-vop)
(:args ,@(mapcar #'(lambda (name)
`(,name :scs (any-reg descriptor-reg)))
(args)))
(:temporary (:scs (non-descriptor-reg))
,@(when (or header need-unbound-marker)
'(temp))
,@(when variable-length '(temp2)))
(:temporary (:scs (descriptor-reg) :to (:result 0)
:target real-result) result)
(:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
(:results (real-result :scs (descriptor-reg)))
(:policy :fast-safe)
,@(when alloc-trans
`((:translate ,alloc-trans)))
(:generator ,(+ 4
(length (init-forms))
(if header 2 0)
(if variable-length 6 0)
(if need-unbound-marker 1 0))
(pseudo-atomic
(pa-flag :extra ,(if variable-length
0
`(pad-data-block ,size)))
(inst or result alloc-tn ,lowtag)
,@(cond ((and header variable-length)
`((inst addu temp extra-words (fixnum (1+ ,size)))
(inst li temp2 (lognot lowtag-mask))
(inst and temp temp2)
(inst addu alloc-tn temp)
(inst addu temp extra-words (fixnum (1- ,size)))
(inst sll temp (- type-bits word-shift))
(inst or temp temp ,header)
(storew temp result 0 ,lowtag)))
(variable-length
(error ":REST-P T with no header in ~S?"
(primitive-object-name obj)))
(header
`((inst li temp
,(logior (ash (1- size) type-bits)
(symbol-value header)))
(storew temp result 0 ,lowtag))))