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        (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))))
  33
  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)
  38   (the sc
  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)
  42   (the sb
  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))))
  47 \f
  48 ;;;; side effect classes
  49
  50 (def-boolean-attribute vop
  51   any)
  52 \f
  53 ;;;; move/coerce definition
  54
  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)
  70                            cost))
  71                  (old (svref vec scn)))
  72             (unless (and old (< old total))
  73               (setf (svref vec scn) total))))))))
  74 \f
  75 ;;;; primitive type definition
  76
  77 ;;; Return the primitive type corresponding to the specified name, or
  78 ;;; die trying.
  79 (defun primitive-type-or-lose (name)
  80   (the primitive-type
  81        (or (gethash name *backend-primitive-type-names*)
  82            (error "~S is not a defined primitive type." name))))
  83
  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)
  91         (return t))
  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)))
  95           (return t))))))
  96 \f
  97 ;;;; generation of emit functions
  98
  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.
 102   ;; -- AL 20010218
 103   ;;
 104   ;; See also the description of VOP-INFO-TARGETS. -- APD, 2002-01-30
 105   (def!constant max-vop-tn-refs 256))
 106
 107 (defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
 108 (defvar *using-vop-tn-refs* nil)
 109
 110 (defun flush-vop-tn-refs ()
 111   (unless *using-vop-tn-refs*
 112     (fill *vop-tn-refs* nil)))
 113
 114 (pushnew 'flush-vop-tn-refs *before-gc-hooks*)
 115
 116 (def!constant sc-bits (integer-length (1- sc-number-limit)))
 117
 118 (defun emit-generic-vop (node block template args results &optional info)
 119   (%emit-generic-vop node block template args results info))
 120
 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))))
 139           ((= index num-args))
 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)))
 146         (when temps
 147           (let ((index num-operands)
 148                 (prev nil))
 149             (dotimes (i (length temps))
 150               (let* ((temp (aref temps i))
 151                      (tn (if (logbitp 0 temp)
 152                              (make-wired-tn nil
 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)
 162                 (if prev
 163                     (setf (tn-ref-across prev) write-ref)
 164                     (setf (vop-temps vop) write-ref))
 165                 (setf prev write-ref)
 166                 (incf index 2))))))
 167       (let ((prev nil))
 168         (flet ((add-ref (ref)
 169                  (setf (tn-ref-vop ref) vop)
 170                  (setf (tn-ref-next-ref ref) prev)
 171                  (setf prev ref)))
 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)))
 178                       ((null ref))
 179                     (add-ref ref))
 180                   (add-ref ref)))))
 181         (setf (vop-refs vop) prev))
 182       (let ((targets (vop-info-targets template)))
 183         (when targets
 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))))))))
 188     (values vop vop)))
 189 \f
 190 ;;;; function translation stuff
 191
 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))
 196   (sort (cons template
 197               (remove (template-name template) list
 198                       :key #'template-name))
 199         #'<=
 200         :key #'template-cost))
 201 \f
 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)
 207            (flet ((frob (x)
 208                     (if (eq x '*)
 209                         t
 210                         (ecase (first x)
 211                           (:or `(or ,@(mapcar (lambda (type)
 212                                                 (type-specifier
 213                                                  (primitive-type-type
 214                                                   type)))
 215                                               (rest x))))
 216                           (:constant `(constant-arg ,(third x)))))))
 217              `(,@(mapcar #'frob types)
 218                ,@(when more-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)
 224                         '(boolean)
 225                         (convert result-restr
 226                                  (cond ((template-more-results-type template))
 227                                        ((/= (length result-restr) 1) '*)
 228                                        (t nil))))))
 229       `(function ,args
 230                  ,(if (= (length results) 1)
 231                       (first results)
 232                       `(values ,@results))))))