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