[4d5026]: src / compiler / x86 / alloc.lisp Maximize Restore History

Download this file

alloc.lisp    263 lines (245 with data), 10.2 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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
;;;; allocation VOPs for the x86
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
;;;; LIST and LIST*
(define-vop (list-or-list*)
(:args (things :more t))
(:temporary (:sc unsigned-reg) ptr temp)
(:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(:policy :safe)
(:node-var node)
(:generator 0
(cond ((zerop num)
;; (move result nil-value)
(inst mov result nil-value))
((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)
((control-stack)
(move temp ,tn)
temp))))
(storew reg ,list ,slot list-pointer-lowtag))))
(let ((cons-cells (if star (1- num) num)))
(pseudo-atomic
(allocation res (* (pad-data-block cons-size) cons-cells) node)
(inst lea res
(make-ea :byte :base res :disp list-pointer-lowtag))
(move ptr res)
(dotimes (i (1- cons-cells))
(store-car (tn-ref-tn things) ptr)
(setf things (tn-ref-across things))
(inst add ptr (pad-data-block cons-size))
(storew ptr ptr (- cons-cdr-slot cons-size)
list-pointer-lowtag))
(store-car (tn-ref-tn things) ptr)
(cond (star
(setf things (tn-ref-across things))
(store-car (tn-ref-tn things) ptr cons-cdr-slot))
(t
(storew nil-value ptr cons-cdr-slot
list-pointer-lowtag)))
(aver (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) :target boxed)
(unboxed-arg :scs (any-reg) :target unboxed))
(:results (result :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg :from :eval) temp)
(:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
(:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
(:generator 100
(move boxed boxed-arg)
(inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
(inst and boxed (lognot lowtag-mask))
(move unboxed unboxed-arg)
(inst shr unboxed word-shift)
(inst add unboxed lowtag-mask)
(inst and unboxed (lognot lowtag-mask))
(pseudo-atomic
;; comment from CMU CL code:
;; now loading code into static space cause it can't move
;;
;; KLUDGE: What? What's all the cruft about saving fixups for then?
;; I think what's happened is that ALLOCATE-CODE-OBJECT is the basic
;; CMU CL primitive; this ALLOCATE-CODE-OBJECT was hacked for
;; static space only in a simple-minded port to the X86; and then
;; in an attempt to improve the port to the X86,
;; ALLOCATE-DYNAMIC-CODE-OBJECT was defined. If that's right, I'd like
;; to know why not just go back to the basic CMU CL behavior of
;; ALLOCATE-CODE-OBJECT, where it makes a relocatable code object.
;; -- WHN 19990916
;;
;; FIXME: should have a check for overflow of static space
(load-symbol-value temp *static-space-free-pointer*)
(inst lea result (make-ea :byte :base temp :disp other-pointer-lowtag))
(inst add temp boxed)
(inst add temp unboxed)
(store-symbol-value temp *static-space-free-pointer*)
(inst shl boxed (- n-widetag-bits word-shift))
(inst or boxed code-header-widetag)
(storew boxed result 0 other-pointer-lowtag)
(storew unboxed result code-code-size-slot other-pointer-lowtag)
(inst mov temp nil-value)
(storew temp result code-entry-points-slot other-pointer-lowtag))
(storew temp result code-debug-info-slot other-pointer-lowtag)))
(define-vop (allocate-dynamic-code-object)
(:args (boxed-arg :scs (any-reg) :target boxed)
(unboxed-arg :scs (any-reg) :target unboxed))
(:results (result :scs (descriptor-reg) :from :eval))
(:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
(:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
(:node-var node)
(:generator 100
(move boxed boxed-arg)
(inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
(inst and boxed (lognot lowtag-mask))
(move unboxed unboxed-arg)
(inst shr unboxed word-shift)
(inst add unboxed lowtag-mask)
(inst and unboxed (lognot lowtag-mask))
(inst mov result boxed)
(inst add result unboxed)
(pseudo-atomic
(allocation result result node)
(inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
(inst shl boxed (- n-widetag-bits word-shift))
(inst or boxed code-header-widetag)
(storew boxed result 0 other-pointer-lowtag)
(storew unboxed result code-code-size-slot other-pointer-lowtag)
(storew nil-value result code-entry-points-slot other-pointer-lowtag))
(storew nil-value result code-debug-info-slot other-pointer-lowtag)))
(define-vop (make-fdefn)
(:policy :fast-safe)
(:translate make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:results (result :scs (descriptor-reg) :from :argument))
(:node-var node)
(:generator 37
(with-fixed-allocation (result fdefn-widetag fdefn-size node)
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew nil-value result fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
result fdefn-raw-addr-slot other-pointer-lowtag))))
(define-vop (make-closure)
(:args (function :to :save :scs (descriptor-reg)))
(:info length)
(:temporary (:sc any-reg) temp)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 10
(pseudo-atomic
(let ((size (+ length closure-info-offset)))
(allocation result (pad-data-block size) node)
(inst lea result
(make-ea :byte :base result :disp fun-pointer-lowtag))
(storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
result 0 fun-pointer-lowtag))
(loadw temp function closure-fun-slot fun-pointer-lowtag)
(storew temp 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 :scs (descriptor-reg any-reg) :to :result))
(:results (result :scs (descriptor-reg) :from :eval))
(:node-var node)
(:generator 10
(with-fixed-allocation
(result value-cell-header-widetag value-cell-size node))
(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 mov result unbound-marker-widetag)))
(define-vop (fixed-alloc)
(:args)
(:info name words type lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg)))
(:node-var node)
(:generator 50
(pseudo-atomic
(allocation result (pad-data-block words) node)
(inst lea result (make-ea :byte :base result :disp lowtag))
(when type
(storew (logior (ash (1- words) n-widetag-bits) type)
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) :from (:eval 1)))
(:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
(:temporary (:sc any-reg :from :eval :to :result) header)
(:node-var node)
(:generator 50
(inst lea bytes
(make-ea :dword :base extra :disp (* (1+ words) n-word-bytes)))
(inst mov header bytes)
(inst shl header (- n-widetag-bits 2)) ; w+1 to length field
(inst lea header ; (w-1 << 8) | type
(make-ea :dword :base header :disp (+ (ash -2 n-widetag-bits) type)))
(inst and bytes (lognot lowtag-mask))
(pseudo-atomic
(allocation result bytes node)
(inst lea result (make-ea :byte :base result :disp lowtag))
(storew header result 0 lowtag))))
(define-vop (make-symbol)
(:policy :fast-safe)
(:translate make-symbol)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:sc unsigned-reg :from :eval) temp)
(:results (result :scs (descriptor-reg) :from :argument))
(:node-var node)
(:generator 37
(with-fixed-allocation (result symbol-header-widetag symbol-size node)
(storew name result symbol-name-slot other-pointer-lowtag)
(storew unbound-marker-widetag
result
symbol-value-slot
other-pointer-lowtag)
;; Set up a random hash value for the symbol. Perhaps the object
;; address could be used for even faster and smaller code!
;; FIXME: We don't mind the symbol hash not being repeatable, so
;; we might as well add in the object address here, too. (Adding entropy
;; is good, even if ANSI doesn't understand that.)
(inst imul temp
(make-fixup (extern-alien-name "fast_random_state") :foreign)
1103515245)
(inst add temp 12345)
(inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
temp)
;; We want a positive fixnum for the hash value, so discard the LS bits.
;;
;; FIXME: OK, who wants to tell me (CSR) why these two
;; instructions aren't replaced by (INST AND TEMP #x8FFFFFFC)?
;; Are the following two instructions actually faster? Does the
;; difference in behaviour really matter?
(inst shr temp 1)
(inst and temp #xfffffffc)
(storew temp result symbol-hash-slot other-pointer-lowtag)
(storew nil-value result symbol-plist-slot other-pointer-lowtag)
(storew nil-value result symbol-package-slot other-pointer-lowtag))))