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.
15 ;;; Return the template having the specified name, or die trying.
16 (defun template-or-lose (x)
18 (or (gethash x
*backend-template-names
*)
19 (error "~S is not a defined template." x
))))
21 ;;; Return the SC structure, SB structure or SC number corresponding
22 ;;; to a name, or die trying.
25 (or (gethash x
*backend-sc-names
*)
26 (error "~S is not a defined storage class." x
))))
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
))))
34 ;;; This is like the non-meta versions, except we go for the
35 ;;; meta-compile-time info. These should not be used after load time,
36 ;;; since compiling the compiler changes the definitions.
37 (defun meta-sc-or-lose (x)
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)
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
))))
48 ;;;; side effect classes
50 (!def-boolean-attribute vop
53 ;;;; move/coerce definition
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
)
71 (old (svref vec scn
)))
72 (unless (and old
(< old total
))
73 (setf (svref vec scn
) total
))))))))
75 ;;;; primitive type definition
77 ;;; Return the primitive type corresponding to the specified name, or
79 (defun primitive-type-or-lose (name)
81 (or (gethash name
*backend-primitive-type-names
*)
82 (error "~S is not a defined primitive type." name
))))
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
)
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
)))
97 ;;;; generation of emit functions
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.
104 ;; See also the description of VOP-INFO-TARGETS. -- APD, 2002-01-30
105 (def!constant max-vop-tn-refs
256))
107 ;;; FIXME: This is a remarkably eccentric way of implementing what
108 ;;; would appear to be by nature a closure. A closure isn't any more
109 ;;; threadsafe than this special variable implementation, but at least
110 ;;; it's more idiomatic, and one could imagine closing over an
111 ;;; extensible pool to make a thread-safe implementation.
112 (declaim (type (simple-vector #.max-vop-tn-refs
) *vop-tn-refs
*))
113 (defvar *vop-tn-refs
* (make-array max-vop-tn-refs
:initial-element nil
))
115 (def!constant sc-bits
(integer-length (1- sc-number-limit
)))
117 (defun emit-generic-vop (node block template args results
&optional info
)
118 (%emit-generic-vop node block template args results info
))
120 (defun %emit-generic-vop
(node block template args results info
)
121 (let* ((vop (make-vop block node template args results
))
122 (num-args (vop-info-num-args template
))
123 (last-arg (1- num-args
))
124 (num-results (vop-info-num-results template
))
125 (num-operands (+ num-args num-results
))
126 (last-result (1- num-operands
))
127 (ref-ordering (vop-info-ref-ordering template
)))
128 (declare (type vop vop
)
129 (type (integer 0 #.max-vop-tn-refs
)
130 num-args num-results num-operands
)
131 (type (integer -
1 #.
(1- max-vop-tn-refs
)) last-arg last-result
))
132 (setf (vop-codegen-info vop
) info
)
134 (let ((refs *vop-tn-refs
*))
135 (declare (type (simple-vector #.max-vop-tn-refs
) refs
))
136 (do ((index 0 (1+ index
))
137 (ref args
(and ref
(tn-ref-across ref
))))
139 (setf (svref refs index
) ref
))
140 (do ((index num-args
(1+ index
))
141 (ref results
(and ref
(tn-ref-across ref
))))
142 ((= index num-operands
))
143 (setf (svref refs index
) ref
))
144 (let ((temps (vop-info-temps template
)))
146 (let ((index num-operands
)
148 (dotimes (i (length temps
))
149 (let* ((temp (aref temps i
))
150 (tn (if (logbitp 0 temp
)
152 (ldb (byte sc-bits
1) temp
)
153 (ash temp
(- (1+ sc-bits
))))
154 (make-restricted-tn nil
(ash temp -
1))))
155 (write-ref (reference-tn tn t
)))
156 ;; KLUDGE: These formulas must be consistent with
157 ;; those in COMPUTE-REF-ORDERING, and this is
158 ;; currently maintained by hand. -- WHN
159 ;; 2002-01-30, paraphrasing APD
160 (setf (aref refs index
) (reference-tn tn nil
))
161 (setf (aref refs
(1+ index
)) write-ref
)
163 (setf (tn-ref-across prev
) write-ref
)
164 (setf (vop-temps vop
) write-ref
))
165 (setf prev write-ref
)
168 (flet ((add-ref (ref)
169 (setf (tn-ref-vop ref
) vop
)
170 (setf (tn-ref-next-ref ref
) prev
)
172 (declare (inline add-ref
))
173 (dotimes (i (length ref-ordering
))
174 (let* ((index (aref ref-ordering i
))
175 (ref (aref refs index
)))
176 (if (or (= index last-arg
) (= index last-result
))
177 (do ((ref ref
(tn-ref-across ref
)))
181 (setf (vop-refs vop
) prev
))
182 (let ((targets (vop-info-targets template
)))
184 (dotimes (i (length targets
))
185 (let ((target (aref targets i
)))
187 (aref refs
(ldb (byte 8 8) target
))
188 (aref refs
(ldb (byte 8 0) target
)))))))
190 (fill *vop-tn-refs
* nil
))))
192 ;;;; function translation stuff
194 ;;; Add Template into List, removing any old template with the same name.
195 ;;; We also maintain the increasing cost ordering.
196 (defun adjoin-template (template list
)
197 (declare (type template template
) (list list
))
199 (remove (template-name template
) list
200 :key
#'template-name
))
202 :key
#'template-cost
))
204 ;;; Return a function type specifier describing TEMPLATE's type computed
205 ;;; from the operand type restrictions.
206 (defun template-type-specifier (template)
207 (declare (type template template
))
208 (flet ((convert (types more-types
)
213 (:or
`(or ,@(mapcar #'primitive-type-specifier
215 (:constant
`(constant-arg ,(third x
)))))))
216 `(,@(mapcar #'frob types
)
218 `(&rest
,(frob more-types
)))))))
219 (let* ((args (convert (template-arg-types template
)
220 (template-more-args-type template
)))
221 (result-restr (template-result-types template
))
222 (results (if (eq result-restr
:conditional
)
224 (convert result-restr
225 (cond ((template-more-results-type template
))
226 ((/= (length result-restr
) 1) '*)
229 ,(if (= (length results
) 1)
231 `(values ,@results
))))))