Pack (mostly) stack TNs according to lexical scope information
[sbcl.git] / src / compiler / sparc / static-fn.lisp
1 ;;;; VOPs and macro magic for calling static functions
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13
14 (define-vop (static-fun-template)
15   (:save-p t)
16   (:policy :safe)
17   (:variant-vars symbol)
18   (:vop-var vop)
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 (:scs (descriptor-reg)) func)
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))
26
27
28 (eval-when (:compile-toplevel :load-toplevel :execute)
29
30 (defun static-fun-template-name (num-args num-results)
31   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
32                   num-args num-results)))
33
34 (defun moves (dst src)
35   (collect ((moves))
36     (do ((dst dst (cdr dst))
37          (src src (cdr src)))
38         ((or (null dst) (null src)))
39       (moves `(move ,(car dst) ,(car src))))
40     (moves)))
41
42 (defun static-fun-template-vop (num-args num-results)
43   (unless (and (<= num-args register-arg-count)
44                (<= num-results register-arg-count))
45     (error "either too many args (~W) or too many results (~W); max = ~W"
46            num-args num-results register-arg-count))
47   (let ((num-temps (max num-args num-results)))
48     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
49       (dotimes (i num-results)
50         (let ((result-name (intern (format nil "RESULT-~D" i))))
51           (result-names result-name)
52           (results `(,result-name :scs (any-reg descriptor-reg)))))
53       (dotimes (i num-temps)
54         (let ((temp-name (intern (format nil "TEMP-~D" i))))
55           (temp-names temp-name)
56           (temps `(:temporary (:sc descriptor-reg
57                                :offset ,(nth i *register-arg-offsets*)
58                                ,@(when (< i num-args)
59                                    `(:from (:argument ,i)))
60                                ,@(when (< i num-results)
61                                    `(:to (:result ,i)
62                                      :target ,(nth i (result-names)))))
63                               ,temp-name))))
64       (dotimes (i num-args)
65         (let ((arg-name (intern (format nil "ARG-~D" i))))
66           (arg-names arg-name)
67           (args `(,arg-name
68                   :scs (any-reg descriptor-reg)
69                   :target ,(nth i (temp-names))))))
70       `(define-vop (,(static-fun-template-name num-args num-results)
71                     static-fun-template)
72          (:args ,@(args))
73          ,@(temps)
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 ld func null-tn (static-fun-offset symbol))
80              (inst li nargs (fixnumize ,num-args))
81              (when cur-nfp
82                (store-stack-tn nfp-save cur-nfp))
83              (inst move old-fp cfp-tn)
84              (inst move cfp-tn csp-tn)
85              (inst compute-lra-from-code lra code-tn lra-label temp)
86              (note-this-location vop :call-site)
87              (inst j func (- (ash simple-fun-code-offset word-shift)
88                              fun-pointer-lowtag))
89              (inst move code-tn func)
90              (emit-return-pc lra-label)
91              ,(collect ((bindings) (links))
92                 (do ((temp (temp-names) (cdr temp))
93                      (name 'values (gensym))
94                      (prev nil name)
95                      (i 0 (1+ i)))
96                     ((= i num-results))
97                   (bindings `(,name
98                               (make-tn-ref ,(car temp) nil)))
99                   (when prev
100                     (links `(setf (tn-ref-across ,prev) ,name))))
101                 `(let ,(bindings)
102                    ,@(links)
103                    (default-unknown-values vop
104                        ,(if (zerop num-results) nil 'values)
105                        ,num-results move-temp temp lra-label)))
106              (when cur-nfp
107                (load-stack-tn cur-nfp nfp-save))
108              ,@(moves (result-names) (temp-names))))))))
109
110
111 ) ; EVAL-WHEN
112
113
114 ;;; FIXME! This looks like a candidate for a dotimes to
115 ;;; register-arg-count.
116 (macrolet ((frob (num-args num-res)
117              (static-fun-template-vop (eval num-args) (eval num-res))))
118   (frob 0 1)
119   (frob 1 1)
120   (frob 2 1)
121   (frob 3 1)
122   (frob 4 1)
123   (frob 5 1))
124
125 (defmacro define-static-fun (name args &key (results '(x)) translate
126                              policy cost arg-types result-types)
127   `(define-vop (,name
128                 ,(static-fun-template-name (length args)
129                                            (length results)))
130      (:variant ',name)
131      (:note ,(format nil "static-fun ~@(~S~)" name))
132      ,@(when translate
133          `((:translate ,translate)))
134      ,@(when policy
135          `((:policy ,policy)))
136      ,@(when cost
137          `((:generator-cost ,cost)))
138      ,@(when arg-types
139          `((:arg-types ,@arg-types)))
140      ,@(when result-types
141          `((:result-types ,@result-types)))))