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 (file-comment
  16   "$Header$")
  17
  18 ;;; Return the template having the specified name, or die trying.
  19 (defun template-or-lose (x)
  20   (the template
  21        (or (gethash x *backend-template-names*)
  22            (error "~S is not a defined template." x))))
  23
  24 ;;; Return the SC structure, SB structure or SC number corresponding to a
  25 ;;; name, or die trying.
  26 (defun sc-or-lose (x)
  27   (the sc
  28        (or (gethash x *backend-sc-names*)
  29            (error "~S is not a defined storage class." x))))
  30 (defun sb-or-lose (x)
  31   (the sb
  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))))
  36
  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)
  41   (the sc
  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)
  45   (the sb
  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))))
  50 \f
  51 ;;;; side-effect classes
  52
  53 (def-boolean-attribute vop
  54   any)
  55 \f
  56 ;;;; move/coerce definition
  57
  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)
  73                            cost))
  74                  (old (svref vec scn)))
  75             (unless (and old (< old total))
  76               (setf (svref vec scn) total))))))))
  77 \f
  78 ;;;; primitive type definition
  79
  80 ;;; Return the primitive type corresponding to the specified name, or die
  81 ;;; trying.
  82 (defun primitive-type-or-lose (name)
  83   (the primitive-type
  84        (or (gethash name *backend-primitive-type-names*)
  85            (error "~S is not a defined primitive type." name))))
  86
  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)
  94         (return t))
  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)))
  98           (return t))))))
  99 \f
 100 ;;;; generation of emit functions
 101
 102 (defconstant max-vop-tn-refs 256)
 103
 104 (defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
 105 (defvar *using-vop-tn-refs* nil)
 106
 107 (defun flush-vop-tn-refs ()
 108   (unless *using-vop-tn-refs*
 109     (fill *vop-tn-refs* nil)))
 110
 111 (pushnew 'flush-vop-tn-refs *before-gc-hooks*)
 112
 113 (defconstant sc-bits (integer-length (1- sc-number-limit)))
 114
 115 (defun emit-generic-vop (node block template args results &optional info)
 116   (%emit-generic-vop node block template args results info))
 117
 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))))
 136           ((= index num-args))
 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)))
 143         (when temps
 144           (let ((index num-operands)
 145                 (prev nil))
 146             (dotimes (i (length temps))
 147               (let* ((temp (aref temps i))
 148                      (tn (if (logbitp 0 temp)
 149                              (make-wired-tn nil
 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)
 156                 (if prev
 157                     (setf (tn-ref-across prev) write-ref)
 158                     (setf (vop-temps vop) write-ref))
 159                 (setf prev write-ref)
 160                 (incf index 2))))))
 161       (let ((prev nil))
 162         (flet ((add-ref (ref)
 163                  (setf (tn-ref-vop ref) vop)
 164                  (setf (tn-ref-next-ref ref) prev)
 165                  (setf prev ref)))
 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)))
 172                       ((null ref))
 173                     (add-ref ref))
 174                   (add-ref ref)))))
 175         (setf (vop-refs vop) prev))
 176       (let ((targets (vop-info-targets template)))
 177         (when targets
 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))))))))
 182     (values vop vop)))
 183 \f
 184 ;;;; function translation stuff
 185
 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))
 190   (sort (cons template
 191               (remove (template-name template) list
 192                       :key #'template-name))
 193         #'<=
 194         :key #'template-cost))
 195 \f
 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)
 201            (flet ((frob (x)
 202                     (if (eq x '*)
 203                         't
 204                         (ecase (first x)
 205                           (:or `(or ,@(mapcar #'(lambda (type)
 206                                                   (type-specifier
 207                                                    (primitive-type-type
 208                                                     type)))
 209                                               (rest x))))
 210                           (:constant `(constant-argument ,(third x)))))))
 211              `(,@(mapcar #'frob types)
 212                ,@(when more-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)
 218                         '(boolean)
 219                         (convert result-restr
 220                                  (cond ((template-more-results-type template))
 221                                        ((/= (length result-restr) 1) '*)
 222                                        (t nil))))))
 223       `(function ,args
 224                  ,(if (= (length results) 1)
 225                       (first results)
 226                       `(values ,@results))))))