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
(: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
) old-fp
)
25 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
))
28 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
31 (defun static-fun-template-name (num-args num-results
)
32 (intern (format nil
"~:@(~R-arg-~R-result-static-fun~)"
33 num-args num-results
)))
36 (defun moves (dst src
)
38 (do ((dst dst
(cdr dst
))
40 ((or (null dst
) (null src
)))
41 (moves `(move ,(car dst
) ,(car src
))))
44 (defun static-fun-template-vop (num-args num-results
)
45 (unless (and (<= num-args register-arg-count
)
46 (<= num-results register-arg-count
))
47 (error "either too many args (~W) or too many results (~W); max = ~W"
48 num-args num-results register-arg-count
))
49 (let ((num-temps (max num-args num-results
)))
50 (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
51 (dotimes (i num-results
)
52 (let ((result-name (intern (format nil
"RESULT-~D" i
))))
53 (result-names result-name
)
54 (results `(,result-name
:scs
(any-reg descriptor-reg
)))))
55 (dotimes (i num-temps
)
56 (let ((temp-name (intern (format nil
"TEMP-~D" i
))))
57 (temp-names temp-name
)
58 (temps `(:temporary
(:sc descriptor-reg
59 :offset
,(nth i
*register-arg-offsets
*)
60 ,@(when (< i num-args
)
61 `(:from
(:argument
,i
)))
62 ,@(when (< i num-results
)
64 :target
,(nth i
(result-names)))))
67 (let ((arg-name (intern (format nil
"ARG-~D" i
))))
70 :scs
(any-reg descriptor-reg
)
71 :target
,(nth i
(temp-names))))))
72 `(define-vop (,(static-fun-template-name num-args num-results
)
76 (:results
,@(results))
77 (:generator
,(+ 50 num-args num-results
)
78 (let ((lra-label (gen-label))
79 (cur-nfp (current-nfp-tn vop
)))
80 ,@(moves (temp-names) (arg-names))
81 (inst lwz entry-point null-tn
(static-fun-offset symbol
))
82 (inst lr nargs
(fixnumize ,num-args
))
84 (store-stack-tn nfp-save cur-nfp
))
85 (inst mr old-fp cfp-tn
)
86 (inst mr cfp-tn csp-tn
)
87 (inst compute-lra-from-code lra code-tn lra-label temp
)
88 (note-this-location vop
:call-site
)
89 ;(inst mr code-tn func)
90 (inst mtctr entry-point
)
92 (emit-return-pc lra-label
)
93 ,(collect ((bindings) (links))
94 (do ((temp (temp-names) (cdr temp
))
95 (name 'values
(gensym))
100 (make-tn-ref ,(car temp
) nil
)))
102 (links `(setf (tn-ref-across ,prev
) ,name
))))
105 (default-unknown-values vop
106 ,(if (zerop num-results
) nil
'values
)
107 ,num-results move-temp temp lra-label
)))
109 (load-stack-tn cur-nfp nfp-save
))
110 ,@(moves (result-names) (temp-names))))))))
115 (macrolet ((frob (num-args num-res
)
116 (static-fun-template-vop (eval num-args
) (eval num-res
))))
124 (defmacro define-static-fun
(name args
&key
(results '(x)) translate
125 policy cost arg-types result-types
)
127 ,(static-fun-template-name (length args
)
130 (:note
,(format nil
"static-fun ~@(~S~)" name
))
132 `((:translate
,translate
)))
134 `((:policy
,policy
)))
136 `((:generator-cost
,cost
)))
138 `((:arg-types
,@arg-types
)))
140 `((:result-types
,@result-types
)))))