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
) ocfp
)
25 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
))
27 (eval-when (: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 (src dst
)
35 (do ((dst dst
(cdr dst
))
37 ((or (null dst
) (null src
)))
38 (moves `(move ,(car src
) ,(car dst
))))
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 null zero
)
68 :target
,(nth i
(temp-names))))))
69 `(define-vop (,(static-fun-template-name num-args num-results
)
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
)
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))
95 (make-tn-ref ,(car temp
) nil
)))
97 (links `(setf (tn-ref-across ,prev
) ,name
))))
100 (default-unknown-values vop
101 ,(if (zerop num-results
) nil
'values
)
102 ,num-results move-temp temp lra-label
)))
104 (maybe-load-stack-nfp-tn cur-nfp nfp-save temp
))
105 ,@(moves (temp-names) (result-names))))))))
110 (collect ((templates (list 'progn
)))
111 (dotimes (i register-arg-count
)
112 (templates (static-fun-template-vop i
1)))
115 (defmacro define-static-fun
(name args
&key
(results '(x)) translate
116 policy cost arg-types result-types
)
118 ,(static-fun-template-name (length args
)
121 (:note
,(format nil
"static-fun ~@(~S~)" name
))
123 `((:translate
,translate
)))
125 `((:policy
,policy
)))
127 `((:generator-cost
,cost
)))
129 `((:arg-types
,@arg-types
)))
131 `((:result-types
,@result-types
)))))