1 ;;;; VOPs and macro magic for calling static functions
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 (define-vop (static-fun-template)
17 (:variant-vars symbol
)
19 (:temporary
(:scs
(non-descriptor-reg)) temp
)
20 (:temporary
(:scs
(descriptor-reg)) move-temp
)
21 (:temporary
(:scs
(descriptor-reg)) function
)
22 (:temporary
(:sc any-reg
:offset nargs-offset
) nargs
)
23 (:temporary
(:sc interior-reg
) lip
)
24 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
))
27 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
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
)))
33 (defun moves (dst src
)
35 (do ((dst dst
(cdr dst
))
37 ((or (null dst
) (null src
)))
38 (moves `(move ,(car dst
) ,(car src
))))
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
)
61 :target
,(nth i
(result-names)))))
64 (let ((arg-name (intern (format nil
"ARG-~D" i
))))
67 :scs
(any-reg descriptor-reg
)
68 :target
,(nth i
(temp-names))))))
69 `(define-vop (,(static-fun-template-name num-args num-results
)
73 (:temporary
(:sc any-reg
) csp-temp
)
74 (:results
,@(results))
75 (:generator
,(+ 50 num-args num-results
)
76 (let ((lra-label (gen-label))
77 (cur-nfp (current-nfp-tn vop
)))
78 ,@(moves (temp-names) (arg-names))
79 (inst ldr function
(@ null-tn
(static-fun-offset symbol
)))
80 (inst mov nargs
(fixnumize ,num-args
))
82 (store-stack-tn nfp-save cur-nfp
))
83 ;; This is a somewhat ideosyncratic way to build a new
84 ;; stack frame, pushing a value and updating CSP, finding
85 ;; the new CFP, then pushing another value on CSP, but it
86 ;; works for this situation.
87 (inst compute-lra lip lip lra-label
)
89 (inst add csp-temp csp-temp
8)
91 (inst str cfp-tn
(@ csp-temp -
8))
92 (inst str lip
(@ csp-temp -
4))
93 (inst sub cfp-tn csp-temp
8)
94 (note-this-location vop
:call-site
)
96 (emit-return-pc lra-label
)
97 ,(collect ((bindings) (links))
98 (do ((temp (temp-names) (cdr temp
))
99 (name 'values
(gensym))
104 (make-tn-ref ,(car temp
) nil
)))
106 (links `(setf (tn-ref-across ,prev
) ,name
))))
109 (default-unknown-values vop
110 ,(if (zerop num-results
) nil
'values
)
111 ,num-results move-temp temp lip lra-label
)))
113 (load-stack-tn cur-nfp nfp-save
))
114 ,@(moves (result-names) (temp-names))))))))
120 (macrolet ((frob (num-args num-res
)
121 (static-fun-template-vop (eval num-args
) (eval num-res
))))
122 ;; Other backends cover options from zero through
123 ;; register-arg-count. It turns out, however, that only the 1 and 2
124 ;; arg cases are actually used.
128 (defmacro define-static-fun
(name args
&key
(results '(x)) translate
129 policy cost arg-types result-types
)
131 ,(static-fun-template-name (length args
)
134 (:note
,(format nil
"static-fun ~@(~S~)" name
))
136 `((:translate
,translate
)))
138 `((:policy
,policy
)))
140 `((:generator-cost
,cost
)))
142 `((:arg-types
,@arg-types
)))
144 `((:result-types
,@result-types
)))))