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 descriptor-reg :offset fdefn-offset) fdefn)
23 (:temporary (:scs (descriptor-reg)) function)
24 (:temporary (:sc interior-reg :offset lip-offset) entry-point)
25 (:temporary (:sc any-reg :offset nargs-offset) nargs)
26 (:temporary (:sc any-reg :offset ocfp-offset) old-fp)
27 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save))
30 (eval-when (:compile-toplevel :load-toplevel :execute)
33 (defun static-fun-template-name (num-args num-results)
34 (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
35 num-args num-results)))
38 (defun moves (dst src)
40 (do ((dst dst (cdr dst))
42 ((or (null dst) (null src)))
43 (moves `(move ,(car dst) ,(car src))))
46 (defun static-fun-template-vop (num-args num-results)
47 (unless (and (<= num-args register-arg-count)
48 (<= num-results register-arg-count))
49 (error "either too many args (~W) or too many results (~W); max = ~W"
50 num-args num-results register-arg-count))
51 (let ((num-temps (max num-args num-results)))
52 (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
53 (dotimes (i num-results)
54 (let ((result-name (intern (format nil "RESULT-~D" i))))
55 (result-names result-name)
56 (results `(,result-name :scs (any-reg descriptor-reg)))))
57 (dotimes (i num-temps)
58 (let ((temp-name (intern (format nil "TEMP-~D" i))))
59 (temp-names temp-name)
60 (temps `(:temporary (:sc descriptor-reg
61 :offset ,(nth i *register-arg-offsets*)
62 ,@(when (< i num-args)
63 `(:from (:argument ,i)))
64 ,@(when (< i num-results)
66 :target ,(nth i (result-names)))))
69 (let ((arg-name (intern (format nil "ARG-~D" i))))
72 :scs (any-reg descriptor-reg)
73 :target ,(nth i (temp-names))))))
74 `(define-vop (,(static-fun-template-name num-args num-results)
78 (:results ,@(results))
79 (:generator ,(+ 50 num-args num-results)
80 (let ((lra-label (gen-label))
81 (cur-nfp (current-nfp-tn vop)))
82 ,@(moves (temp-names) (arg-names))
83 (inst addi fdefn null-tn (static-fdefn-offset symbol))
84 (loadw function fdefn fdefn-fun-slot other-pointer-lowtag)
85 (loadw entry-point fdefn fdefn-raw-addr-slot other-pointer-lowtag)
86 (inst lr nargs (fixnumize ,num-args))
88 (store-stack-tn nfp-save cur-nfp))
89 (inst mr old-fp cfp-tn)
90 (inst mr cfp-tn csp-tn)
91 (inst compute-lra-from-code lra code-tn lra-label temp)
92 (note-this-location vop :call-site)
93 ;(inst mr code-tn func)
94 (inst mtctr entry-point)
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 lra-label)))
113 (load-stack-tn cur-nfp nfp-save))
114 ,@(moves (result-names) (temp-names))))))))
119 (macrolet ((frob (num-args num-res)
120 (static-fun-template-vop (eval num-args) (eval num-res))))
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)))))