forked from dmitryvk/sbcl-win32-threads
/
macros.lisp
350 lines (312 loc) · 13.4 KB
/
macros.lisp
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
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
;;;; a bunch of handy macros for the PPC
;;;; 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")
;;; Instruction-like macros.
(defmacro move (dst src)
"Move SRC into DST unless they are location=."
(once-only ((n-dst dst)
(n-src src))
`(unless (location= ,n-dst ,n-src)
(inst mr ,n-dst ,n-src))))
(macrolet
((def (op inst shift)
`(defmacro ,op (object base &optional (offset 0) (lowtag 0))
`(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
(def loadw lwz word-shift)
(def storew stw word-shift))
(defmacro load-symbol (reg symbol)
`(inst addi ,reg null-tn (static-symbol-offset ,symbol)))
(macrolet
((frob (slot)
(let ((loader (intern (concatenate 'simple-string
"LOAD-SYMBOL-"
(string slot))))
(storer (intern (concatenate 'simple-string
"STORE-SYMBOL-"
(string slot))))
(offset (intern (concatenate 'simple-string
"SYMBOL-"
(string slot)
"-SLOT")
(find-package "SB!VM"))))
`(progn
(defmacro ,loader (reg symbol)
`(inst lwz ,reg null-tn
(+ (static-symbol-offset ',symbol)
(ash ,',offset word-shift)
(- other-pointer-lowtag))))
(defmacro ,storer (reg symbol)
`(inst stw ,reg null-tn
(+ (static-symbol-offset ',symbol)
(ash ,',offset word-shift)
(- other-pointer-lowtag))))))))
(frob value)
(frob function))
(defmacro load-type (target source &optional (offset 0))
"Loads the type bits of a pointer into target independent of
byte-ordering issues."
(once-only ((n-target target)
(n-source source)
(n-offset offset))
(ecase *backend-byte-order*
(:little-endian
`(inst lbz ,n-target ,n-source ,n-offset))
(:big-endian
`(inst lbz ,n-target ,n-source (+ ,n-offset (1- n-word-bytes)))))))
;;; Macros to handle the fact that we cannot use the machine native call and
;;; return instructions.
(defmacro lisp-jump (function lip)
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
;; something is deeply bogus. look at this
;; (loadw ,lip ,function function-code-offset function-pointer-type)
(inst addi ,lip ,function (- (* n-word-bytes simple-fun-code-offset) fun-pointer-lowtag))
(inst mtctr ,lip)
(move code-tn ,function)
(inst bctr)))
(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
"Return to RETURN-PC."
`(progn
(inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
(inst mtlr ,lip)
,@(if frob-code
`((move code-tn ,return-pc)))
(inst blr)))
(defmacro emit-return-pc (label)
"Emit a return-pc header word. LABEL is the label to use for this return-pc."
`(progn
(align n-lowtag-bits)
(emit-label ,label)
(inst lra-header-word)))
;;;; Stack TN's
;;; Move a stack TN to a register and vice-versa.
(defmacro load-stack-tn (reg stack)
`(let ((reg ,reg)
(stack ,stack))
(let ((offset (tn-offset stack)))
(sc-case stack
((control-stack)
(loadw reg cfp-tn offset))))))
(defmacro store-stack-tn (stack reg)
`(let ((stack ,stack)
(reg ,reg))
(let ((offset (tn-offset stack)))
(sc-case stack
((control-stack)
(storew reg cfp-tn offset))))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
(n-stack reg-or-stack))
`(sc-case ,n-reg
((any-reg descriptor-reg)
(sc-case ,n-stack
((any-reg descriptor-reg)
(move ,n-reg ,n-stack))
((control-stack)
(loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
;;;; Storage allocation:
;;; This is the main mechanism for allocating memory in the lisp heap.
;;;
;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
;;; applied. The amount of space to be allocated is SIZE bytes (which
;;; must be a multiple of the lisp object size).
;;;
;;; On other platforms (Non-PPC), if STACK-P is given, then allocation
;;; occurs on the control stack (for dynamic-extent). In this case,
;;; you MUST also specify NODE, so that the appropriate compiler
;;; policy can be used, and TEMP-TN, which is needed for work-space.
;;; TEMP-TN MUST be a non-descriptor reg. FIXME: This is not yet
;;; implemented on PPC. We should implement this and replace the
;;; inline stack-based allocation that presently occurs in the
;;; VOPs. The stack-p argument is ignored on PPC.
;;;
;;; If generational GC is enabled, you MUST supply a value for TEMP-TN
;;; because a temp register is needed to do inline allocation.
;;; TEMP-TN, in this case, can be any register, since it holds a
;;; double-word aligned address (essentially a fixnum).
(defmacro allocation (result-tn size lowtag &key stack-p node temp-tn flag-tn)
;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
;; set. If the lowtag also has a 1 bit in the same position, we're all
;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and
;; then or in the lowtag.
;; Normal allocation to the heap.
(declare (ignore stack-p node)
#!-gencgc
(ignore temp-tn flag-tn))
#!-gencgc
(let ((alloc-size (gensym)))
`(let ((,alloc-size ,size))
(if (logbitp (1- n-lowtag-bits) ,lowtag)
(progn
(inst ori ,result-tn alloc-tn ,lowtag))
(progn
(inst clrrwi ,result-tn alloc-tn n-lowtag-bits)
(inst ori ,result-tn ,result-tn ,lowtag)))
(if (numberp ,alloc-size)
(inst addi alloc-tn alloc-tn ,alloc-size)
(inst add alloc-tn alloc-tn ,alloc-size))))
#!+gencgc
(let ((fix-addr (gensym))
(inline-alloc (gensym)))
`(let ((,fix-addr (gen-label))
(,inline-alloc (gen-label)))
;; Make temp-tn be the size
(cond ((numberp ,size)
(inst lr ,temp-tn ,size))
(t
(move ,temp-tn ,size)))
(inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
(inst lwz ,result-tn ,flag-tn 0)
;; we can optimize this to only use one fixup here, once we get
;; it working
;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4))
;; (inst lwz ,flag-tn ,flag-tn 0)
(inst lwz ,flag-tn ,flag-tn 4)
(without-scheduling ()
;; CAUTION: The C code depends on the exact order of
;; instructions here. In particular, three instructions before
;; the TW instruction must be an ADD or ADDI instruction, so it
;; can figure out the size of the desired allocation.
;; Now make result-tn point at the end of the object, to
;; figure out if we overflowed the current region.
(inst add ,result-tn ,result-tn ,temp-tn)
;; result-tn points to the new end of the region. Did we go past
;; the actual end of the region? If so, we need a full alloc.
;; The C code depends on this exact form of instruction. If
;; either changes, you have to change the other appropriately!
(inst cmpw ,result-tn ,flag-tn)
(inst bng ,inline-alloc)
(inst tw :lge ,result-tn ,flag-tn))
(inst b ,fix-addr)
(emit-label ,inline-alloc)
(inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
(inst stw ,result-tn ,flag-tn 0)
(emit-label ,fix-addr)
;; At this point, result-tn points at the end of the object.
;; Adjust to point to the beginning.
(inst sub ,result-tn ,result-tn ,temp-tn)
;; Set the lowtag appropriately
(inst ori ,result-tn ,result-tn ,lowtag))))
(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
&key (lowtag other-pointer-lowtag))
&body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
word header having the specified Type-Code. The result is placed in
Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
by the body.) The body is placed inside the PSEUDO-ATOMIC, and presumably
initializes the object."
(once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
(type-code type-code) (size size) (lowtag lowtag))
`(pseudo-atomic (,flag-tn)
(allocation ,result-tn (pad-data-block ,size) ,lowtag
:temp-tn ,temp-tn
:flag-tn ,flag-tn)
(when ,type-code
(inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
(storew ,temp-tn ,result-tn 0 ,lowtag))
,@body)))
(defun align-csp (temp)
;; is used for stack allocation of dynamic-extent objects
(let ((aligned (gen-label)))
(inst andi. temp csp-tn lowtag-mask)
(inst beq aligned)
(inst addi csp-tn csp-tn n-word-bytes)
(storew zero-tn csp-tn -1)
(emit-label aligned)))
;;;; Error Code
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
(when vop
(note-this-location vop :internal-error)))
(inst unimp ,kind)
(with-adjustable-vector (,vector)
(write-var-integer (error-number-or-lose ',code) ,vector)
,@(mapcar #'(lambda (tn)
`(let ((tn ,tn))
(write-var-integer (make-sc-offset (sc-number
(tn-sc tn))
(tn-offset tn))
,vector)))
values)
(inst byte (length ,vector))
(dotimes (i (length ,vector))
(inst byte (aref ,vector i))))
(align word-shift)))))
(defmacro error-call (vop error-code &rest values)
"Cause an error. ERROR-CODE is the error to cause."
(cons 'progn
(emit-error-break vop error-trap error-code values)))
(defmacro cerror-call (vop label error-code &rest values)
"Cause a continuable error. If the error is continued, execution resumes at
LABEL."
`(progn
,@(emit-error-break vop cerror-trap error-code values)
(inst b ,label)))
(defmacro generate-error-code (vop error-code &rest values)
"Generate-Error-Code Error-code Value*
Emit code for an error with the specified Error-Code and context Values."
`(assemble (*elsewhere*)
(let ((start-lab (gen-label)))
(emit-label start-lab)
(error-call ,vop ,error-code ,@values)
start-lab)))
(defmacro generate-cerror-code (vop error-code &rest values)
"Generate-CError-Code Error-code Value*
Emit code for a continuable error with the specified Error-Code and
context Values. If the error is continued, execution resumes after
the GENERATE-CERROR-CODE form."
(with-unique-names (continue error)
`(let ((,continue (gen-label)))
(emit-label ,continue)
(assemble (*elsewhere*)
(let ((,error (gen-label)))
(emit-label ,error)
(cerror-call ,vop ,continue ,error-code ,@values)
,error)))))
;;;; PSEUDO-ATOMIC
;;; handy macro for making sequences look atomic
;;;
;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens
;;; while we have the low bits of ALLOC-TN set, we add a "large"
;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a)
;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
(defmacro pseudo-atomic ((flag-tn) &body forms)
`(progn
(without-scheduling ()
;; Extra debugging stuff:
#+debug
(progn
(inst andi. ,flag-tn alloc-tn 7)
(inst twi :ne ,flag-tn 0))
(inst ori alloc-tn alloc-tn 4))
,@forms
(without-scheduling ()
(inst li ,flag-tn -5)
(inst and alloc-tn alloc-tn ,flag-tn)
;; Now test to see if the pseudo-atomic interrupted bit is set.
(inst andi. ,flag-tn alloc-tn 1)
(inst twi :ne ,flag-tn 0))
#+debug
(progn
(inst andi. ,flag-tn alloc-tn 7)
(inst twi :ne ,flag-tn 0))))
(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
"Arrange with the garbage collector that the pages occupied by
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection. This is currently implemented by disabling GC"
(declare (ignore objects)) ; should we eval these for side-effect?
`(without-gcing
,@body))