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 (defvar *vop-tn-refs
* (make-array max-vop-tn-refs
:initial-element nil
))
108 (defvar *using-vop-tn-refs
* nil
)
110 (defun flush-vop-tn-refs ()
111 (unless *using-vop-tn-refs
*
112 (fill *vop-tn-refs
* nil
)))
114 (pushnew 'flush-vop-tn-refs
*before-gc-hooks
*)
116 (def!constant sc-bits
(integer-length (1- sc-number-limit
)))
118 (defun emit-generic-vop (node block template args results
&optional info
)
119 (%emit-generic-vop node block template args results info
))
121 (defun %emit-generic-vop
(node block template args results info
)
122 (let* ((vop (make-vop block node template args results
))
123 (num-args (vop-info-num-args template
))
124 (last-arg (1- num-args
))
125 (num-results (vop-info-num-results template
))
126 (num-operands (+ num-args num-results
))
127 (last-result (1- num-operands
))
128 (ref-ordering (vop-info-ref-ordering template
)))
129 (declare (type vop vop
)
130 (type (integer 0 #.max-vop-tn-refs
)
131 num-args num-results num-operands
)
132 (type (integer -
1 #.
(1- max-vop-tn-refs
)) last-arg last-result
))
133 (setf (vop-codegen-info vop
) info
)
134 (let ((refs *vop-tn-refs
*)
135 (*using-vop-tn-refs
* t
))
136 (declare (type (simple-vector #.max-vop-tn-refs
) refs
))
137 (do ((index 0 (1+ index
))
138 (ref args
(and ref
(tn-ref-across ref
))))
140 (setf (svref refs index
) ref
))
141 (do ((index num-args
(1+ index
))
142 (ref results
(and ref
(tn-ref-across ref
))))
143 ((= index num-operands
))
144 (setf (svref refs index
) ref
))
145 (let ((temps (vop-info-temps template
)))
147 (let ((index num-operands
)
149 (dotimes (i (length temps
))
150 (let* ((temp (aref temps i
))
151 (tn (if (logbitp 0 temp
)
153 (ldb (byte sc-bits
1) temp
)
154 (ash temp
(- (1+ sc-bits
))))
155 (make-restricted-tn nil
(ash temp -
1))))
156 (write-ref (reference-tn tn t
)))
157 ;; KLUDGE: These formulas must be consistent with those in
158 ;; COMPUTE-REF-ORDERING, and this is currently
159 ;; maintained by hand. -- WHN 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
)))
186 (target-if-desirable (aref refs
(ldb (byte 8 8) target
))
187 (aref refs
(ldb (byte 8 0) target
))))))))
190 ;;;; function translation stuff
192 ;;; Add Template into List, removing any old template with the same name.
193 ;;; We also maintain the increasing cost ordering.
194 (defun adjoin-template (template list
)
195 (declare (type template template
) (list list
))
197 (remove (template-name template
) list
198 :key
#'template-name
))
200 :key
#'template-cost
))
202 ;;; Return a function type specifier describing Template's type computed
203 ;;; from the operand type restrictions.
204 (defun template-type-specifier (template)
205 (declare (type template template
))
206 (flet ((convert (types more-types
)
211 (:or
`(or ,@(mapcar (lambda (type)
216 (:constant
`(constant-arg ,(third x
)))))))
217 `(,@(mapcar #'frob types
)
219 `(&rest
,(frob more-types
)))))))
220 (let* ((args (convert (template-arg-types template
)
221 (template-more-args-type template
)))
222 (result-restr (template-result-types template
))
223 (results (if (eq result-restr
:conditional
)
225 (convert result-restr
226 (cond ((template-more-results-type template
))
227 ((/= (length result-restr
) 1) '*)
230 ,(if (= (length results
) 1)
232 `(values ,@results
))))))