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