1.0.29.38: better DESCRIBE
[sbcl.git] / src / compiler / mips / macros.lisp
1 ;;;; various useful macros for generating MIPS code
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11 (in-package "SB!VM")
12
13 ;;; Handy macro for defining top-level forms that depend on the compile
14 ;;; environment.
15
16 (defmacro expand (expr)
17   (let ((gensym (gensym)))
18     `(macrolet
19          ((,gensym ()
20             ,expr))
21        (,gensym))))
22
23 \f
24 ;;; Instruction-like macros.
25
26 (defmacro move (dst src &optional (always-emit-code-p nil))
27   #!+sb-doc
28   "Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
29 is nil)."
30   (once-only ((n-dst dst)
31               (n-src src))
32     `(if (location= ,n-dst ,n-src)
33          (when ,always-emit-code-p
34            (inst nop))
35          (inst move ,n-dst ,n-src))))
36
37 (defmacro def-mem-op (op inst shift load)
38   `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
39      `(progn
40         (inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag))
41         ,,@(when load '('(inst nop))))))
42 ;;;
43 (def-mem-op loadw lw word-shift t)
44 (def-mem-op storew sw word-shift nil)
45
46 (defmacro load-symbol (reg symbol)
47   (once-only ((reg reg) (symbol symbol))
48     `(inst addu ,reg null-tn (static-symbol-offset ,symbol))))
49
50 (defmacro load-symbol-value (reg symbol)
51   `(progn
52      (inst lw ,reg null-tn
53            (+ (static-symbol-offset ',symbol)
54               (ash symbol-value-slot word-shift)
55               (- other-pointer-lowtag)))
56      (inst nop)))
57
58 (defmacro store-symbol-value (reg symbol)
59   `(inst sw ,reg null-tn
60          (+ (static-symbol-offset ',symbol)
61             (ash symbol-value-slot word-shift)
62             (- other-pointer-lowtag))))
63
64 (defmacro load-type (target source &optional (offset 0))
65   #!+sb-doc
66   "Loads the type bits of a pointer into target independent of
67 byte-ordering issues."
68   (once-only ((n-target target)
69               (n-source source)
70               (n-offset offset))
71     (ecase *backend-byte-order*
72       (:little-endian
73        `(inst lbu ,n-target ,n-source ,n-offset))
74       (:big-endian
75        `(inst lbu ,n-target ,n-source (+ ,n-offset (1- n-word-bytes)))))))
76
77
78 ;;; Macros to handle the fact that we cannot use the machine native call and
79 ;;; return instructions.
80
81 (defmacro lisp-jump (function lip)
82   #!+sb-doc
83   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
84   `(progn
85      (inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
86                                    fun-pointer-lowtag))
87      (inst j ,lip)
88      (move code-tn ,function t)))
89
90 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
91   #!+sb-doc
92   "Return to RETURN-PC.  LIP is an interior-reg temporary."
93   `(progn
94      (inst addu ,lip ,return-pc
95            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
96      (inst j ,lip)
97      ,(if frob-code
98           `(move code-tn ,return-pc t)
99           '(inst nop))))
100
101
102 (defmacro emit-return-pc (label)
103   #!+sb-doc
104   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
105   `(progn
106      (emit-alignment n-lowtag-bits)
107      (emit-label ,label)
108      (inst lra-header-word)))
109
110
111 \f
112 ;;;; Stack TN's
113
114 ;;; Move a stack TN to a register and vice-versa.
115 (defmacro load-stack-tn (reg stack)
116   `(let ((reg ,reg)
117          (stack ,stack))
118      (let ((offset (tn-offset stack)))
119        (sc-case stack
120          ((control-stack)
121           (loadw reg cfp-tn offset))))))
122
123 (defmacro store-stack-tn (stack reg)
124   `(let ((stack ,stack)
125          (reg ,reg))
126      (let ((offset (tn-offset stack)))
127        (sc-case stack
128          ((control-stack)
129           (storew reg cfp-tn offset))))))
130
131 (defmacro maybe-load-stack-tn (reg reg-or-stack)
132   #!+sb-doc
133   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
134   (once-only ((n-reg reg)
135               (n-stack reg-or-stack))
136     `(sc-case ,n-reg
137        ((any-reg descriptor-reg)
138         (sc-case ,n-stack
139           ((any-reg descriptor-reg)
140            (move ,n-reg ,n-stack))
141           ((control-stack)
142            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
143
144 \f
145 ;;;; Storage allocation:
146 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code
147                                   size dynamic-extent-p
148                                   &key (lowtag other-pointer-lowtag))
149                                  &body body)
150   #!+sb-doc
151   "Do stuff to allocate an other-pointer object of fixed Size with a single
152 word header having the specified Type-Code.  The result is placed in
153 Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non-
154 descriptor temp (which may be randomly used by the body.)  The body is
155 placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
156   (unless body
157     (bug "empty &body in WITH-FIXED-ALLOCATION"))
158   (once-only ((result-tn result-tn) (flag-tn flag-tn) (temp-tn temp-tn)
159               (type-code type-code) (size size)
160               (dynamic-extent-p dynamic-extent-p)
161               (lowtag lowtag))
162     `(if ,dynamic-extent-p
163          (pseudo-atomic (,flag-tn)
164            (align-csp ,temp-tn)
165            (inst or ,result-tn csp-tn ,lowtag)
166            (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
167            (inst addu csp-tn (pad-data-block ,size))
168            (storew ,temp-tn ,result-tn 0 ,lowtag)
169            ,@body)
170          (pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
171            ;; The pseudo-atomic bit in alloc-tn is set.  If the lowtag also
172            ;; has a 1 bit in the same position, we're all set.  Otherwise,
173            ;; we need to subtract the pseudo-atomic bit.
174            (inst or ,result-tn alloc-tn ,lowtag)
175            (unless (logbitp 0 ,lowtag) (inst sub ,result-tn 1))
176            (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
177            (storew ,temp-tn ,result-tn 0 ,lowtag)
178            ,@body))))
179
180 (defun align-csp (temp)
181   ;; is used for stack allocation of dynamic-extent objects
182   (let ((aligned (gen-label)))
183     (inst and temp csp-tn lowtag-mask)
184     (inst beq temp aligned)
185     (inst nop)
186     (inst addu csp-tn n-word-bytes)
187     (storew zero-tn csp-tn -1)
188     (emit-label aligned)))
189
190 \f
191 ;;;; Three Way Comparison
192 (defun three-way-comparison (x y condition flavor not-p target temp)
193   (ecase condition
194     (:eq
195      (if not-p
196          (inst bne x y target)
197          (inst beq x y target)))
198     (:lt
199      (ecase flavor
200        (:unsigned
201         (inst sltu temp x y))
202        (:signed
203         (inst slt temp x y)))
204      (if not-p
205          (inst beq temp target)
206          (inst bne temp target)))
207     (:gt
208      (ecase flavor
209        (:unsigned
210         (inst sltu temp y x))
211        (:signed
212         (inst slt temp y x)))
213      (if not-p
214          (inst beq temp target)
215          (inst bne temp target))))
216   (inst nop))
217
218
219 \f
220 ;;;; Error Code
221 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
222   (defun emit-error-break (vop kind code values)
223     (let ((vector (gensym)))
224       `((let ((vop ,vop))
225           (when vop
226             (note-this-location vop :internal-error)))
227         (inst break 0 ,kind)
228         (with-adjustable-vector (,vector)
229           (write-var-integer (error-number-or-lose ',code) ,vector)
230           ,@(mapcar #'(lambda (tn)
231                         `(let ((tn ,tn))
232                            (write-var-integer (make-sc-offset (sc-number
233                                                                (tn-sc tn))
234                                                               (tn-offset tn))
235                                               ,vector)))
236                     values)
237           (inst byte (length ,vector))
238           (dotimes (i (length ,vector))
239             (inst byte (aref ,vector i))))
240         (emit-alignment word-shift)))))
241
242 (defmacro error-call (vop error-code &rest values)
243   #!+sb-doc
244   "Cause an error.  ERROR-CODE is the error to cause."
245   (cons 'progn
246         (emit-error-break vop error-trap error-code values)))
247
248
249 (defmacro cerror-call (vop label error-code &rest values)
250   #!+sb-doc
251   "Cause a continuable error.  If the error is continued, execution resumes at
252   LABEL."
253   `(progn
254      (without-scheduling ()
255        (inst b ,label)
256        ,@(emit-error-break vop cerror-trap error-code values))))
257
258 (defmacro generate-error-code (vop error-code &rest values)
259   #!+sb-doc
260   "Generate-Error-Code Error-code Value*
261   Emit code for an error with the specified Error-Code and context Values."
262   `(assemble (*elsewhere*)
263      (let ((start-lab (gen-label)))
264        (emit-label start-lab)
265        (error-call ,vop ,error-code ,@values)
266        start-lab)))
267
268 (defmacro generate-cerror-code (vop error-code &rest values)
269   #!+sb-doc
270   "Generate-CError-Code Error-code Value*
271   Emit code for a continuable error with the specified Error-Code and
272   context Values.  If the error is continued, execution resumes after
273   the GENERATE-CERROR-CODE form."
274   (with-unique-names (continue error)
275     `(let ((,continue (gen-label)))
276        (emit-label ,continue)
277        (assemble (*elsewhere*)
278          (let ((,error (gen-label)))
279            (emit-label ,error)
280            (cerror-call ,vop ,continue ,error-code ,@values)
281            ,error)))))
282 \f
283 ;;;; PSEUDO-ATOMIC
284
285 ;;; handy macro for making sequences look atomic
286 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
287   `(progn
288      (aver (= (tn-offset ,flag-tn) nl4-offset))
289      (aver (not (minusp ,extra)))
290      (without-scheduling ()
291        (inst li ,flag-tn ,extra)
292        (inst addu alloc-tn 1))
293      ,@forms
294      (without-scheduling ()
295        (let ((label (gen-label)))
296          (inst bgez ,flag-tn label)
297          (inst addu alloc-tn (1- ,extra))
298          (inst break 0 16)
299          (emit-label label)))))
300 \f
301 ;;;; memory accessor vop generators
302
303 (deftype load/store-index (scale lowtag min-offset
304                                  &optional (max-offset min-offset))
305   `(integer ,(- (truncate (+ (ash 1 16)
306                              (* min-offset n-word-bytes)
307                              (- lowtag))
308                           scale))
309             ,(truncate (- (+ (1- (ash 1 16)) lowtag)
310                           (* max-offset n-word-bytes))
311                        scale)))
312
313 (defmacro define-full-reffer (name type offset lowtag scs el-type
314                                    &optional translate)
315   `(progn
316      (define-vop (,name)
317        ,@(when translate
318            `((:translate ,translate)))
319        (:policy :fast-safe)
320        (:args (object :scs (descriptor-reg))
321               (index :scs (any-reg)))
322        (:arg-types ,type tagged-num)
323        (:temporary (:scs (interior-reg)) lip)
324        (:results (value :scs ,scs))
325        (:result-types ,el-type)
326        (:generator 5
327          (inst addu lip object index)
328          (loadw value lip ,offset ,lowtag)))
329      (define-vop (,(symbolicate name "-C"))
330        ,@(when translate
331            `((:translate ,translate)))
332        (:policy :fast-safe)
333        (:args (object :scs (descriptor-reg)))
334        (:info index)
335        (:arg-types ,type
336                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
337                                                 ,(eval offset))))
338        (:results (value :scs ,scs))
339        (:result-types ,el-type)
340        (:generator 4
341          (loadw value object (+ ,offset index) ,lowtag)))))
342
343 (defmacro define-full-setter (name type offset lowtag scs el-type
344                                    &optional translate)
345   `(progn
346      (define-vop (,name)
347        ,@(when translate
348            `((:translate ,translate)))
349        (:policy :fast-safe)
350        (:args (object :scs (descriptor-reg))
351               (index :scs (any-reg))
352               (value :scs ,scs :target result))
353        (:arg-types ,type tagged-num ,el-type)
354        (:temporary (:scs (interior-reg)) lip)
355        (:results (result :scs ,scs))
356        (:result-types ,el-type)
357        (:generator 2
358          (inst addu lip object index)
359          (storew value lip ,offset ,lowtag)
360          (move result value)))
361      (define-vop (,(symbolicate name "-C"))
362        ,@(when translate
363            `((:translate ,translate)))
364        (:policy :fast-safe)
365        (:args (object :scs (descriptor-reg))
366               (value :scs ,scs))
367        (:info index)
368        (:arg-types ,type
369                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
370                                                 ,(eval offset)))
371                    ,el-type)
372        (:results (result :scs ,scs))
373        (:result-types ,el-type)
374        (:generator 1
375          (storew value object (+ ,offset index) ,lowtag)
376          (move result value)))))
377
378
379 (defmacro define-partial-reffer (name type size signed offset lowtag scs
380                                       el-type &optional translate)
381   (let ((scale (ecase size (:byte 1) (:short 2))))
382     `(progn
383        (define-vop (,name)
384          ,@(when translate
385              `((:translate ,translate)))
386          (:policy :fast-safe)
387          (:args (object :scs (descriptor-reg))
388                 (index :scs (unsigned-reg)))
389          (:arg-types ,type positive-fixnum)
390          (:results (value :scs ,scs))
391          (:result-types ,el-type)
392          (:temporary (:scs (interior-reg)) lip)
393          (:generator 5
394            (inst addu lip object index)
395            ,@(when (eq size :short)
396                '((inst addu lip index)))
397            (inst ,(ecase size
398                     (:byte (if signed 'lb 'lbu))
399                     (:short (if signed 'lh 'lhu)))
400                  value lip (- (* ,offset n-word-bytes) ,lowtag))
401            (inst nop)))
402        (define-vop (,(symbolicate name "-C"))
403          ,@(when translate
404              `((:translate ,translate)))
405          (:policy :fast-safe)
406          (:args (object :scs (descriptor-reg)))
407          (:info index)
408          (:arg-types ,type
409                      (:constant (load/store-index ,scale
410                                                   ,(eval lowtag)
411                                                   ,(eval offset))))
412          (:results (value :scs ,scs))
413          (:result-types ,el-type)
414          (:generator 4
415            (inst ,(ecase size
416                     (:byte (if signed 'lb 'lbu))
417                     (:short (if signed 'lh 'lhu)))
418                  value object
419                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
420            (inst nop))))))
421
422 (defmacro define-partial-setter (name type size offset lowtag scs el-type
423                                       &optional translate)
424   (let ((scale (ecase size (:byte 1) (:short 2))))
425     `(progn
426        (define-vop (,name)
427          ,@(when translate
428              `((:translate ,translate)))
429          (:policy :fast-safe)
430          (:args (object :scs (descriptor-reg))
431                 (index :scs (unsigned-reg))
432                 (value :scs ,scs :target result))
433          (:arg-types ,type positive-fixnum ,el-type)
434          (:temporary (:scs (interior-reg)) lip)
435          (:results (result :scs ,scs))
436          (:result-types ,el-type)
437          (:generator 5
438            (inst addu lip object index)
439            ,@(when (eq size :short)
440                '((inst addu lip index)))
441            (inst ,(ecase size (:byte 'sb) (:short 'sh))
442                  value lip (- (* ,offset n-word-bytes) ,lowtag))
443            (move result value)))
444        (define-vop (,(symbolicate name "-C"))
445          ,@(when translate
446              `((:translate ,translate)))
447          (:policy :fast-safe)
448          (:args (object :scs (descriptor-reg))
449                 (value :scs ,scs :target result))
450          (:info index)
451          (:arg-types ,type
452                      (:constant (load/store-index ,scale
453                                                   ,(eval lowtag)
454                                                   ,(eval offset)))
455                      ,el-type)
456          (:results (result :scs ,scs))
457          (:result-types ,el-type)
458          (:generator 4
459            (inst ,(ecase size (:byte 'sb) (:short 'sh))
460                  value object
461                  (- (+ (* ,offset n-word-bytes) (* index ,scale)) ,lowtag))
462            (move result value))))))
463
464
465 (def!macro with-pinned-objects ((&rest objects) &body body)
466   "Arrange with the garbage collector that the pages occupied by
467 OBJECTS will not be moved in memory for the duration of BODY.
468 Useful for e.g. foreign calls where another thread may trigger
469 garbage collection.  This is currently implemented by disabling GC"
470   (declare (ignore objects))            ;should we eval these for side-effect?
471   `(without-gcing
472     ,@body))