26ac591d632c6ed3a9313500bf7f0da082cac9a2
[sbcl.git] / src / compiler / alpha / macros.lisp
1 ;;;; various useful macros for generating Alpha 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
12 (in-package "SB!VM")
13
14 ;;; a handy macro for defining top-level forms that depend on the
15 ;;; compile environment
16 (defmacro expand (expr)
17   (let ((gensym (gensym)))
18     `(macrolet
19          ((,gensym ()
20             ,expr))
21        (,gensym))))
22 \f
23 ;;; instruction-like macros
24
25 ;;; c.f. x86 backend:
26 ;;(defmacro move (dst src)
27 ;;  #!+sb-doc
28 ;;  "Move SRC into DST unless they are location=."
29 ;;  (once-only ((n-dst dst)
30 ;;              (n-src src))
31 ;;    `(unless (location= ,n-dst ,n-src)
32 ;;       (inst mov ,n-dst ,n-src))))
33
34 (defmacro move (src dst)
35   "Move SRC into DST unless they are location=."
36   (once-only ((n-src src) (n-dst dst))
37     `(unless (location= ,n-src ,n-dst)
38        (inst move ,n-src ,n-dst))))
39
40 (defmacro loadw (result base &optional (offset 0) (lowtag 0))
41   (once-only ((result result) (base base))
42     `(inst ldl ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
43
44 (defmacro loadq (result base &optional (offset 0) (lowtag 0))
45   (once-only ((result result) (base base))
46     `(inst ldq ,result (- (ash ,offset word-shift) ,lowtag) ,base)))
47
48 (defmacro storew (value base &optional (offset 0) (lowtag 0))
49   (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
50     `(inst stl ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
51
52 (defmacro storeq (value base &optional (offset 0) (lowtag 0))
53   (once-only ((value value) (base base) (offset offset) (lowtag lowtag))
54     `(inst stq ,value (- (ash ,offset word-shift) ,lowtag) ,base)))
55
56 (defmacro load-symbol (reg symbol)
57   (once-only ((reg reg) (symbol symbol))
58     `(inst lda ,reg (static-symbol-offset ,symbol) null-tn)))
59
60 (defmacro load-symbol-value (reg symbol)
61   `(inst ldl ,reg
62          (+ (static-symbol-offset ',symbol)
63             (ash symbol-value-slot word-shift)
64             (- other-pointer-lowtag))
65          null-tn))
66
67 (defmacro store-symbol-value (reg symbol)
68   `(inst stl ,reg
69          (+ (static-symbol-offset ',symbol)
70             (ash symbol-value-slot word-shift)
71             (- other-pointer-lowtag))
72          null-tn))
73
74 (defmacro load-type (target source &optional (offset 0))
75   "Loads the type bits of a pointer into target independent of
76   byte-ordering issues."
77   (once-only ((n-target target)
78               (n-source source)
79               (n-offset offset))
80      `(progn
81         (inst ldl ,n-target ,n-offset ,n-source)
82         (inst and ,n-target #xff ,n-target))))
83
84 ;;; macros to handle the fact that we cannot use the machine native
85 ;;; call and return instructions
86
87 (defmacro lisp-jump (function lip)
88   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
89   `(progn
90      (inst lda ,lip (- (ash sb!vm:simple-fun-code-offset sb!vm:word-shift)
91                        sb!vm:fun-pointer-lowtag)
92             ,function)
93      (move ,function code-tn)
94      (inst jsr zero-tn ,lip 1)))
95
96 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
97   "Return to RETURN-PC.  LIP is an interior-reg temporary."
98   `(progn
99      (inst lda ,lip  
100            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)
101             ,return-pc)
102      ,@(when frob-code
103          `((move ,return-pc code-tn)))
104      (inst ret zero-tn ,lip 1)))
105
106
107 (defmacro emit-return-pc (label)
108   "Emit a return-pc header word.  LABEL is the label to use for this
109    return-pc."
110   `(progn
111      (align n-lowtag-bits)
112      (emit-label ,label)
113      (inst lra-header-word)))
114
115
116 \f
117 ;;;; stack TN's
118
119 ;;;    Move a stack TN to a register and vice-versa.
120 (defmacro load-stack-tn (reg stack)
121   `(let ((reg ,reg)
122          (stack ,stack))
123      (let ((offset (tn-offset stack)))
124        (sc-case stack
125          ((control-stack)
126           (loadw reg cfp-tn offset))))))
127 (defmacro store-stack-tn (stack reg)
128   `(let ((stack ,stack)
129          (reg ,reg))
130      (let ((offset (tn-offset stack)))
131        (sc-case stack
132          ((control-stack)
133           (storew reg cfp-tn offset))))))
134
135 ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
136 (defmacro maybe-load-stack-tn (reg reg-or-stack)
137   (once-only ((n-reg reg)
138               (n-stack reg-or-stack))
139     `(sc-case ,n-reg
140        ((any-reg descriptor-reg)
141         (sc-case ,n-stack
142           ((any-reg descriptor-reg)
143            (move ,n-stack ,n-reg))
144           ((control-stack)
145            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
146
147 ;;; Move the TN Reg-Or-Stack into Reg if it isn't already there.
148 (defmacro maybe-load-stack-nfp-tn (reg reg-or-stack temp)
149   (once-only ((n-reg reg)
150               (n-stack reg-or-stack))
151      `(when ,reg
152         (sc-case ,n-reg
153          ((any-reg descriptor-reg)
154           (sc-case ,n-stack
155            ((any-reg descriptor-reg)
156             (move ,n-stack ,n-reg))
157            ((control-stack)
158             (loadw ,n-reg cfp-tn (tn-offset ,n-stack))
159             (inst mskll nsp-tn 0 ,temp)
160             (inst bis ,temp ,n-reg ,n-reg))))))))
161 \f
162 ;;;; storage allocation
163
164 ;;; Do stuff to allocate an other-pointer object of fixed SIZE with a
165 ;;; single word header having the specified WIDETAG value. The result is
166 ;;; placed in RESULT-TN, Flag-Tn must be wired to NL3-OFFSET, and
167 ;;; Temp-TN is a non- descriptor temp (which may be randomly used by
168 ;;; the body.) The body is placed inside the PSEUDO-ATOMIC, and
169 ;;; presumably initializes the object.
170 (defmacro with-fixed-allocation ((result-tn temp-tn widetagsize)
171                                  &body body)
172   `(pseudo-atomic (:extra (pad-data-block ,size))
173      (inst bis alloc-tn other-pointer-lowtag ,result-tn)
174      (inst li (logior (ash (1- ,size) n-widetag-bits) ,widetag) ,temp-tn)
175      (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
176      ,@body))
177 \f
178 ;;;; error code
179
180 (defvar *adjustable-vectors* nil)
181
182 (defmacro with-adjustable-vector ((var) &rest body)
183   `(let ((,var (or (pop *adjustable-vectors*)
184                    (make-array 16
185                                :element-type '(unsigned-byte 8)
186                                :fill-pointer 0
187                                :adjustable t))))
188      (setf (fill-pointer ,var) 0)
189      (unwind-protect
190          (progn
191            ,@body)
192        (push ,var *adjustable-vectors*))))
193
194 (eval-when (:compile-toplevel :load-toplevel :execute) 
195   (defun emit-error-break (vop kind code values)
196     (let ((vector (gensym)))
197       `((let ((vop ,vop))
198           (when vop
199             (note-this-location vop :internal-error)))
200         (inst gentrap ,kind)
201         (with-adjustable-vector (,vector)
202           (write-var-integer (error-number-or-lose ',code) ,vector)
203           ,@(mapcar #'(lambda (tn)
204                         `(let ((tn ,tn))
205                            (write-var-integer (make-sc-offset (sc-number
206                                                                (tn-sc tn))
207                                                               (tn-offset tn))
208                                               ,vector)))
209                     values)
210           (inst byte (length ,vector))
211           (dotimes (i (length ,vector))
212             (inst byte (aref ,vector i))))
213         (align word-shift)))))
214
215 (defmacro error-call (vop error-code &rest values)
216   "Cause an error.  ERROR-CODE is the error to cause."
217   (cons 'progn
218         (emit-error-break vop error-trap error-code values)))
219
220
221 (defmacro cerror-call (vop label error-code &rest values)
222   "Cause a continuable error.  If the error is continued, execution resumes at
223   LABEL."
224   `(progn
225      (inst br zero-tn ,label)
226      ,@(emit-error-break vop cerror-trap error-code values)))
227
228 (defmacro generate-error-code (vop error-code &rest values)
229   "Generate-Error-Code Error-code Value*
230   Emit code for an error with the specified Error-Code and context Values."
231   `(assemble (*elsewhere*)
232      (let ((start-lab (gen-label)))
233        (emit-label start-lab)
234        (error-call ,vop ,error-code ,@values)
235        start-lab)))
236
237 (defmacro generate-cerror-code (vop error-code &rest values)
238   "Generate-CError-Code Error-code Value*
239   Emit code for a continuable error with the specified Error-Code and
240   context Values.  If the error is continued, execution resumes after
241   the GENERATE-CERROR-CODE form."
242   (let ((continue (gensym "CONTINUE-LABEL-"))
243         (error (gensym "ERROR-LABEL-")))
244     `(let ((,continue (gen-label)))
245        (emit-label ,continue)
246        (assemble (*elsewhere*)
247          (let ((,error (gen-label)))
248            (emit-label ,error)
249            (cerror-call ,vop ,continue ,error-code ,@values)
250            ,error)))))
251
252 \f
253 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
254 ;;;
255 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
256   `(progn
257      (inst addq alloc-tn 1 alloc-tn)
258      ,@forms
259      (inst lda alloc-tn (1- ,extra) alloc-tn)
260      (inst stl zero-tn 0 alloc-tn)))
261
262
263 \f
264 ;;;; Memory accessor vop generators
265
266 (deftype load/store-index (scale lowtag min-offset
267                                  &optional (max-offset min-offset))
268   `(integer ,(- (truncate (+ (ash 1 16)
269                              (* min-offset n-word-bytes)
270                              (- lowtag))
271                           scale))
272             ,(truncate (- (+ (1- (ash 1 16)) 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 addq object index lip)
291          (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
292          ,@(when (equal scs '(unsigned-reg))
293              '((inst mskll value 4 value)))))
294      (define-vop (,(symbolicate name "-C"))
295        ,@(when translate
296            `((:translate ,translate)))
297        (:policy :fast-safe)
298        (:args (object :scs (descriptor-reg)))
299        (:info index)
300        (:arg-types ,type
301                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
302                                                 ,(eval offset))))
303        (:results (value :scs ,scs))
304        (:result-types ,el-type)
305        (:generator 4
306          (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
307                object)
308          ,@(when (equal scs '(unsigned-reg))
309              '((inst mskll value 4 value)))))))
310
311 (defmacro define-full-setter (name type offset lowtag scs el-type
312                                    &optional translate #+gengc (remember t))
313   `(progn
314      (define-vop (,name)
315        ,@(when translate
316            `((:translate ,translate)))
317        (:policy :fast-safe)
318        (:args (object :scs (descriptor-reg))
319               (index :scs (any-reg))
320               (value :scs ,scs :target result))
321        (:arg-types ,type tagged-num ,el-type)
322        (:temporary (:scs (interior-reg)) lip)
323        (:results (result :scs ,scs))
324        (:result-types ,el-type)
325        (:generator 2
326          (inst addq index object lip)
327          (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)
328          (move value result)))
329      (define-vop (,(symbolicate name "-C"))
330        ,@(when translate
331            `((:translate ,translate)))
332        (:policy :fast-safe)
333        (:args (object :scs (descriptor-reg))
334               (value :scs ,scs))
335        (:info index)
336        (:arg-types ,type
337                    (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
338                                                 ,(eval offset)))
339                    ,el-type)
340        (:results (result :scs ,scs))
341        (:result-types ,el-type)
342        (:generator 1
343          (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
344                object)
345          (move value result)))))
346
347
348 (defmacro define-partial-reffer (name type size signed offset lowtag scs
349                                       el-type &optional translate)
350   (let ((scale (ecase size (:byte 1) (:short 2))))
351     `(progn
352        (define-vop (,name)
353          ,@(when translate
354              `((:translate ,translate)))
355          (:policy :fast-safe)
356          (:args (object :scs (descriptor-reg))
357                 (index :scs (unsigned-reg)))
358          (:arg-types ,type positive-fixnum)
359          (:results (value :scs ,scs))
360          (:result-types ,el-type)
361          (:temporary (:scs (interior-reg)) lip)
362          (:temporary (:sc non-descriptor-reg) temp)
363          (:temporary (:sc non-descriptor-reg) temp1)
364          (:generator 5
365            (inst addq object index lip)
366            ,@(when (eq size :short)
367                '((inst addq index lip lip)))
368            ,@(ecase size
369                (:byte
370                 (if signed
371                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
372                             lip)
373                       (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
374                             lip)
375                       (inst extqh temp temp1 temp)
376                       (inst sra temp 56 value))
377                     `((inst ldq_u
378                             temp
379                             (- (* ,offset n-word-bytes) ,lowtag)
380                             lip)
381                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
382                                           lip)
383                       (inst extbl temp temp1 value))))
384                (:short
385                 (if signed
386                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
387                             lip)
388                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
389                             lip)
390                       (inst extwl temp temp1 temp)
391                       (inst sll temp 48 temp)
392                       (inst sra temp 48 value))
393                     `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
394                             lip)
395                       (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
396                       (inst extwl temp temp1 value)))))))
397        (define-vop (,(symbolicate name "-C"))
398          ,@(when translate
399              `((:translate ,translate)))
400          (:policy :fast-safe)
401          (:args (object :scs (descriptor-reg)))
402          (:info index)
403          (:arg-types ,type
404                      (:constant (load/store-index ,scale
405                                                   ,(eval lowtag)
406                                                   ,(eval offset))))
407          (:results (value :scs ,scs))
408          (:result-types ,el-type)
409          (:temporary (:sc non-descriptor-reg) temp)
410          (:temporary (:sc non-descriptor-reg) temp1)
411          (:generator 5
412            ,@(ecase size
413                (:byte
414                 (if signed
415                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
416                                              (* index ,scale)) ,lowtag)
417                             object)
418                       (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
419                                                 (* index ,scale)) ,lowtag))
420                             object)
421                       (inst extqh temp temp1 temp)
422                       (inst sra temp 56 value))
423                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
424                                              (* index ,scale)) ,lowtag)
425                             object)
426                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
427                                             (* index ,scale)) ,lowtag)
428                             object)
429                       (inst extbl temp temp1 value))))
430                (:short
431                 (if signed
432                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
433                                              (* index ,scale)) ,lowtag)
434                             object)
435                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
436                                             (* index ,scale)) ,lowtag)
437                             object)
438                       (inst extwl temp temp1 temp)
439                       (inst sll temp 48 temp)
440                       (inst sra temp 48 value))
441                     `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
442                                              (* index ,scale)) ,lowtag)
443                             object)
444                       (inst lda temp1 (- (+ (* ,offset n-word-bytes)
445                                             (* index ,scale)) ,lowtag)
446                             object)
447                       (inst extwl temp temp1 value))))))))))
448
449 (defmacro define-partial-setter (name type size offset lowtag scs el-type
450                                       &optional translate)
451   (let ((scale (ecase size (:byte 1) (:short 2))))
452     `(progn
453        (define-vop (,name)
454          ,@(when translate
455              `((:translate ,translate)))
456          (:policy :fast-safe)
457          (:args (object :scs (descriptor-reg))
458                 (index :scs (unsigned-reg))
459                 (value :scs ,scs :target result))
460          (:arg-types ,type positive-fixnum ,el-type)
461          (:temporary (:scs (interior-reg)) lip)
462          (:temporary (:sc non-descriptor-reg) temp)
463          (:temporary (:sc non-descriptor-reg) temp1)
464          (:temporary (:sc non-descriptor-reg) temp2)
465          (:results (result :scs ,scs))
466          (:result-types ,el-type)
467          (:generator 5
468            (inst addq object index lip)
469            ,@(when (eq size :short)
470                '((inst addq lip index lip)))
471            ,@(ecase size
472                (:byte
473                 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
474                   (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
475                   (inst insbl value  temp temp2)
476                   (inst mskbl temp1 temp temp1)
477                   (inst bis temp1 temp2 temp1)
478                   (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
479                (:short
480                 `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
481                   (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
482                   (inst mskwl temp1 temp temp1)
483                   (inst inswl value temp temp2)
484                   (inst bis temp1 temp2 temp)
485                   (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
486            (move value result)))
487        (define-vop (,(symbolicate name "-C"))
488          ,@(when translate
489              `((:translate ,translate)))
490          (:policy :fast-safe)
491          (:args (object :scs (descriptor-reg))
492                 (value :scs ,scs :target result))
493          (:info index)
494          (:arg-types ,type
495                      (:constant (load/store-index ,scale
496                                                   ,(eval lowtag)
497                                                   ,(eval offset)))
498                      ,el-type)
499          (:temporary (:sc non-descriptor-reg) temp)
500          (:temporary (:sc non-descriptor-reg) temp1)
501          (:temporary (:sc non-descriptor-reg) temp2)
502          (:results (result :scs ,scs))
503          (:result-types ,el-type)
504          (:generator 5
505            ,@(ecase size
506                (:byte
507                 `((inst lda temp (- (* ,offset n-word-bytes)
508                                     (* index ,scale) ,lowtag)
509                         object)
510                   (inst ldq_u temp1 (- (* ,offset n-word-bytes) 
511                                        (* index ,scale) ,lowtag)
512                         object)
513                   (inst insbl value temp temp2)
514                   (inst mskbl temp1 temp temp1)
515                   (inst bis temp1 temp2 temp1)
516                   (inst stq_u temp1 (- (* ,offset n-word-bytes)
517                                        (* index ,scale) ,lowtag) object)))
518                (:short
519                 `((inst lda temp (- (* ,offset n-word-bytes)
520                                     (* index ,scale) ,lowtag)
521                         object)
522                   (inst ldq_u temp1 (- (* ,offset n-word-bytes)
523                                        (* index ,scale) ,lowtag)
524                         object)
525                   (inst mskwl temp1 temp temp1)
526                   (inst inswl value temp temp2)
527                   (inst bis temp1 temp2 temp)
528                   (inst stq_u temp (- (* ,offset n-word-bytes)
529                                       (* index ,scale) ,lowtag) object))))
530            (move value result))))))