cleanup: partial long cleanup in sniff_code_object and gencgc_apply_code_fixups
[sbcl.git] / src / compiler / alpha / static-fn.lisp
1 ;;;; VOPs and macro magic for calling static functions
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 (define-vop (static-fun-template)
15   (:save-p t)
16   (:policy :safe)
17   (:variant-vars symbol)
18   (:vop-var vop)
19   (:temporary (:scs (non-descriptor-reg)) temp)
20   (:temporary (:scs (descriptor-reg)) move-temp)
21   (:temporary (:sc descriptor-reg :offset lra-offset) lra)
22   (:temporary (:sc interior-reg :offset lip-offset) entry-point)
23   (:temporary (:sc any-reg :offset nargs-offset) nargs)
24   (:temporary (:sc any-reg :offset ocfp-offset) ocfp)
25   (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
26
27 (eval-when  (:compile-toplevel :load-toplevel :execute)
28
29 (defun static-fun-template-name (num-args num-results)
30   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
31                   num-args num-results)))
32
33 (defun moves (src dst)
34   (collect ((moves))
35     (do ((dst dst (cdr dst))
36          (src src (cdr src)))
37         ((or (null dst) (null src)))
38       (moves `(move ,(car src) ,(car dst))))
39     (moves)))
40
41 (defun static-fun-template-vop (num-args num-results)
42   (unless (and (<= num-args register-arg-count)
43                (<= num-results register-arg-count))
44     (error "either too many args (~W) or too many results (~W); max = ~W"
45            num-args num-results register-arg-count))
46   (let ((num-temps (max num-args num-results)))
47     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
48       (dotimes (i num-results)
49         (let ((result-name (intern (format nil "RESULT-~D" i))))
50           (result-names result-name)
51           (results `(,result-name :scs (any-reg descriptor-reg)))))
52       (dotimes (i num-temps)
53         (let ((temp-name (intern (format nil "TEMP-~D" i))))
54           (temp-names temp-name)
55           (temps `(:temporary (:sc descriptor-reg
56                                :offset ,(nth i *register-arg-offsets*)
57                                ,@(when (< i num-args)
58                                    `(:from (:argument ,i)))
59                                ,@(when (< i num-results)
60                                    `(:to (:result ,i)
61                                      :target ,(nth i (result-names)))))
62                               ,temp-name))))
63       (dotimes (i num-args)
64         (let ((arg-name (intern (format nil "ARG-~D" i))))
65           (arg-names arg-name)
66           (args `(,arg-name
67                   :scs (any-reg descriptor-reg null zero)
68                   :target ,(nth i (temp-names))))))
69       `(define-vop (,(static-fun-template-name num-args num-results)
70                     static-fun-template)
71          (:args ,@(args))
72          ,@(temps)
73          (:results ,@(results))
74          (:generator ,(+ 50 num-args num-results)
75            (let ((lra-label (gen-label))
76                  (cur-nfp (current-nfp-tn vop)))
77              ,@(moves (arg-names) (temp-names))
78              (inst li (fixnumize ,num-args) nargs)
79              (inst ldl entry-point (static-fun-offset symbol) null-tn)
80              (when cur-nfp
81                (store-stack-tn nfp-save cur-nfp))
82              (inst move cfp-tn ocfp)
83              (inst compute-lra-from-code lra code-tn lra-label temp)
84              (note-this-location vop :call-site)
85              (inst move csp-tn cfp-tn)
86              (inst jsr zero-tn entry-point)
87              (emit-return-pc lra-label)
88              ,(collect ((bindings) (links))
89                 (do ((temp (temp-names) (cdr temp))
90                      (name 'values (gensym))
91                      (prev nil name)
92                      (i 0 (1+ i)))
93                     ((= i num-results))
94                   (bindings `(,name
95                               (make-tn-ref ,(car temp) nil)))
96                   (when prev
97                     (links `(setf (tn-ref-across ,prev) ,name))))
98                 `(let ,(bindings)
99                    ,@(links)
100                    (default-unknown-values vop
101                        ,(if (zerop num-results) nil 'values)
102                        ,num-results move-temp temp lra-label)))
103              (when cur-nfp
104                (maybe-load-stack-nfp-tn cur-nfp nfp-save temp))
105              ,@(moves (temp-names) (result-names))))))))
106
107 ) ; EVAL-WHEN
108
109 (expand
110  (collect ((templates (list 'progn)))
111    (dotimes (i register-arg-count)
112      (templates (static-fun-template-vop i 1)))
113    (templates)))
114
115 (defmacro define-static-fun (name args &key (results '(x)) translate
116                                        policy cost arg-types result-types)
117   `(define-vop (,name
118                 ,(static-fun-template-name (length args)
119                                            (length results)))
120      (:variant ',name)
121      (:note ,(format nil "static-fun ~@(~S~)" name))
122      ,@(when translate
123          `((:translate ,translate)))
124      ,@(when policy
125          `((:policy ,policy)))
126      ,@(when cost
127          `((:generator-cost ,cost)))
128      ,@(when arg-types
129          `((:arg-types ,@arg-types)))
130      ,@(when result-types
131          `((:result-types ,@result-types)))))