1 ;;;; implementation-independent facilities used for defining the
2 ;;;; compiler's interface to the VM in a given implementation
4 ;;;; This software is part of the SBCL system. See the README file for
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.
18 ;;; Return the template having the specified name, or die trying.
19 (defun template-or-lose (x)
21 (or (gethash x *backend-template-names*)
22 (error "~S is not a defined template." x))))
24 ;;; Return the SC structure, SB structure or SC number corresponding to a
25 ;;; name, or die trying.
28 (or (gethash x *backend-sc-names*)
29 (error "~S is not a defined storage class." x))))
32 (or (gethash x *backend-sb-names*)
33 (error "~S is not a defined storage base." x))))
34 (defun sc-number-or-lose (x)
35 (the sc-number (sc-number (sc-or-lose x))))
37 ;;; Like the non-meta versions, but go for the meta-compile-time info.
38 ;;; These should not be used after load time, since compiling the compiler
39 ;;; changes the definitions.
40 (defun meta-sc-or-lose (x)
42 (or (gethash x *backend-meta-sc-names*)
43 (error "~S is not a defined storage class." x))))
44 (defun meta-sb-or-lose (x)
46 (or (gethash x *backend-meta-sb-names*)
47 (error "~S is not a defined storage base." x))))
48 (defun meta-sc-number-or-lose (x)
49 (the sc-number (sc-number (meta-sc-or-lose x))))
51 ;;;; side-effect classes
53 (def-boolean-attribute vop
56 ;;;; move/coerce definition
58 ;;; Compute at compiler load time the costs for moving between all SCs that
59 ;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
60 (defun compute-move-costs (from-sc to-sc cost)
61 (declare (type sc from-sc to-sc) (type index cost))
62 (let ((to-scn (sc-number to-sc))
63 (from-costs (sc-load-costs from-sc)))
64 (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
65 (let ((vec (sc-move-costs dest-sc))
66 (dest-costs (sc-load-costs dest-sc)))
67 (setf (svref vec (sc-number from-sc)) cost)
68 (dolist (sc (append (sc-alternate-scs from-sc)
69 (sc-constant-scs from-sc)))
70 (let* ((scn (sc-number sc))
71 (total (+ (svref from-costs scn)
72 (svref dest-costs to-scn)
74 (old (svref vec scn)))
75 (unless (and old (< old total))
76 (setf (svref vec scn) total))))))))
78 ;;;; primitive type definition
80 ;;; Return the primitive type corresponding to the specified name, or die
82 (defun primitive-type-or-lose (name)
84 (or (gethash name *backend-primitive-type-names*)
85 (error "~S is not a defined primitive type." name))))
87 ;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
88 ;;; alternate or constant SCs.
89 (defun sc-allowed-by-primitive-type (sc ptype)
90 (declare (type sc sc) (type primitive-type ptype))
91 (let ((scn (sc-number sc)))
92 (dolist (allowed (primitive-type-scs ptype) nil)
93 (when (eql allowed scn)
95 (let ((allowed-sc (svref *backend-sc-numbers* allowed)))
96 (when (or (member sc (sc-alternate-scs allowed-sc))
97 (member sc (sc-constant-scs allowed-sc)))
100 ;;;; generation of emit functions
102 (defconstant max-vop-tn-refs 256)
104 (defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
105 (defvar *using-vop-tn-refs* nil)
107 (defun flush-vop-tn-refs ()
108 (unless *using-vop-tn-refs*
109 (fill *vop-tn-refs* nil)))
111 (pushnew 'flush-vop-tn-refs *before-gc-hooks*)
113 (defconstant sc-bits (integer-length (1- sc-number-limit)))
115 (defun emit-generic-vop (node block template args results &optional info)
116 (%emit-generic-vop node block template args results info))
118 (defun %emit-generic-vop (node block template args results info)
119 (let* ((vop (make-vop block node template args results))
120 (num-args (vop-info-num-args template))
121 (last-arg (1- num-args))
122 (num-results (vop-info-num-results template))
123 (num-operands (+ num-args num-results))
124 (last-result (1- num-operands))
125 (ref-ordering (vop-info-ref-ordering template)))
126 (declare (type vop vop)
127 (type (integer 0 #.max-vop-tn-refs)
128 num-args num-results num-operands)
129 (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result))
130 (setf (vop-codegen-info vop) info)
131 (let ((refs *vop-tn-refs*)
132 (*using-vop-tn-refs* t))
133 (declare (type (simple-vector #.max-vop-tn-refs) refs))
134 (do ((index 0 (1+ index))
135 (ref args (and ref (tn-ref-across ref))))
137 (setf (svref refs index) ref))
138 (do ((index num-args (1+ index))
139 (ref results (and ref (tn-ref-across ref))))
140 ((= index num-operands))
141 (setf (svref refs index) ref))
142 (let ((temps (vop-info-temps template)))
144 (let ((index num-operands)
146 (dotimes (i (length temps))
147 (let* ((temp (aref temps i))
148 (tn (if (logbitp 0 temp)
150 (ldb (byte sc-bits 1) temp)
151 (ash temp (- (1+ sc-bits))))
152 (make-restricted-tn nil (ash temp -1))))
153 (write-ref (reference-tn tn t)))
154 (setf (aref refs index) (reference-tn tn nil))
155 (setf (aref refs (1+ index)) write-ref)
157 (setf (tn-ref-across prev) write-ref)
158 (setf (vop-temps vop) write-ref))
159 (setf prev write-ref)
162 (flet ((add-ref (ref)
163 (setf (tn-ref-vop ref) vop)
164 (setf (tn-ref-next-ref ref) prev)
166 (declare (inline add-ref))
167 (dotimes (i (length ref-ordering))
168 (let* ((index (aref ref-ordering i))
169 (ref (aref refs index)))
170 (if (or (= index last-arg) (= index last-result))
171 (do ((ref ref (tn-ref-across ref)))
175 (setf (vop-refs vop) prev))
176 (let ((targets (vop-info-targets template)))
178 (dotimes (i (length targets))
179 (let ((target (aref targets i)))
180 (target-if-desirable (aref refs (ldb (byte 8 8) target))
181 (aref refs (ldb (byte 8 0) target))))))))
184 ;;;; function translation stuff
186 ;;; Add Template into List, removing any old template with the same name.
187 ;;; We also maintain the increasing cost ordering.
188 (defun adjoin-template (template list)
189 (declare (type template template) (list list))
191 (remove (template-name template) list
192 :key #'template-name))
194 :key #'template-cost))
196 ;;; Return a function type specifier describing Template's type computed
197 ;;; from the operand type restrictions.
198 (defun template-type-specifier (template)
199 (declare (type template template))
200 (flet ((convert (types more-types)
205 (:or `(or ,@(mapcar #'(lambda (type)
210 (:constant `(constant-argument ,(third x)))))))
211 `(,@(mapcar #'frob types)
213 `(&rest ,(frob more-types)))))))
214 (let* ((args (convert (template-arg-types template)
215 (template-more-args-type template)))
216 (result-restr (template-result-types template))
217 (results (if (eq result-restr :conditional)
219 (convert result-restr
220 (cond ((template-more-results-type template))
221 ((/= (length result-restr) 1) '*)
224 ,(if (= (length results) 1)
226 `(values ,@results))))))