0.6.11.7:
[sbcl.git] / src / compiler / vmdef.lisp
1 ;;;; implementation-independent facilities used for defining the
2 ;;;; compiler's interface to the VM in a given implementation
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!C")
14
15 ;;; Return the template having the specified name, or die trying.
16 (defun template-or-lose (x)
17   (the template
18        (or (gethash x *backend-template-names*)
19            (error "~S is not a defined template." x))))
20
21 ;;; Return the SC structure, SB structure or SC number corresponding
22 ;;; to a name, or die trying.
23 (defun sc-or-lose (x)
24   (the sc
25        (or (gethash x *backend-sc-names*)
26            (error "~S is not a defined storage class." x))))
27 (defun sb-or-lose (x)
28   (the sb
29        (or (gethash x *backend-sb-names*)
30            (error "~S is not a defined storage base." x))))
31 (defun sc-number-or-lose (x)
32   (the sc-number (sc-number (sc-or-lose x))))
33
34 ;;; Like the non-meta versions, but go for the meta-compile-time info.
35 ;;; These should not be used after load time, since compiling the compiler
36 ;;; changes the definitions.
37 (defun meta-sc-or-lose (x)
38   (the sc
39        (or (gethash x *backend-meta-sc-names*)
40            (error "~S is not a defined storage class." x))))
41 (defun meta-sb-or-lose (x)
42   (the sb
43        (or (gethash x *backend-meta-sb-names*)
44            (error "~S is not a defined storage base." x))))
45 (defun meta-sc-number-or-lose (x)
46   (the sc-number (sc-number (meta-sc-or-lose x))))
47 \f
48 ;;;; side-effect classes
49
50 (def-boolean-attribute vop
51   any)
52 \f
53 ;;;; move/coerce definition
54
55 ;;; Compute at compiler load time the costs for moving between all SCs that
56 ;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
57 (defun compute-move-costs (from-sc to-sc cost)
58   (declare (type sc from-sc to-sc) (type index cost))
59   (let ((to-scn (sc-number to-sc))
60         (from-costs (sc-load-costs from-sc)))
61     (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
62       (let ((vec (sc-move-costs dest-sc))
63             (dest-costs (sc-load-costs dest-sc)))
64         (setf (svref vec (sc-number from-sc)) cost)
65         (dolist (sc (append (sc-alternate-scs from-sc)
66                             (sc-constant-scs from-sc)))
67           (let* ((scn (sc-number sc))
68                  (total (+ (svref from-costs scn)
69                            (svref dest-costs to-scn)
70                            cost))
71                  (old (svref vec scn)))
72             (unless (and old (< old total))
73               (setf (svref vec scn) total))))))))
74 \f
75 ;;;; primitive type definition
76
77 ;;; Return the primitive type corresponding to the specified name, or
78 ;;; die trying.
79 (defun primitive-type-or-lose (name)
80   (the primitive-type
81        (or (gethash name *backend-primitive-type-names*)
82            (error "~S is not a defined primitive type." name))))
83
84 ;;; Return true if SC is either one of PTYPE's SC's, or one of those
85 ;;; SC's alternate or constant SCs.
86 (defun sc-allowed-by-primitive-type (sc ptype)
87   (declare (type sc sc) (type primitive-type ptype))
88   (let ((scn (sc-number sc)))
89     (dolist (allowed (primitive-type-scs ptype) nil)
90       (when (eql allowed scn)
91         (return t))
92       (let ((allowed-sc (svref *backend-sc-numbers* allowed)))
93         (when (or (member sc (sc-alternate-scs allowed-sc))
94                   (member sc (sc-constant-scs allowed-sc)))
95           (return t))))))
96 \f
97 ;;;; generation of emit functions
98
99 (eval-when (:compile-toplevel :load-toplevel :execute)
100   ;; We need the EVAL-WHEN because %EMIT-GENERIC-VOP (below)
101   ;; uses #.MAX-VOP-TN-REFS, not just MAX-VOP-TN-REFS.
102   ;; -- AL 20010218
103   (defconstant max-vop-tn-refs 256))
104
105 (defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
106 (defvar *using-vop-tn-refs* nil)
107
108 (defun flush-vop-tn-refs ()
109   (unless *using-vop-tn-refs*
110     (fill *vop-tn-refs* nil)))
111
112 (pushnew 'flush-vop-tn-refs *before-gc-hooks*)
113
114 (defconstant sc-bits (integer-length (1- sc-number-limit)))
115
116 (defun emit-generic-vop (node block template args results &optional info)
117   (%emit-generic-vop node block template args results info))
118
119 (defun %emit-generic-vop (node block template args results info)
120   (let* ((vop (make-vop block node template args results))
121          (num-args (vop-info-num-args template))
122          (last-arg (1- num-args))
123          (num-results (vop-info-num-results template))
124          (num-operands (+ num-args num-results))
125          (last-result (1- num-operands))
126          (ref-ordering (vop-info-ref-ordering template)))
127     (declare (type vop vop)
128              (type (integer 0 #.max-vop-tn-refs)
129                    num-args num-results num-operands)
130              (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result))
131     (setf (vop-codegen-info vop) info)
132     (let ((refs *vop-tn-refs*)
133           (*using-vop-tn-refs* t))
134       (declare (type (simple-vector #.max-vop-tn-refs) refs))
135       (do ((index 0 (1+ index))
136            (ref args (and ref (tn-ref-across ref))))
137           ((= index num-args))
138         (setf (svref refs index) ref))
139       (do ((index num-args (1+ index))
140            (ref results (and ref (tn-ref-across ref))))
141           ((= index num-operands))
142         (setf (svref refs index) ref))
143       (let ((temps (vop-info-temps template)))
144         (when temps
145           (let ((index num-operands)
146                 (prev nil))
147             (dotimes (i (length temps))
148               (let* ((temp (aref temps i))
149                      (tn (if (logbitp 0 temp)
150                              (make-wired-tn nil
151                                             (ldb (byte sc-bits 1) temp)
152                                             (ash temp (- (1+ sc-bits))))
153                              (make-restricted-tn nil (ash temp -1))))
154                      (write-ref (reference-tn tn t)))
155                 (setf (aref refs index) (reference-tn tn nil))
156                 (setf (aref refs (1+ index)) write-ref)
157                 (if prev
158                     (setf (tn-ref-across prev) write-ref)
159                     (setf (vop-temps vop) write-ref))
160                 (setf prev write-ref)
161                 (incf index 2))))))
162       (let ((prev nil))
163         (flet ((add-ref (ref)
164                  (setf (tn-ref-vop ref) vop)
165                  (setf (tn-ref-next-ref ref) prev)
166                  (setf prev ref)))
167           (declare (inline add-ref))
168           (dotimes (i (length ref-ordering))
169             (let* ((index (aref ref-ordering i))
170                    (ref (aref refs index)))
171               (if (or (= index last-arg) (= index last-result))
172                   (do ((ref ref (tn-ref-across ref)))
173                       ((null ref))
174                     (add-ref ref))
175                   (add-ref ref)))))
176         (setf (vop-refs vop) prev))
177       (let ((targets (vop-info-targets template)))
178         (when targets
179           (dotimes (i (length targets))
180             (let ((target (aref targets i)))
181               (target-if-desirable (aref refs (ldb (byte 8 8) target))
182                                    (aref refs (ldb (byte 8 0) target))))))))
183     (values vop vop)))
184 \f
185 ;;;; function translation stuff
186
187 ;;; Add Template into List, removing any old template with the same name.
188 ;;; We also maintain the increasing cost ordering.
189 (defun adjoin-template (template list)
190   (declare (type template template) (list list))
191   (sort (cons template
192               (remove (template-name template) list
193                       :key #'template-name))
194         #'<=
195         :key #'template-cost))
196 \f
197 ;;; Return a function type specifier describing Template's type computed
198 ;;; from the operand type restrictions.
199 (defun template-type-specifier (template)
200   (declare (type template template))
201   (flet ((convert (types more-types)
202            (flet ((frob (x)
203                     (if (eq x '*)
204                         't
205                         (ecase (first x)
206                           (:or `(or ,@(mapcar #'(lambda (type)
207                                                   (type-specifier
208                                                    (primitive-type-type
209                                                     type)))
210                                               (rest x))))
211                           (:constant `(constant-argument ,(third x)))))))
212              `(,@(mapcar #'frob types)
213                ,@(when more-types
214                    `(&rest ,(frob more-types)))))))
215     (let* ((args (convert (template-arg-types template)
216                           (template-more-args-type template)))
217            (result-restr (template-result-types template))
218            (results (if (eq result-restr :conditional)
219                         '(boolean)
220                         (convert result-restr
221                                  (cond ((template-more-results-type template))
222                                        ((/= (length result-restr) 1) '*)
223                                        (t nil))))))
224       `(function ,args
225                  ,(if (= (length results) 1)
226                       (first results)
227                       `(values ,@results))))))