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        (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 \f
  37 ;;;; side effect classes
  38
  39 (!def-boolean-attribute vop
  40   any)
  41 \f
  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 \f
  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 \f
  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   (def!constant 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 (def!constant 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 \f
 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 \f
 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))))))