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