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