1.0.27.32: implement and use SB!XC:GENSYM
[sbcl.git] / src / compiler / x86 / static-fn.lisp
1 ;;;; the VOPs and macro magic required to call 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 function)
18   (:vop-var vop)
19   (:temporary (:sc unsigned-reg :offset ecx-offset
20                    :from (:eval 0) :to (:eval 2)) ecx))
21
22 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
23
24 (defun static-fun-template-name (num-args num-results)
25   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
26                   num-args num-results)))
27
28 (defun moves (dst src)
29   (collect ((moves))
30     (do ((dst dst (cdr dst))
31          (src src (cdr src)))
32         ((or (null dst) (null src)))
33       (moves `(move ,(car dst) ,(car src))))
34     (moves)))
35
36 (defun static-fun-template-vop (num-args num-results)
37   (unless (and (<= num-args register-arg-count)
38                (<= num-results register-arg-count))
39     (error "either too many args (~W) or too many results (~W); max = ~W"
40            num-args num-results register-arg-count))
41   (let ((num-temps (max num-args num-results))
42         (node (sb!xc:gensym "NODE")))
43     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
44       (dotimes (i num-results)
45         (let ((result-name (intern (format nil "RESULT-~D" i))))
46           (result-names result-name)
47           (results `(,result-name :scs (any-reg descriptor-reg)))))
48       (dotimes (i num-temps)
49         (let ((temp-name (intern (format nil "TEMP-~D" i))))
50           (temp-names temp-name)
51           (temps `(:temporary (:sc descriptor-reg
52                                :offset ,(nth i *register-arg-offsets*)
53                                :from ,(if (< i num-args)
54                                           `(:argument ,i)
55                                           '(:eval 1))
56                                :to ,(if (< i num-results)
57                                         `(:result ,i)
58                                         '(:eval 1))
59                                ,@(when (< i num-results)
60                                    `(:target ,(nth i (result-names)))))
61                               ,temp-name))))
62       (dotimes (i num-args)
63         (let ((arg-name (intern (format nil "ARG-~D" i))))
64           (arg-names arg-name)
65           (args `(,arg-name
66                   :scs (any-reg descriptor-reg)
67                   :target ,(nth i (temp-names))))))
68       `(define-vop (,(static-fun-template-name num-args num-results)
69                     static-fun-template)
70         (:args ,@(args))
71         ,@(temps)
72         (:results ,@(results))
73         (:node-var ,node)
74         (:generator ,(+ 50 num-args num-results)
75          ,@(moves (temp-names) (arg-names))
76
77          ;; If speed is at least as important as size, duplicate the
78          ;; effect of the ENTER with discrete instructions. Takes
79          ;; 3+4+4=11 bytes as opposed to 1+4=5 bytes.
80          (cond ((policy ,node (>= speed space))
81                 (inst sub esp-tn (fixnumize 3))
82                 (inst mov (make-ea :dword :base esp-tn
83                                    :disp (frame-byte-offset
84                                           (+ sp->fp-offset
85                                              -3
86                                              ocfp-save-offset)))
87                       ebp-tn)
88                 (inst lea ebp-tn (make-ea :dword :base esp-tn
89                                           :disp (frame-byte-offset
90                                                  (+ sp->fp-offset
91                                                     -3
92                                                     ocfp-save-offset)))))
93                (t
94                 ;; Dummy for return address.
95                 (inst push ebp-tn)
96                 (inst enter (fixnumize 1))))
97
98          ,(if (zerop num-args)
99               '(inst xor ecx ecx)
100               `(inst mov ecx (fixnumize ,num-args)))
101
102          (note-this-location vop :call-site)
103          ;; Old CMU CL comment:
104          ;;   STATIC-FUN-OFFSET gives the offset from the start of
105          ;;   the NIL object to the static function FDEFN and has the
106          ;;   low tag of 1 added. When the NIL symbol value with its
107          ;;   low tag of 3 is added the resulting value points to the
108          ;;   raw address slot of the fdefn (at +4).
109          ;; FIXME: Since the fork from CMU CL, we've swapped
110          ;; FUN-POINTER-LOWTAG and INSTANCE-POINTER-LOWTAG, so the
111          ;; text above is no longer right. Mysteriously, things still
112          ;; work. It would be good to explain why. (Is this code no
113          ;; longer executed? Does it not depend on the
114          ;; 1+3=4=fdefn_raw_address_offset relationship above?
115          ;; Is something else going on?)
116          (inst call (make-ea :dword
117                              :disp (+ nil-value
118                                       (static-fun-offset function))))
119          ,(collect ((bindings) (links))
120                    (do ((temp (temp-names) (cdr temp))
121                         (name 'values (gensym))
122                         (prev nil name)
123                         (i 0 (1+ i)))
124                        ((= i num-results))
125                      (bindings `(,name
126                                  (make-tn-ref ,(car temp) nil)))
127                      (when prev
128                        (links `(setf (tn-ref-across ,prev) ,name))))
129                    `(let ,(bindings)
130                      ,@(links)
131                      (default-unknown-values
132                          vop
133                          ,(if (zerop num-results) nil 'values)
134                        ,num-results
135                        ,node)))
136          ,@(moves (result-names) (temp-names)))))))
137
138 ) ; EVAL-WHEN
139
140 (macrolet ((frob (num-args num-res)
141              (static-fun-template-vop (eval num-args) (eval num-res))))
142   (frob 0 1)
143   (frob 1 1)
144   (frob 2 1)
145   (frob 3 1))
146
147 (defmacro define-static-fun (name args &key (results '(x)) translate
148                                   policy cost arg-types result-types)
149   `(define-vop (,name
150                 ,(static-fun-template-name (length args)
151                                            (length results)))
152      (:variant ',name)
153      (:note ,(format nil "static-fun ~@(~S~)" name))
154      ,@(when translate
155          `((:translate ,translate)))
156      ,@(when policy
157          `((:policy ,policy)))
158      ,@(when cost
159          `((:generator-cost ,cost)))
160      ,@(when arg-types
161          `((:arg-types ,@arg-types)))
162      ,@(when result-types
163          `((:result-types ,@result-types)))))