[506253]: src / compiler / ppc / alloc.lisp Maximize Restore History

Download this file

alloc.lisp    188 lines (168 with data), 6.7 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 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
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
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
;;;
;;; Written by William Lott.
;;;
(in-package "SB!VM")
;;;; 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 nl3-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
((maybe-load (tn)
(once-only ((tn tn))
`(sc-case ,tn
((any-reg descriptor-reg zero null)
,tn)
(control-stack
(load-stack-tn temp ,tn)
temp)))))
(let* ((cons-cells (if star (1- num) num))
(alloc (* (pad-data-block cons-size) cons-cells)))
(pseudo-atomic (pa-flag :extra alloc)
(inst clrrwi res alloc-tn n-lowtag-bits)
(inst ori res res list-pointer-lowtag)
(move ptr res)
(dotimes (i (1- cons-cells))
(storew (maybe-load (tn-ref-tn things)) ptr
cons-car-slot list-pointer-lowtag)
(setf things (tn-ref-across things))
(inst addi ptr ptr (pad-data-block cons-size))
(storew ptr ptr
(- cons-cdr-slot cons-size)
list-pointer-lowtag))
(storew (maybe-load (tn-ref-tn things)) ptr
cons-car-slot list-pointer-lowtag)
(storew (if star
(maybe-load (tn-ref-tn (tn-ref-across things)))
null-tn)
ptr cons-cdr-slot list-pointer-lowtag))
(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 nl3-offset) pa-flag)
(:generator 100
(inst addi boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot)))
(inst clrrwi boxed boxed n-lowtag-bits)
(inst srwi unboxed unboxed-arg word-shift)
(inst addi unboxed unboxed lowtag-mask)
(inst clrrwi unboxed unboxed n-lowtag-bits)
(pseudo-atomic (pa-flag)
;; Note: we don't have to subtract off the 4 that was added by
;; pseudo-atomic, because oring in other-pointer-lowtag just adds
;; it right back.
(inst ori result alloc-tn other-pointer-lowtag)
(inst add alloc-tn alloc-tn boxed)
(inst add alloc-tn alloc-tn unboxed)
(inst slwi ndescr boxed (- n-widetag-bits word-shift))
(inst ori ndescr ndescr code-header-widetag)
(storew ndescr result 0 other-pointer-lowtag)
(storew unboxed result code-code-size-slot other-pointer-lowtag)
(storew null-tn result code-entry-points-slot other-pointer-lowtag)
(storew null-tn result code-debug-info-slot other-pointer-lowtag))))
(define-vop (make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:results (result :scs (descriptor-reg) :from :argument))
(:policy :fast-safe)
(:translate make-fdefn)
(:generator 37
(with-fixed-allocation (result pa-flag temp fdefn-widetag fdefn-size)
(inst lr temp (make-fixup (extern-alien-name "undefined_tramp") :foreign))
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew null-tn result fdefn-fun-slot other-pointer-lowtag)
(storew temp result fdefn-raw-addr-slot other-pointer-lowtag))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(:info length)
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:results (result :scs (descriptor-reg)))
(:generator 10
(let ((size (+ length closure-info-offset)))
(pseudo-atomic (pa-flag :extra (pad-data-block size))
(inst clrrwi. result alloc-tn n-lowtag-bits)
(inst ori result result fun-pointer-lowtag)
(inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
(storew temp result 0 fun-pointer-lowtag)))
;(inst lis temp (ash 18 10))
;(storew temp result closure-jump-insn-slot function-pointer-type)
(storew function result closure-fun-slot fun-pointer-lowtag)))
;;; The compiler likes to be able to directly make value cells.
;;;
(define-vop (make-value-cell)
(:args (value :to :save :scs (descriptor-reg any-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:results (result :scs (descriptor-reg)))
(:generator 10
(with-fixed-allocation
(result pa-flag temp value-cell-header-widetag value-cell-size))
(storew value result value-cell-value-slot other-pointer-lowtag)))
;;;; Automatic allocators for primitive objects.
(define-vop (make-unbound-marker)
(:args)
(:results (result :scs (any-reg)))
(:generator 1
(inst li result unbound-marker-widetag)))
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:generator 4
(pseudo-atomic (pa-flag :extra (pad-data-block words))
(cond ((logbitp 2 lowtag)
(inst ori result alloc-tn lowtag))
(t
(inst clrrwi result alloc-tn n-lowtag-bits)
(inst ori result result lowtag)))
(when type
(inst lr temp (logior (ash (1- words) n-widetag-bits) type))
(storew temp result 0 lowtag)))))
(define-vop (var-alloc)
(:args (extra :scs (any-reg)))
(:arg-types positive-fixnum)
(:info name words type lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (any-reg)) bytes header)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:generator 6
(inst addi bytes extra (* (1+ words) n-word-bytes))
(inst slwi header bytes (- n-widetag-bits 2))
(inst addi header header (+ (ash -2 n-widetag-bits) type))
(inst clrrwi bytes bytes n-lowtag-bits)
(pseudo-atomic (pa-flag)
(cond ((logbitp 2 lowtag)
(inst ori result alloc-tn lowtag))
(t
(inst clrrwi result alloc-tn n-lowtag-bits)
(inst ori result result lowtag)))
(storew header result 0 lowtag)
(inst add alloc-tn alloc-tn bytes))))