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 (dolist (sb *backend-sb-list* 30 (error "~S is not a defined storage base." x)) 31 (when (eq (sb-name sb) x) 32 (return sb))))) 33 34(defun sc-number-or-lose (x) 35 (the sc-number (sc-number (sc-or-lose x)))) 36 37;;;; side effect classes 38 39(!def-boolean-attribute vop 40 any) 41 42;;;; move/coerce definition 43 44;;; Compute at compiler load time the costs for moving between all SCs that 45;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost. 46(defun compute-move-costs (from-sc to-sc cost) 47 (declare (type sc from-sc to-sc) (type index cost)) 48 (let ((to-scn (sc-number to-sc)) 49 (from-costs (sc-load-costs from-sc))) 50 (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc))) 51 (let ((vec (sc-move-costs dest-sc)) 52 (dest-costs (sc-load-costs dest-sc))) 53 (setf (svref vec (sc-number from-sc)) cost) 54 (dolist (sc (append (sc-alternate-scs from-sc) 55 (sc-constant-scs from-sc))) 56 (let* ((scn (sc-number sc)) 57 (total (+ (svref from-costs scn) 58 (svref dest-costs to-scn) 59 cost)) 60 (old (svref vec scn))) 61 (unless (and old (< old total)) 62 (setf (svref vec scn) total)))))))) 63 64;;;; primitive type definition 65 66;;; Return the primitive type corresponding to the specified name, or 67;;; die trying. 68(defun primitive-type-or-lose (name) 69 (the primitive-type 70 (or (gethash name *backend-primitive-type-names*) 71 (error "~S is not a defined primitive type." name)))) 72 73;;; Return true if SC is either one of PTYPE's SC's, or one of those 74;;; SC's alternate or constant SCs. 75(defun sc-allowed-by-primitive-type (sc ptype) 76 (declare (type sc sc) (type primitive-type ptype)) 77 (let ((scn (sc-number sc))) 78 (dolist (allowed (primitive-type-scs ptype) nil) 79 (when (eql allowed scn) 80 (return t)) 81 (let ((allowed-sc (svref *backend-sc-numbers* allowed))) 82 (when (or (member sc (sc-alternate-scs allowed-sc)) 83 (member sc (sc-constant-scs allowed-sc))) 84 (return t)))))) 85 86;;;; generation of emit functions 87 88(eval-when (:compile-toplevel :load-toplevel :execute) 89 ;; We need the EVAL-WHEN because EMIT-VOP (below) 90 ;; uses #.MAX-VOP-TN-REFS, not just MAX-VOP-TN-REFS. 91 ;; -- AL 20010218 92 ;; 93 ;; See also the description of VOP-INFO-TARGETS. -- APD, 2002-01-30 94 (defconstant max-vop-tn-refs 256)) 95 96;;; FIXME: This is a remarkably eccentric way of implementing what 97;;; would appear to be by nature a closure. A closure isn't any more 98;;; threadsafe than this special variable implementation, but at least 99;;; it's more idiomatic, and one could imagine closing over an 100;;; extensible pool to make a thread-safe implementation. 101(declaim (type (simple-vector #.max-vop-tn-refs) *vop-tn-refs*)) 102(defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil)) 103 104(defconstant sc-bits (integer-length (1- sc-number-limit))) 105 106;;; Emit a VOP for TEMPLATE. Arguments: 107;;; NODE Node for source context. 108;;; BLOCK IR2-BLOCK that we place the VOP in. 109;;; TEMPLATE: VOP template 110;;; ARGS Head of argument TN-REF list. 111;;; RESULT Head of result TN-REF list. 112;;; INFO If INFO-ARG-COUNT is non-zero, then a list of the magic arguments. 113;;; 114;;; Return the emitted vop 115(defun emit-vop (node block template args results &optional info) 116 (let* ((vop (make-vop block node template args results)) 117 (num-args (vop-info-num-args template)) 118 (last-arg (1- num-args)) 119 (num-results (vop-info-num-results template)) 120 (num-operands (+ num-args num-results)) 121 (last-result (1- num-operands)) 122 (ref-ordering (vop-info-ref-ordering template))) 123 (declare (type vop vop) 124 (type (integer 0 #.max-vop-tn-refs) 125 num-args num-results num-operands) 126 (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result)) 127 (setf (vop-codegen-info vop) info) 128 (unwind-protect 129 (let ((refs *vop-tn-refs*)) 130 (declare (type (simple-vector #.max-vop-tn-refs) refs)) 131 (do ((index 0 (1+ index)) 132 (ref args (and ref (tn-ref-across ref)))) 133 ((= index num-args)) 134 (setf (svref refs index) ref)) 135 (do ((index num-args (1+ index)) 136 (ref results (and ref (tn-ref-across ref)))) 137 ((= index num-operands)) 138 (setf (svref refs index) ref)) 139 (let ((temps (vop-info-temps template))) 140 (when temps 141 (let ((index num-operands) 142 (prev nil)) 143 (dotimes (i (length temps)) 144 (let* ((temp (aref temps i)) 145 (tn (if (logbitp 0 temp) 146 (make-wired-tn nil 147 (ldb (byte sc-bits 1) temp) 148 (ash temp (- (1+ sc-bits)))) 149 (make-restricted-tn nil (ash temp -1)))) 150 (write-ref (reference-tn tn t))) 151 ;; KLUDGE: These formulas must be consistent with 152 ;; those in COMPUTE-REF-ORDERING, and this is 153 ;; currently maintained by hand. -- WHN 154 ;; 2002-01-30, paraphrasing APD 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 (sb!regalloc:target-if-desirable 182 (aref refs (ldb (byte 8 8) target)) 183 (aref refs (ldb (byte 8 0) target))))))) 184 vop) 185 (fill *vop-tn-refs* nil)))) 186 187;;;; function translation stuff 188 189;;; Add Template into List, removing any old template with the same name. 190;;; We also maintain the increasing cost ordering. 191(defun adjoin-template (template list) 192 (declare (type template template) (list list)) 193 (sort (cons template 194 (remove (template-name template) list 195 :key #'template-name)) 196 #'<= 197 :key #'template-cost)) 198 199;;; Return a function type specifier describing TEMPLATE's type computed 200;;; from the operand type restrictions. 201#!-sb-fluid (declaim (inline template-conditional-p)) 202(defun template-conditional-p (template) 203 (declare (type template template)) 204 (let ((rtypes (template-result-types template))) 205 (or (eq rtypes :conditional) 206 (eq (car rtypes) :conditional)))) 207 208(defun template-type-specifier (template) 209 (declare (type template template)) 210 (flet ((convert (types more-types) 211 (flet ((frob (x) 212 (if (eq x '*) 213 t 214 (ecase (first x) 215 (:or `(or ,@(mapcar #'primitive-type-specifier 216 (rest x)))) 217 (:constant `(constant-arg ,(third x))))))) 218 `(,@(mapcar #'frob types) 219 ,@(when more-types 220 `(&rest ,(frob more-types))))))) 221 (let* ((args (convert (template-arg-types template) 222 (template-more-args-type template))) 223 (result-restr (template-result-types template)) 224 (results (if (template-conditional-p template) 225 '(boolean) 226 (convert result-restr 227 (cond ((template-more-results-type template)) 228 ((/= (length result-restr) 1) '*) 229 (t nil)))))) 230 `(function ,args 231 ,(if (= (length results) 1) 232 (first results) 233 `(values ,@results)))))) 234 235(defun template-translates-arg-p (function argument type) 236 (let ((primitive-type (primitive-type (specifier-type type)))) 237 (loop for template in (fun-info-templates (info :function :info function)) 238 for arg-type = (nth argument (template-arg-types template)) 239 thereis (and (consp arg-type) 240 (memq primitive-type (cdr arg-type)))))) 241