src/compiler/meta-vmdef.lisp

   1 ;;;; This file contains the implementation-independent facilities used
   2 ;;;; for defining the compiler's interface to the VM in a given
   3 ;;;; implementation that are needed at meta-compile time. They are
   4 ;;;; separated out from vmdef.lisp so that they can be compiled and
   5 ;;;; loaded without trashing the running compiler.
   6 ;;;;
   7 ;;;; FIXME: The "trashing the running [CMU CL] compiler" motivation no
   8 ;;;; longer makes sense in SBCL, since we can cross-compile cleanly.
   9
  10 ;;;; This software is part of the SBCL system. See the README file for
  11 ;;;; more information.
  12 ;;;;
  13 ;;;; This software is derived from the CMU CL system, which was
  14 ;;;; written at Carnegie Mellon University and released into the
  15 ;;;; public domain. The software is in the public domain and is
  16 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  17 ;;;; files for more information.
  18
  19 (in-package "SB!C")
  20 \f
  21 ;;;; storage class and storage base definition
  22
  23 ;;; Define a storage base having the specified NAME. KIND may be :FINITE,
  24 ;;; :UNBOUNDED or :NON-PACKED. The following keywords are legal:
  25 ;;;    :SIZE specifies the number of locations in a :FINITE SB or
  26 ;;;          the initial size of an :UNBOUNDED SB.
  27 ;;;
  28 ;;; We enter the basic structure at meta-compile time, and then fill
  29 ;;; in the missing slots at load time.
  30 (defmacro define-storage-base (name kind &key size)
  31
  32   (declare (type symbol name))
  33   (declare (type (member :finite :unbounded :non-packed) kind))
  34
  35   ;; SIZE is either mandatory or forbidden.
  36   (ecase kind
  37     (:non-packed
  38      (when size
  39        (error "A size specification is meaningless in a ~S SB." kind)))
  40     ((:finite :unbounded)
  41      (unless size (error "Size is not specified in a ~S SB." kind))
  42      (aver (typep size 'unsigned-byte))))
  43
  44   (let ((res (if (eq kind :non-packed)
  45                  (make-sb :name name :kind kind)
  46                  (make-finite-sb :name name :kind kind :size size))))
  47     `(progn
  48        (eval-when (:compile-toplevel :load-toplevel :execute)
  49          (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
  50          (setf (gethash ',name *backend-meta-sb-names*)
  51                ',res))
  52        (/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE")
  53        ,(if (eq kind :non-packed)
  54             `(setf (gethash ',name *backend-sb-names*)
  55                    (copy-sb ',res))
  56             `(let ((res (copy-finite-sb ',res)))
  57                (/show0 "not :NON-PACKED, i.e. hairy case")
  58                (setf (finite-sb-always-live res)
  59                      (make-array ',size
  60                                  :initial-element
  61                                  #-(or sb-xc sb-xc-host) #*
  62                                  ;; The cross-compiler isn't very good
  63                                  ;; at dumping specialized arrays; we
  64                                  ;; work around that by postponing
  65                                  ;; generation of the specialized
  66                                  ;; array 'til runtime.
  67                                  #+(or sb-xc sb-xc-host)
  68                                  (make-array 0 :element-type 'bit)))
  69                (/show0 "doing second SETF")
  70                (setf (finite-sb-conflicts res)
  71                      (make-array ',size :initial-element '#()))
  72                (/show0 "doing third SETF")
  73                (setf (finite-sb-live-tns res)
  74                      (make-array ',size :initial-element nil))
  75                (/show0 "doing fourth and final SETF")
  76                (setf (gethash ',name *backend-sb-names*)
  77                      res)))
  78
  79        (/show0 "about to put SB onto/into SB-LIST")
  80        (setf *backend-sb-list*
  81              (cons (sb-or-lose ',name)
  82                    (remove ',name *backend-sb-list* :key #'sb-name)))
  83        (/show0 "finished with DEFINE-STORAGE-BASE expansion")
  84        ',name)))
  85
  86 ;;; Define a storage class Name that uses the named Storage-Base. Number is a
  87 ;;; small, non-negative integer that is used as an alias. The following
  88 ;;; keywords are defined:
  89 ;;;
  90 ;;; :Element-Size Size
  91 ;;;   The size of objects in this SC in whatever units the SB uses. This
  92 ;;;   defaults to 1.
  93 ;;;
  94 ;;; :Alignment Size
  95 ;;;   The alignment restrictions for this SC. TNs will only be allocated at
  96 ;;;   offsets that are an even multiple of this number. Defaults to 1.
  97 ;;;
  98 ;;; :Locations (Location*)
  99 ;;;   If the SB is :Finite, then this is a list of the offsets within the SB
 100 ;;;   that are in this SC.
 101 ;;;
 102 ;;; :Reserve-Locations (Location*)
 103 ;;;   A subset of the Locations that the register allocator should try to
 104 ;;;   reserve for operand loading (instead of to hold variable values.)
 105 ;;;
 106 ;;; :Save-P {T | NIL}
 107 ;;;   If T, then values stored in this SC must be saved in one of the
 108 ;;;   non-save-p :Alternate-SCs across calls.
 109 ;;;
 110 ;;; :Alternate-SCs (SC*)
 111 ;;;   Indicates other SCs that can be used to hold values from this SC across
 112 ;;;   calls or when storage in this SC is exhausted. The SCs should be
 113 ;;;   specified in order of decreasing \"goodness\". There must be at least
 114 ;;;   one SC in an unbounded SB, unless this SC is only used for restricted or
 115 ;;;   wired TNs.
 116 ;;;
 117 ;;; :Constant-SCs (SC*)
 118 ;;;   A list of the names of all the constant SCs that can be loaded into this
 119 ;;;   SC by a move function.
 120 (defmacro define-storage-class (name number sb-name &key (element-size '1)
 121                                      (alignment '1) locations reserve-locations
 122                                      save-p alternate-scs constant-scs)
 123   (declare (type symbol name))
 124   (declare (type sc-number number))
 125   (declare (type symbol sb-name))
 126   (declare (type list locations reserve-locations alternate-scs constant-scs))
 127   (declare (type boolean save-p))
 128   (unless (= (logcount alignment) 1)
 129     (error "alignment not a power of two: ~W" alignment))
 130
 131   (let ((sb (meta-sb-or-lose sb-name)))
 132     (if (eq (sb-kind sb) :finite)
 133         (let ((size (sb-size sb))
 134               (element-size (eval element-size)))
 135           (declare (type unsigned-byte element-size))
 136           (dolist (el locations)
 137             (declare (type unsigned-byte el))
 138             (unless (<= 1 (+ el element-size) size)
 139               (error "SC element ~W out of bounds for ~S" el sb))))
 140         (when locations
 141           (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
 142
 143     (unless (subsetp reserve-locations locations)
 144       (error "RESERVE-LOCATIONS not a subset of LOCATIONS."))
 145
 146     (when (and (or alternate-scs constant-scs)
 147                (eq (sb-kind sb) :non-packed))
 148       (error
 149        "It's meaningless to specify alternate or constant SCs in a ~S SB."
 150        (sb-kind sb))))
 151
 152   (let ((nstack-p
 153          (if (or (eq sb-name 'non-descriptor-stack)
 154                  (find 'non-descriptor-stack
 155                        (mapcar #'meta-sc-or-lose alternate-scs)
 156                        :key (lambda (x)
 157                               (sb-name (sc-sb x)))))
 158              t nil)))
 159     `(progn
 160        (eval-when (:compile-toplevel :load-toplevel :execute)
 161          (let ((res (make-sc :name ',name :number ',number
 162                              :sb (meta-sb-or-lose ',sb-name)
 163                              :element-size ,element-size
 164                              :alignment ,alignment
 165                              :locations ',locations
 166                              :reserve-locations ',reserve-locations
 167                              :save-p ',save-p
 168                              :number-stack-p ,nstack-p
 169                              :alternate-scs (mapcar #'meta-sc-or-lose
 170                                                     ',alternate-scs)
 171                              :constant-scs (mapcar #'meta-sc-or-lose
 172                                                    ',constant-scs))))
 173            (setf (gethash ',name *backend-meta-sc-names*) res)
 174            (setf (svref *backend-meta-sc-numbers* ',number) res)
 175            (setf (svref (sc-load-costs res) ',number) 0)))
 176
 177        (let ((old (svref *backend-sc-numbers* ',number)))
 178          (when (and old (not (eq (sc-name old) ',name)))
 179            (warn "redefining SC number ~W from ~S to ~S" ',number
 180                  (sc-name old) ',name)))
 181
 182        (setf (svref *backend-sc-numbers* ',number)
 183              (meta-sc-or-lose ',name))
 184        (setf (gethash ',name *backend-sc-names*)
 185              (meta-sc-or-lose ',name))
 186        (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
 187        ',name)))
 188 \f
 189 ;;;; move/coerce definition
 190
 191 ;;; Given a list of pairs of lists of SCs (as given to DEFINE-MOVE-VOP,
 192 ;;; etc.), bind TO-SC and FROM-SC to all the combinations.
 193 (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
 194   `(do ((froms ,scs (cddr froms))
 195         (tos (cdr ,scs) (cddr tos)))
 196        ((null froms))
 197      (dolist (from (car froms))
 198        (let ((,from-sc-var (meta-sc-or-lose from)))
 199          (dolist (to (car tos))
 200            (let ((,to-sc-var (meta-sc-or-lose to)))
 201              ,@body))))))
 202
 203 ;;; Define the function NAME and note it as the function used for
 204 ;;; moving operands from the From-SCs to the To-SCs. Cost is the cost
 205 ;;; of this move operation. The function is called with three
 206 ;;; arguments: the VOP (for context), and the source and destination
 207 ;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of
 208 ;;; DEFINE-MOVE-FUN should be compiled before any uses of
 209 ;;; DEFINE-VOP.
 210 (defmacro define-move-fun ((name cost) lambda-list scs &body body)
 211   (declare (type index cost))
 212   (when (or (oddp (length scs)) (null scs))
 213     (error "malformed SCs spec: ~S" scs))
 214   `(progn
 215      (eval-when (:compile-toplevel :load-toplevel :execute)
 216        (do-sc-pairs (from-sc to-sc ',scs)
 217          (unless (eq from-sc to-sc)
 218            (let ((num (sc-number from-sc)))
 219              (setf (svref (sc-move-funs to-sc) num) ',name)
 220              (setf (svref (sc-load-costs to-sc) num) ',cost)))))
 221
 222      (defun ,name ,lambda-list
 223        (sb!assem:assemble (*code-segment* ,(first lambda-list))
 224          ,@body))))
 225
 226 (eval-when (:compile-toplevel :load-toplevel :execute)
 227   (defparameter *sc-vop-slots*
 228     '((:move . sc-move-vops)
 229       (:move-arg . sc-move-arg-vops))))
 230
 231 ;;; Make NAME be the VOP used to move values in the specified FROM-SCs
 232 ;;; to the representation of the TO-SCs of each SC pair in SCS.
 233 ;;;
 234 ;;; If KIND is :MOVE-ARG, then the VOP takes an extra argument,
 235 ;;; which is the frame pointer of the frame to move into.
 236 ;;;
 237 ;;; We record the VOP and costs for all SCs that we can move between
 238 ;;; (including implicit loading).
 239 (defmacro define-move-vop (name kind &rest scs)
 240   (when (or (oddp (length scs)) (null scs))
 241     (error "malformed SCs spec: ~S" scs))
 242   (let ((accessor (or (cdr (assoc kind *sc-vop-slots*))
 243                       (error "unknown kind ~S" kind))))
 244     `(progn
 245        ,@(when (eq kind :move)
 246            `((eval-when (:compile-toplevel :load-toplevel :execute)
 247                (do-sc-pairs (from-sc to-sc ',scs)
 248                  (compute-move-costs from-sc to-sc
 249                                      ,(vop-parse-cost
 250                                        (vop-parse-or-lose name)))))))
 251
 252        (let ((vop (template-or-lose ',name)))
 253          (do-sc-pairs (from-sc to-sc ',scs)
 254            (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
 255              (let ((vec (,accessor dest-sc)))
 256                (let ((scn (sc-number from-sc)))
 257                  (setf (svref vec scn)
 258                        (adjoin-template vop (svref vec scn))))
 259                (dolist (sc (append (sc-alternate-scs from-sc)
 260                                    (sc-constant-scs from-sc)))
 261                  (let ((scn (sc-number sc)))
 262                    (setf (svref vec scn)
 263                          (adjoin-template vop (svref vec scn))))))))))))
 264 \f
 265 ;;;; primitive type definition
 266
 267 (defun meta-primitive-type-or-lose (name)
 268   (the primitive-type
 269        (or (gethash name *backend-meta-primitive-type-names*)
 270            (error "~S is not a defined primitive type." name))))
 271
 272 ;;; Define a primitive type NAME. Each SCS entry specifies a storage
 273 ;;; class that values of this type may be allocated in. TYPE is the
 274 ;;; type descriptor for the Lisp type that is equivalent to this type.
 275 (defmacro !def-primitive-type (name scs &key (type name))
 276   (declare (type symbol name) (type list scs))
 277   (let ((scns (mapcar #'meta-sc-number-or-lose scs))
 278         (ctype-form `(specifier-type ',type)))
 279     `(progn
 280        (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
 281        (/primitive-print ,(symbol-name name))
 282        (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 283          (setf (gethash ',name *backend-meta-primitive-type-names*)
 284                (make-primitive-type :name ',name
 285                                     :scs ',scns
 286                                     :type ,ctype-form)))
 287        ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
 288                     (n-type ctype-form))
 289           `(progn
 290              ;; If the PRIMITIVE-TYPE structure already exists, we
 291              ;; destructively modify it so that existing references in
 292              ;; templates won't be invalidated. FIXME: This should no
 293              ;; longer be an issue in SBCL, since we don't try to do
 294              ;; serious surgery on ourselves. Probably this should
 295              ;; just become an assertion that N-OLD is NIL, so that we
 296              ;; don't have to try to maintain the correctness of the
 297              ;; never-ordinarily-used clause.
 298              (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND")
 299              (cond (,n-old
 300                     (/show0 "in ,N-OLD clause of COND")
 301                     (setf (primitive-type-scs ,n-old) ',scns)
 302                     (setf (primitive-type-type ,n-old) ,n-type))
 303                    (t
 304                     (/show0 "in T clause of COND")
 305                     (setf (gethash ',name *backend-primitive-type-names*)
 306                           (make-primitive-type :name ',name
 307                                                :scs ',scns
 308                                                :type ,n-type))))
 309              (/show0 "done with !DEF-PRIMITIVE-TYPE")
 310              ',name)))))
 311
 312 ;;; Define NAME to be an alias for RESULT in VOP operand type restrictions.
 313 (defmacro !def-primitive-type-alias (name result)
 314   ;; Just record the translation.
 315   `(eval-when (:compile-toplevel :load-toplevel :execute)
 316      (setf (gethash ',name *backend-primitive-type-aliases*) ',result)
 317      ',name))
 318
 319 (defparameter *primitive-type-slot-alist*
 320   '((:check . primitive-type-check)))
 321
 322 (defmacro primitive-type-vop (vop kinds &rest types)
 323   #!+sb-doc
 324   "Primitive-Type-VOP Vop (Kind*) Type*
 325   Annotate all the specified primitive Types with the named VOP under each of
 326   the specified kinds:
 327
 328   :Check
 329       A one argument one result VOP that moves the argument to the result,
 330       checking that the value is of this type in the process."
 331   (let ((n-vop (gensym))
 332         (n-type (gensym)))
 333     `(let ((,n-vop (template-or-lose ',vop)))
 334        ,@(mapcar
 335           (lambda (type)
 336             `(let ((,n-type (primitive-type-or-lose ',type)))
 337                ,@(mapcar
 338                   (lambda (kind)
 339                     (let ((slot (or (cdr (assoc kind
 340                                                 *primitive-type-slot-alist*))
 341                                     (error "unknown kind: ~S" kind))))
 342                       `(setf (,slot ,n-type) ,n-vop)))
 343                   kinds)))
 344           types)
 345        nil)))
 346
 347 ;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
 348 ;;; alternate or constant SCs.
 349 (defun meta-sc-allowed-by-primitive-type (sc ptype)
 350   (declare (type sc sc) (type primitive-type ptype))
 351   (let ((scn (sc-number sc)))
 352     (dolist (allowed (primitive-type-scs ptype) nil)
 353       (when (eql allowed scn)
 354         (return t))
 355       (let ((allowed-sc (svref *backend-meta-sc-numbers* allowed)))
 356         (when (or (member sc (sc-alternate-scs allowed-sc))
 357                   (member sc (sc-constant-scs allowed-sc)))
 358           (return t))))))
 359 \f
 360 ;;;; VOP definition structures
 361 ;;;;
 362 ;;;; DEFINE-VOP uses some fairly complex data structures at
 363 ;;;; meta-compile time, both to hold the results of parsing the
 364 ;;;; elaborate syntax and to retain the information so that it can be
 365 ;;;; inherited by other VOPs.
 366
 367 ;;; A VOP-PARSE object holds everything we need to know about a VOP at
 368 ;;; meta-compile time.
 369 (def!struct (vop-parse
 370              (:make-load-form-fun just-dump-it-normally)
 371              #-sb-xc-host (:pure t))
 372   ;; the name of this VOP
 373   (name nil :type symbol)
 374   ;; If true, then the name of the VOP we inherit from.
 375   (inherits nil :type (or symbol null))
 376   ;; lists of OPERAND-PARSE structures describing the arguments,
 377   ;; results and temporaries of the VOP
 378   (args nil :type list)
 379   (results nil :type list)
 380   (temps nil :type list)
 381   ;; OPERAND-PARSE structures containing information about more args
 382   ;; and results. If null, then there there are no more operands of
 383   ;; that kind
 384   (more-args nil :type (or operand-parse null))
 385   (more-results nil :type (or operand-parse null))
 386   ;; a list of all the above together
 387   (operands nil :type list)
 388   ;; names of variables that should be declared IGNORE
 389   (ignores () :type list)
 390   ;; true if this is a :CONDITIONAL VOP
 391   (conditional-p nil)
 392   ;; argument and result primitive types. These are pulled out of the
 393   ;; operands, since we often want to change them without respecifying
 394   ;; the operands.
 395   (arg-types :unspecified :type (or (member :unspecified) list))
 396   (result-types :unspecified :type (or (member :unspecified) list))
 397   ;; the guard expression specified, or NIL if none
 398   (guard nil)
 399   ;; the cost of and body code for the generator
 400   (cost 0 :type unsigned-byte)
 401   (body :unspecified :type (or (member :unspecified) list))
 402   ;; info for VOP variants. The list of forms to be evaluated to get
 403   ;; the variant args for this VOP, and the list of variables to be
 404   ;; bound to the variant args.
 405   (variant () :type list)
 406   (variant-vars () :type list)
 407   ;; variables bound to the VOP and Vop-Node when in the generator body
 408   (vop-var (gensym) :type symbol)
 409   (node-var nil :type (or symbol null))
 410   ;; a list of the names of the codegen-info arguments to this VOP
 411   (info-args () :type list)
 412   ;; an efficiency note associated with this VOP
 413   (note nil :type (or string null))
 414   ;; a list of the names of the Effects and Affected attributes for
 415   ;; this VOP
 416   (effects '(any) :type list)
 417   (affected '(any) :type list)
 418   ;; a list of the names of functions this VOP is a translation of and
 419   ;; the policy that allows this translation to be done. :Fast is a
 420   ;; safe default, since it isn't a safe policy.
 421   (translate () :type list)
 422   (ltn-policy :fast :type ltn-policy)
 423   ;; stuff used by life analysis
 424   (save-p nil :type (member t nil :compute-only :force-to-stack))
 425   ;; info about how to emit MOVE-ARG VOPs for the &MORE operand in
 426   ;; call/return VOPs
 427   (move-args nil :type (member nil :local-call :full-call :known-return)))
 428 (defprinter (vop-parse)
 429   name
 430   (inherits :test inherits)
 431   args
 432   results
 433   temps
 434   (more-args :test more-args)
 435   (more-results :test more-results)
 436   (conditional-p :test conditional-p)
 437   ignores
 438   arg-types
 439   result-types
 440   cost
 441   body
 442   (variant :test variant)
 443   (variant-vars :test variant-vars)
 444   (info-args :test info-args)
 445   (note :test note)
 446   effects
 447   affected
 448   translate
 449   ltn-policy
 450   (save-p :test save-p)
 451   (move-args :test move-args))
 452
 453 ;;; An OPERAND-PARSE object contains stuff we need to know about an
 454 ;;; operand or temporary at meta-compile time. Besides the obvious
 455 ;;; stuff, we also store the names of per-operand temporaries here.
 456 (def!struct (operand-parse
 457              (:make-load-form-fun just-dump-it-normally)
 458              #-sb-xc-host (:pure t))
 459   ;; name of the operand (which we bind to the TN)
 460   (name nil :type symbol)
 461   ;; the way this operand is used:
 462   (kind (missing-arg)
 463         :type (member :argument :result :temporary
 464                       :more-argument :more-result))
 465   ;; If true, the name of an operand that this operand is targeted to.
 466   ;; This is only meaningful in :ARGUMENT and :TEMPORARY operands.
 467   (target nil :type (or symbol null))
 468   ;; TEMP is a temporary that holds the TN-REF for this operand.
 469   ;; TEMP-TEMP holds the write reference that begins a temporary's
 470   ;; lifetime.
 471   (temp (gensym) :type symbol)
 472   (temp-temp nil :type (or symbol null))
 473   ;; the time that this operand is first live and the time at which it
 474   ;; becomes dead again. These are TIME-SPECs, as returned by
 475   ;; PARSE-TIME-SPEC.
 476   born
 477   dies
 478   ;; a list of the names of the SCs that this operand is allowed into.
 479   ;; If false, there is no restriction.
 480   (scs nil :type list)
 481   ;; Variable that is bound to the load TN allocated for this operand, or to
 482   ;; NIL if no load-TN was allocated.
 483   (load-tn (gensym) :type symbol)
 484   ;; an expression that tests whether to do automatic operand loading
 485   (load t)
 486   ;; In a wired or restricted temporary this is the SC the TN is to be
 487   ;; packed in. Null otherwise.
 488   (sc nil :type (or symbol null))
 489   ;; If non-null, we are a temp wired to this offset in SC.
 490   (offset nil :type (or unsigned-byte null)))
 491 (defprinter (operand-parse)
 492   name
 493   kind
 494   (target :test target)
 495   born
 496   dies
 497   (scs :test scs)
 498   (load :test load)
 499   (sc :test sc)
 500   (offset :test offset))
 501 \f
 502 ;;;; miscellaneous utilities
 503
 504 ;;; Find the operand or temporary with the specifed Name in the VOP
 505 ;;; Parse. If there is no such operand, signal an error. Also error if
 506 ;;; the operand kind isn't one of the specified Kinds. If Error-P is
 507 ;;; NIL, just return NIL if there is no such operand.
 508 (defun find-operand (name parse &optional
 509                           (kinds '(:argument :result :temporary))
 510                           (error-p t))
 511   (declare (symbol name) (type vop-parse parse) (list kinds))
 512   (let ((found (find name (vop-parse-operands parse)
 513                      :key #'operand-parse-name)))
 514     (if found
 515         (unless (member (operand-parse-kind found) kinds)
 516           (error "Operand ~S isn't one of these kinds: ~S." name kinds))
 517         (when error-p
 518           (error "~S is not an operand to ~S." name (vop-parse-name parse))))
 519     found))
 520
 521 ;;; Get the VOP-Parse structure for NAME or die trying. For all
 522 ;;; meta-compile time uses, the VOP-Parse should be used instead of
 523 ;;; the VOP-Info.
 524 (defun vop-parse-or-lose (name)
 525   (the vop-parse
 526        (or (gethash name *backend-parsed-vops*)
 527            (error "~S is not the name of a defined VOP." name))))
 528
 529 ;;; Return a list of LET-forms to parse a TN-REF list into the temps
 530 ;;; specified by the operand-parse structures. MORE-OPERAND is the
 531 ;;; Operand-Parse describing any more operand, or NIL if none. REFS is
 532 ;;; an expression that evaluates into the first tn-ref.
 533 (defun access-operands (operands more-operand refs)
 534   (declare (list operands))
 535   (collect ((res))
 536     (let ((prev refs))
 537       (dolist (op operands)
 538         (let ((n-ref (operand-parse-temp op)))
 539           (res `(,n-ref ,prev))
 540           (setq prev `(tn-ref-across ,n-ref))))
 541
 542       (when more-operand
 543         (res `(,(operand-parse-name more-operand) ,prev))))
 544     (res)))
 545
 546 ;;; This is used with ACCESS-OPERANDS to prevent warnings for TN-Ref
 547 ;;; temps not used by some particular function. It returns the name of
 548 ;;; the last operand, or NIL if Operands is NIL.
 549 (defun ignore-unreferenced-temps (operands)
 550   (when operands
 551     (operand-parse-temp (car (last operands)))))
 552
 553 ;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
 554 (defun vop-spec-arg (spec type &optional (n 1) (last t))
 555   (let ((len (length spec)))
 556     (when (<= len n)
 557       (error "~:R argument missing: ~S" n spec))
 558     (when (and last (> len (1+ n)))
 559       (error "extra junk at end of ~S" spec))
 560     (let ((thing (elt spec n)))
 561       (unless (typep thing type)
 562         (error "~:R argument is not a ~S: ~S" n type spec))
 563       thing)))
 564 \f
 565 ;;;; time specs
 566
 567 ;;; Return a time spec describing a time during the evaluation of a
 568 ;;; VOP, used to delimit operand and temporary lifetimes. The
 569 ;;; representation is a cons whose CAR is the number of the evaluation
 570 ;;; phase and the CDR is the sub-phase. The sub-phase is 0 in the
 571 ;;; :LOAD and :SAVE phases.
 572 (defun parse-time-spec (spec)
 573   (let ((dspec (if (atom spec) (list spec 0) spec)))
 574     (unless (and (= (length dspec) 2)
 575                  (typep (second dspec) 'unsigned-byte))
 576       (error "malformed time specifier: ~S" spec))
 577
 578     (cons (case (first dspec)
 579             (:load 0)
 580             (:argument 1)
 581             (:eval 2)
 582             (:result 3)
 583             (:save 4)
 584             (t
 585              (error "unknown phase in time specifier: ~S" spec)))
 586           (second dspec))))
 587
 588 ;;; Return true if the time spec X is the same or later time than Y.
 589 (defun time-spec-order (x y)
 590   (or (> (car x) (car y))
 591       (and (= (car x) (car y))
 592            (>= (cdr x) (cdr y)))))
 593 \f
 594 ;;;; generation of emit functions
 595
 596 (defun compute-temporaries-description (parse)
 597   (let ((temps (vop-parse-temps parse))
 598         (element-type '(unsigned-byte 16)))
 599     (when temps
 600       (let ((results (make-specializable-array
 601                       (length temps)
 602                       :element-type element-type))
 603             (index 0))
 604         (dolist (temp temps)
 605           (declare (type operand-parse temp))
 606           (let ((sc (operand-parse-sc temp))
 607                 (offset (operand-parse-offset temp)))
 608             (aver sc)
 609             (setf (aref results index)
 610                   (if offset
 611                       (+ (ash offset (1+ sc-bits))
 612                          (ash (meta-sc-number-or-lose sc) 1)
 613                          1)
 614                       (ash (meta-sc-number-or-lose sc) 1))))
 615           (incf index))
 616         ;; KLUDGE: As in the other COERCEs wrapped around with
 617         ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING,
 618         ;; this coercion could be removed by a sufficiently smart
 619         ;; compiler, but I dunno whether Python is that smart. It
 620         ;; would be good to check this and help it if it's not smart
 621         ;; enough to remove it for itself. However, it's probably not
 622         ;; urgent, since the overhead of an extra no-op conversion is
 623         ;; unlikely to be large compared to consing and corresponding
 624         ;; GC. -- WHN ca. 19990701
 625         `(coerce ,results '(specializable-vector ,element-type))))))
 626
 627 (defun compute-ref-ordering (parse)
 628   (let* ((num-args (+ (length (vop-parse-args parse))
 629                       (if (vop-parse-more-args parse) 1 0)))
 630          (num-results (+ (length (vop-parse-results parse))
 631                          (if (vop-parse-more-results parse) 1 0)))
 632          (index 0))
 633     (collect ((refs) (targets))
 634       (dolist (op (vop-parse-operands parse))
 635         (when (operand-parse-target op)
 636           (unless (member (operand-parse-kind op) '(:argument :temporary))
 637             (error "cannot target a ~S operand: ~S" (operand-parse-kind op)
 638                    (operand-parse-name op)))
 639           (let ((target (find-operand (operand-parse-target op) parse
 640                                       '(:temporary :result))))
 641             (targets (+ (* index max-vop-tn-refs)
 642                         (ecase (operand-parse-kind target)
 643                           (:result
 644                            (+ (position-or-lose target
 645                                                 (vop-parse-results parse))
 646                               num-args))
 647                           (:temporary
 648                            (+ (* (position-or-lose target
 649                                                    (vop-parse-temps parse))
 650                                  2)
 651                               num-args num-results)))))))
 652         (let ((born (operand-parse-born op))
 653               (dies (operand-parse-dies op)))
 654           (ecase (operand-parse-kind op)
 655             (:argument
 656              (refs (cons (cons dies nil) index)))
 657             (:more-argument
 658              (refs (cons (cons dies nil) index)))
 659             (:result
 660              (refs (cons (cons born t) index)))
 661             (:more-result
 662              (refs (cons (cons born t) index)))
 663             (:temporary
 664              (refs (cons (cons dies nil) index))
 665              (incf index)
 666              (refs (cons (cons born t) index))))
 667           (incf index)))
 668       (let* ((sorted (sort (refs)
 669                            (lambda (x y)
 670                              (let ((x-time (car x))
 671                                    (y-time (car y)))
 672                                (if (time-spec-order x-time y-time)
 673                                    (if (time-spec-order y-time x-time)
 674                                        (and (not (cdr x)) (cdr y))
 675                                        nil)
 676                                    t)))
 677                            :key #'car))
 678              (oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type
 679              (te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type
 680              (ordering (make-specializable-array
 681                         (length sorted)
 682                         :element-type oe-type)))
 683         (let ((index 0))
 684           (dolist (ref sorted)
 685             (setf (aref ordering index) (cdr ref))
 686             (incf index)))
 687         `(:num-args ,num-args
 688           :num-results ,num-results
 689           ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper
 690           ;; here around the result returned by
 691           ;; MAKE-SPECIALIZABLE-ARRAY above was of course added to
 692           ;; help with cross-compilation. "A sufficiently smart
 693           ;; compiler" should be able to optimize all this away in the
 694           ;; final target Lisp, leaving a single MAKE-ARRAY with no
 695           ;; subsequent coercion. However, I don't know whether Python
 696           ;; is that smart. (Can it figure out the return type of
 697           ;; MAKE-ARRAY? Does it know that COERCE can be optimized
 698           ;; away if the input type is known to be the same as the
 699           ;; COERCEd-to type?) At some point it would be good to test
 700           ;; to see whether this construct is in fact causing run-time
 701           ;; overhead, and fix it if so. (Some declarations of the
 702           ;; types returned by MAKE-ARRAY might be enough to fix it.)
 703           ;; However, it's probably not urgent to fix this, since it's
 704           ;; hard to imagine that any overhead caused by calling
 705           ;; COERCE and letting it decide to bail out could be large
 706           ;; compared to the cost of consing and GCing the vectors in
 707           ;; the first place. -- WHN ca. 19990701
 708           :ref-ordering (coerce ',ordering
 709                                 '(specializable-vector ,oe-type))
 710           ,@(when (targets)
 711               `(:targets (coerce ',(targets)
 712                                  '(specializable-vector ,te-type)))))))))
 713
 714 (defun make-emit-function-and-friends (parse)
 715   `(:emit-function #'emit-generic-vop
 716     :temps ,(compute-temporaries-description parse)
 717     ,@(compute-ref-ordering parse)))
 718 \f
 719 ;;;; generator functions
 720
 721 ;;; Return an alist that translates from lists of SCs we can load OP
 722 ;;; from to the move function used for loading those SCs. We quietly
 723 ;;; ignore restrictions to :non-packed (constant) and :unbounded SCs,
 724 ;;; since we don't load into those SCs.
 725 (defun find-move-funs (op load-p)
 726   (collect ((funs))
 727     (dolist (sc-name (operand-parse-scs op))
 728       (let* ((sc (meta-sc-or-lose sc-name))
 729              (scn (sc-number sc))
 730              (load-scs (append (when load-p
 731                                  (sc-constant-scs sc))
 732                                (sc-alternate-scs sc))))
 733         (cond
 734          (load-scs
 735           (dolist (alt load-scs)
 736             (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
 737               (let* ((altn (sc-number alt))
 738                      (name (if load-p
 739                                (svref (sc-move-funs sc) altn)
 740                                (svref (sc-move-funs alt) scn)))
 741                      (found (or (assoc alt (funs) :test #'member)
 742                                 (rassoc name (funs)))))
 743                 (unless name
 744                   (error "no move function defined to ~:[save~;load~] SC ~S ~
 745                           with ~S ~:[to~;from~] from SC ~S"
 746                          load-p sc-name load-p (sc-name alt)))
 747
 748                 (cond (found
 749                        (unless (eq (cdr found) name)
 750                          (error "can't tell whether to ~:[save~;load~]~@
 751                                  or ~S when operand is in SC ~S"
 752                                 load-p name (cdr found) (sc-name alt)))
 753                        (pushnew alt (car found)))
 754                       (t
 755                        (funs (cons (list alt) name))))))))
 756          ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
 757          (t
 758           (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
 759                   mentioned in the restriction for operand ~S"
 760                  sc-name load-p (operand-parse-name op))))))
 761     (funs)))
 762
 763 ;;; Return a form to load/save the specified operand when it has a
 764 ;;; load TN. For any given SC that we can load from, there must be a
 765 ;;; unique load function. If all SCs we can load from have the same
 766 ;;; move function, then we just call that when there is a load TN. If
 767 ;;; there are multiple possible move functions, then we dispatch off
 768 ;;; of the operand TN's type to see which move function to use.
 769 (defun call-move-fun (parse op load-p)
 770   (let ((funs (find-move-funs op load-p))
 771         (load-tn (operand-parse-load-tn op)))
 772     (if funs
 773         (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
 774                (n-vop (or (vop-parse-vop-var parse)
 775                           (setf (vop-parse-vop-var parse) (gensym))))
 776                (form (if (rest funs)
 777                          `(sc-case ,tn
 778                             ,@(mapcar (lambda (x)
 779                                         `(,(mapcar #'sc-name (car x))
 780                                           ,(if load-p
 781                                                `(,(cdr x) ,n-vop ,tn
 782                                                  ,load-tn)
 783                                                `(,(cdr x) ,n-vop ,load-tn
 784                                                  ,tn))))
 785                                       funs))
 786                          (if load-p
 787                              `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
 788                              `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
 789           (if (eq (operand-parse-load op) t)
 790               `(when ,load-tn ,form)
 791               `(when (eq ,load-tn ,(operand-parse-name op))
 792                  ,form)))
 793         `(when ,load-tn
 794            (error "load TN allocated, but no move function?~@
 795                    VM definition is inconsistent, recompile and try again.")))))
 796
 797 ;;; Return the TN that we should bind to the operand's var in the
 798 ;;; generator body. In general, this involves evaluating the :LOAD-IF
 799 ;;; test expression.
 800 (defun decide-to-load (parse op)
 801   (let ((load (operand-parse-load op))
 802         (load-tn (operand-parse-load-tn op))
 803         (temp (operand-parse-temp op)))
 804     (if (eq load t)
 805         `(or ,load-tn (tn-ref-tn ,temp))
 806         (collect ((binds)
 807                   (ignores))
 808           (dolist (x (vop-parse-operands parse))
 809             (when (member (operand-parse-kind x) '(:argument :result))
 810               (let ((name (operand-parse-name x)))
 811                 (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
 812                 (ignores name))))
 813           `(if (and ,load-tn
 814                     (let ,(binds)
 815                       (declare (ignorable ,@(ignores)))
 816                       ,load))
 817                ,load-tn
 818                (tn-ref-tn ,temp))))))
 819
 820 ;;; Make a lambda that parses the VOP TN-Refs, does automatic operand
 821 ;;; loading, and runs the appropriate code generator.
 822 (defun make-generator-function (parse)
 823   (declare (type vop-parse parse))
 824   (let ((n-vop (vop-parse-vop-var parse))
 825         (operands (vop-parse-operands parse))
 826         (n-info (gensym)) (n-variant (gensym)))
 827     (collect ((binds)
 828               (loads)
 829               (saves))
 830       (dolist (op operands)
 831         (ecase (operand-parse-kind op)
 832           ((:argument :result)
 833            (let ((temp (operand-parse-temp op))
 834                  (name (operand-parse-name op)))
 835              (cond ((and (operand-parse-load op) (operand-parse-scs op))
 836                     (binds `(,(operand-parse-load-tn op)
 837                              (tn-ref-load-tn ,temp)))
 838                     (binds `(,name ,(decide-to-load parse op)))
 839                     (if (eq (operand-parse-kind op) :argument)
 840                         (loads (call-move-fun parse op t))
 841                         (saves (call-move-fun parse op nil))))
 842                    (t
 843                     (binds `(,name (tn-ref-tn ,temp)))))))
 844           (:temporary
 845            (binds `(,(operand-parse-name op)
 846                     (tn-ref-tn ,(operand-parse-temp op)))))
 847           ((:more-argument :more-result))))
 848
 849       `(lambda (,n-vop)
 850          (let* (,@(access-operands (vop-parse-args parse)
 851                                    (vop-parse-more-args parse)
 852                                    `(vop-args ,n-vop))
 853                   ,@(access-operands (vop-parse-results parse)
 854                                      (vop-parse-more-results parse)
 855                                      `(vop-results ,n-vop))
 856                   ,@(access-operands (vop-parse-temps parse) nil
 857                                      `(vop-temps ,n-vop))
 858                   ,@(when (vop-parse-info-args parse)
 859                       `((,n-info (vop-codegen-info ,n-vop))
 860                         ,@(mapcar (lambda (x) `(,x (pop ,n-info)))
 861                                   (vop-parse-info-args parse))))
 862                   ,@(when (vop-parse-variant-vars parse)
 863                       `((,n-variant (vop-info-variant (vop-info ,n-vop)))
 864                         ,@(mapcar (lambda (x) `(,x (pop ,n-variant)))
 865                                   (vop-parse-variant-vars parse))))
 866                   ,@(when (vop-parse-node-var parse)
 867                       `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
 868                   ,@(binds))
 869            (declare (ignore ,@(vop-parse-ignores parse)))
 870            ,@(loads)
 871            (sb!assem:assemble (*code-segment* ,n-vop)
 872                               ,@(vop-parse-body parse))
 873            ,@(saves))))))
 874 \f
 875 ;;; Given a list of operand specifications as given to DEFINE-VOP,
 876 ;;; return a list of OPERAND-PARSE structures describing the fixed
 877 ;;; operands, and a single OPERAND-PARSE describing any more operand.
 878 ;;; If we are inheriting a VOP, we default attributes to the inherited
 879 ;;; operand of the same name.
 880 (defun !parse-vop-operands (parse specs kind)
 881   (declare (list specs)
 882            (type (member :argument :result) kind))
 883   (let ((num -1)
 884         (more nil))
 885     (collect ((operands))
 886       (dolist (spec specs)
 887         (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
 888           (error "malformed operand specifier: ~S" spec))
 889         (when more
 890           (error "The MORE operand isn't the last operand: ~S" specs))
 891         (let* ((name (first spec))
 892                (old (if (vop-parse-inherits parse)
 893                         (find-operand name
 894                                       (vop-parse-or-lose
 895                                        (vop-parse-inherits parse))
 896                                       (list kind)
 897                                       nil)
 898                         nil))
 899                (res (if old
 900                         (make-operand-parse
 901                          :name name
 902                          :kind kind
 903                          :target (operand-parse-target old)
 904                          :born (operand-parse-born old)
 905                          :dies (operand-parse-dies old)
 906                          :scs (operand-parse-scs old)
 907                          :load-tn (operand-parse-load-tn old)
 908                          :load (operand-parse-load old))
 909                         (ecase kind
 910                           (:argument
 911                            (make-operand-parse
 912                             :name (first spec)
 913                             :kind :argument
 914                             :born (parse-time-spec :load)
 915                             :dies (parse-time-spec `(:argument ,(incf num)))))
 916                           (:result
 917                            (make-operand-parse
 918                             :name (first spec)
 919                             :kind :result
 920                             :born (parse-time-spec `(:result ,(incf num)))
 921                             :dies (parse-time-spec :save)))))))
 922           (do ((key (rest spec) (cddr key)))
 923               ((null key))
 924             (let ((value (second key)))
 925               (case (first key)
 926                 (:scs
 927                  (aver (typep value 'list))
 928                  (setf (operand-parse-scs res) (remove-duplicates value)))
 929                 (:load-tn
 930                  (aver (typep value 'symbol))
 931                  (setf (operand-parse-load-tn res) value))
 932                 (:load-if
 933                  (setf (operand-parse-load res) value))
 934                 (:more
 935                  (aver (typep value 'boolean))
 936                  (setf (operand-parse-kind res)
 937                        (if (eq kind :argument) :more-argument :more-result))
 938                  (setf (operand-parse-load res) nil)
 939                  (setq more res))
 940                 (:target
 941                  (aver (typep value 'symbol))
 942                  (setf (operand-parse-target res) value))
 943                 (:from
 944                  (unless (eq kind :result)
 945                    (error "can only specify :FROM in a result: ~S" spec))
 946                  (setf (operand-parse-born res) (parse-time-spec value)))
 947                 (:to
 948                  (unless (eq kind :argument)
 949                    (error "can only specify :TO in an argument: ~S" spec))
 950                  (setf (operand-parse-dies res) (parse-time-spec value)))
 951                 (t
 952                  (error "unknown keyword in operand specifier: ~S" spec)))))
 953
 954           (cond ((not more)
 955                  (operands res))
 956                 ((operand-parse-target more)
 957                  (error "cannot specify :TARGET in a :MORE operand"))
 958                 ((operand-parse-load more)
 959                  (error "cannot specify :LOAD-IF in a :MORE operand")))))
 960       (values (the list (operands)) more))))
 961 \f
 962 ;;; Parse a temporary specification, putting the OPERAND-PARSE
 963 ;;; structures in the PARSE structure.
 964 (defun parse-temporary (spec parse)
 965   (declare (list spec)
 966            (type vop-parse parse))
 967   (let ((len (length spec)))
 968     (unless (>= len 2)
 969       (error "malformed temporary spec: ~S" spec))
 970     (unless (listp (second spec))
 971       (error "malformed options list: ~S" (second spec)))
 972     (unless (evenp (length (second spec)))
 973       (error "odd number of arguments in keyword options: ~S" spec))
 974     (unless (consp (cddr spec))
 975       (warn "temporary spec allocates no temps:~%  ~S" spec))
 976     (dolist (name (cddr spec))
 977       (unless (symbolp name)
 978         (error "bad temporary name: ~S" name))
 979       (let ((res (make-operand-parse :name name
 980                                      :kind :temporary
 981                                      :temp-temp (gensym)
 982                                      :born (parse-time-spec :load)
 983                                      :dies (parse-time-spec :save))))
 984         (do ((opt (second spec) (cddr opt)))
 985             ((null opt))
 986           (case (first opt)
 987             (:target
 988              (setf (operand-parse-target res)
 989                    (vop-spec-arg opt 'symbol 1 nil)))
 990             (:sc
 991              (setf (operand-parse-sc res)
 992                    (vop-spec-arg opt 'symbol 1 nil)))
 993             (:offset
 994              (let ((offset (eval (second opt))))
 995                (aver (typep offset 'unsigned-byte))
 996                (setf (operand-parse-offset res) offset)))
 997             (:from
 998              (setf (operand-parse-born res) (parse-time-spec (second opt))))
 999             (:to
1000              (setf (operand-parse-dies res) (parse-time-spec (second opt))))
1001             ;; backward compatibility...
1002             (:scs
1003              (let ((scs (vop-spec-arg opt 'list 1 nil)))
1004                (unless (= (length scs) 1)
1005                  (error "must specify exactly one SC for a temporary"))
1006                (setf (operand-parse-sc res) (first scs))))
1007             (:type)
1008             (t
1009              (error "unknown temporary option: ~S" opt))))
1010
1011         (unless (and (time-spec-order (operand-parse-dies res)
1012                                       (operand-parse-born res))
1013                      (not (time-spec-order (operand-parse-born res)
1014                                            (operand-parse-dies res))))
1015           (error "Temporary lifetime doesn't begin before it ends: ~S" spec))
1016
1017         (unless (operand-parse-sc res)
1018           (error "must specify :SC for all temporaries: ~S" spec))
1019
1020         (setf (vop-parse-temps parse)
1021               (cons res
1022                     (remove name (vop-parse-temps parse)
1023                             :key #'operand-parse-name))))))
1024   (values))
1025 \f
1026 ;;; the top level parse function: clobber PARSE to represent the
1027 ;;; specified options.
1028 (defun parse-define-vop (parse specs)
1029   (declare (type vop-parse parse) (list specs))
1030   (dolist (spec specs)
1031     (unless (consp spec)
1032       (error "malformed option specification: ~S" spec))
1033     (case (first spec)
1034       (:args
1035        (multiple-value-bind (fixed more)
1036            (!parse-vop-operands parse (rest spec) :argument)
1037          (setf (vop-parse-args parse) fixed)
1038          (setf (vop-parse-more-args parse) more)))
1039       (:results
1040        (multiple-value-bind (fixed more)
1041            (!parse-vop-operands parse (rest spec) :result)
1042          (setf (vop-parse-results parse) fixed)
1043          (setf (vop-parse-more-results parse) more))
1044        (setf (vop-parse-conditional-p parse) nil))
1045       (:conditional
1046        (setf (vop-parse-result-types parse) ())
1047        (setf (vop-parse-results parse) ())
1048        (setf (vop-parse-more-results parse) nil)
1049        (setf (vop-parse-conditional-p parse) t))
1050       (:temporary
1051        (parse-temporary spec parse))
1052       (:generator
1053        (setf (vop-parse-cost parse)
1054              (vop-spec-arg spec 'unsigned-byte 1 nil))
1055        (setf (vop-parse-body parse) (cddr spec)))
1056       (:effects
1057        (setf (vop-parse-effects parse) (rest spec)))
1058       (:affected
1059        (setf (vop-parse-affected parse) (rest spec)))
1060       (:info
1061        (setf (vop-parse-info-args parse) (rest spec)))
1062       (:ignore
1063        (setf (vop-parse-ignores parse) (rest spec)))
1064       (:variant
1065        (setf (vop-parse-variant parse) (rest spec)))
1066       (:variant-vars
1067        (let ((vars (rest spec)))
1068          (setf (vop-parse-variant-vars parse) vars)
1069          (setf (vop-parse-variant parse)
1070                (make-list (length vars) :initial-element nil))))
1071       (:variant-cost
1072        (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
1073       (:vop-var
1074        (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
1075       (:move-args
1076        (setf (vop-parse-move-args parse)
1077              (vop-spec-arg spec '(member nil :local-call :full-call
1078                                          :known-return))))
1079       (:node-var
1080        (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
1081       (:note
1082        (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
1083       (:arg-types
1084        (setf (vop-parse-arg-types parse)
1085              (!parse-vop-operand-types (rest spec) t)))
1086       (:result-types
1087        (setf (vop-parse-result-types parse)
1088              (!parse-vop-operand-types (rest spec) nil)))
1089       (:translate
1090        (setf (vop-parse-translate parse) (rest spec)))
1091       (:guard
1092        (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
1093       ;; FIXME: :LTN-POLICY would be a better name for this. It would
1094       ;; probably be good to leave it unchanged for a while, though,
1095       ;; at least until the first port to some other architecture,
1096       ;; since the renaming would be a change to the interface between
1097       (:policy
1098        (setf (vop-parse-ltn-policy parse)
1099              (vop-spec-arg spec 'ltn-policy)))
1100       (:save-p
1101        (setf (vop-parse-save-p parse)
1102              (vop-spec-arg spec
1103                            '(member t nil :compute-only :force-to-stack))))
1104       (t
1105        (error "unknown option specifier: ~S" (first spec)))))
1106   (values))
1107 \f
1108 ;;;; making costs and restrictions
1109
1110 ;;; Given an operand, returns two values:
1111 ;;; 1. A SC-vector of the cost for the operand being in that SC,
1112 ;;;    including both the costs for move functions and coercion VOPs.
1113 ;;; 2. A SC-vector holding the SC that we load into, for any SC
1114 ;;;    that we can directly load from.
1115 ;;;
1116 ;;; In both vectors, unused entries are NIL. LOAD-P specifies the
1117 ;;; direction: if true, we are loading, if false we are saving.
1118 (defun compute-loading-costs (op load-p)
1119   (declare (type operand-parse op))
1120   (let ((scs (operand-parse-scs op))
1121         (costs (make-array sc-number-limit :initial-element nil))
1122         (load-scs (make-array sc-number-limit :initial-element nil)))
1123     (dolist (sc-name scs)
1124       (let* ((load-sc (meta-sc-or-lose sc-name))
1125              (load-scn (sc-number load-sc)))
1126         (setf (svref costs load-scn) 0)
1127         (setf (svref load-scs load-scn) t)
1128         (dolist (op-sc (append (when load-p
1129                                  (sc-constant-scs load-sc))
1130                                (sc-alternate-scs load-sc)))
1131           (let* ((op-scn (sc-number op-sc))
1132                  (load (if load-p
1133                            (aref (sc-load-costs load-sc) op-scn)
1134                            (aref (sc-load-costs op-sc) load-scn))))
1135             (unless load
1136               (error "no move function defined to move ~:[from~;to~] SC ~
1137                       ~S~%~:[to~;from~] alternate or constant SC ~S"
1138                      load-p sc-name load-p (sc-name op-sc)))
1139
1140             (let ((op-cost (svref costs op-scn)))
1141               (when (or (not op-cost) (< load op-cost))
1142                 (setf (svref costs op-scn) load)))
1143
1144             (let ((op-load (svref load-scs op-scn)))
1145               (unless (eq op-load t)
1146                 (pushnew load-scn (svref load-scs op-scn))))))
1147
1148         (dotimes (i sc-number-limit)
1149           (unless (svref costs i)
1150             (let ((op-sc (svref *backend-meta-sc-numbers* i)))
1151               (when op-sc
1152                 (let ((cost (if load-p
1153                                 (svref (sc-move-costs load-sc) i)
1154                                 (svref (sc-move-costs op-sc) load-scn))))
1155                   (when cost
1156                     (setf (svref costs i) cost)))))))))
1157
1158     (values costs load-scs)))
1159
1160 (defparameter *no-costs*
1161   (make-array sc-number-limit :initial-element 0))
1162
1163 (defparameter *no-loads*
1164   (make-array sc-number-limit :initial-element t))
1165
1166 ;;; Pick off the case of operands with no restrictions.
1167 (defun compute-loading-costs-if-any (op load-p)
1168   (declare (type operand-parse op))
1169   (if (operand-parse-scs op)
1170       (compute-loading-costs op load-p)
1171       (values *no-costs* *no-loads*)))
1172
1173 (defun compute-costs-and-restrictions-list (ops load-p)
1174   (declare (list ops))
1175   (collect ((costs)
1176             (scs))
1177     (dolist (op ops)
1178       (multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p)
1179         (costs costs)
1180         (scs scs)))
1181     (values (costs) (scs))))
1182
1183 (defun make-costs-and-restrictions (parse)
1184   (multiple-value-bind (arg-costs arg-scs)
1185       (compute-costs-and-restrictions-list (vop-parse-args parse) t)
1186     (multiple-value-bind (result-costs result-scs)
1187         (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
1188       `(
1189         :cost ,(vop-parse-cost parse)
1190
1191         :arg-costs ',arg-costs
1192         :arg-load-scs ',arg-scs
1193         :result-costs ',result-costs
1194         :result-load-scs ',result-scs
1195
1196         :more-arg-costs
1197         ',(if (vop-parse-more-args parse)
1198               (compute-loading-costs-if-any (vop-parse-more-args parse) t)
1199               nil)
1200
1201         :more-result-costs
1202         ',(if (vop-parse-more-results parse)
1203               (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
1204               nil)))))
1205 \f
1206 ;;;; operand checking and stuff
1207
1208 ;;; Given a list of arg/result restrictions, check for valid syntax
1209 ;;; and convert to canonical form.
1210 (defun !parse-vop-operand-types (specs args-p)
1211   (declare (list specs))
1212   (labels ((parse-operand-type (spec)
1213              (cond ((eq spec '*) spec)
1214                    ((symbolp spec)
1215                     (let ((alias (gethash spec
1216                                           *backend-primitive-type-aliases*)))
1217                       (if alias
1218                           (parse-operand-type alias)
1219                           `(:or ,spec))))
1220                    ((atom spec)
1221                     (error "bad thing to be a operand type: ~S" spec))
1222                    (t
1223                     (case (first spec)
1224                       (:or
1225                        (collect ((results))
1226                          (results :or)
1227                          (dolist (item (cdr spec))
1228                            (unless (symbolp item)
1229                              (error "bad PRIMITIVE-TYPE name in ~S: ~S"
1230                                     spec item))
1231                            (let ((alias
1232                                   (gethash item
1233                                            *backend-primitive-type-aliases*)))
1234                              (if alias
1235                                  (let ((alias (parse-operand-type alias)))
1236                                    (unless (eq (car alias) :or)
1237                                      (error "can't include primitive-type ~
1238                                              alias ~S in an :OR restriction: ~S"
1239                                             item spec))
1240                                    (dolist (x (cdr alias))
1241                                      (results x)))
1242                                  (results item))))
1243                          (remove-duplicates (results)
1244                                             :test #'eq
1245                                             :start 1)))
1246                       (:constant
1247                        (unless args-p
1248                          (error "can't :CONSTANT for a result"))
1249                        (unless (= (length spec) 2)
1250                          (error "bad :CONSTANT argument type spec: ~S" spec))
1251                        spec)
1252                       (t
1253                        (error "bad thing to be a operand type: ~S" spec)))))))
1254     (mapcar #'parse-operand-type specs)))
1255
1256 ;;; Check the consistency of Op's Sc restrictions with the specified
1257 ;;; primitive-type restriction. :CONSTANT operands have already been
1258 ;;; filtered out, so only :OR and * restrictions are left.
1259 ;;;
1260 ;;; We check that every representation allowed by the type can be
1261 ;;; directly loaded into some SC in the restriction, and that the type
1262 ;;; allows every SC in the restriction. With *, we require that T
1263 ;;; satisfy the first test, and omit the second.
1264 (defun check-operand-type-scs (parse op type load-p)
1265   (declare (type vop-parse parse) (type operand-parse op))
1266   (let ((ptypes (if (eq type '*) (list t) (rest type)))
1267         (scs (operand-parse-scs op)))
1268     (when scs
1269       (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p)
1270         (declare (ignore costs))
1271         (dolist (ptype ptypes)
1272           (unless (dolist (rep (primitive-type-scs
1273                                 (meta-primitive-type-or-lose ptype))
1274                                nil)
1275                     (when (svref load-scs rep) (return t)))
1276             (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
1277                     none of the SCs allowed by the operand type ~S can ~
1278                     directly be loaded~@
1279                     into any of the restriction's SCs:~%  ~S~:[~;~@
1280                     [* type operand must allow T's SCs.]~]"
1281                    (operand-parse-name op) load-p (vop-parse-name parse)
1282                    ptype
1283                    scs (eq type '*)))))
1284
1285       (dolist (sc scs)
1286         (unless (or (eq type '*)
1287                     (dolist (ptype ptypes nil)
1288                       (when (meta-sc-allowed-by-primitive-type
1289                              (meta-sc-or-lose sc)
1290                              (meta-primitive-type-or-lose ptype))
1291                         (return t))))
1292           (warn "~:[Result~;Argument~] ~A to VOP ~S~@
1293                  has SC restriction ~S which is ~
1294                  not allowed by the operand type:~%  ~S"
1295                 load-p (operand-parse-name op) (vop-parse-name parse)
1296                 sc type)))))
1297
1298   (values))
1299
1300 ;;; If the operand types are specified, then check the number specified
1301 ;;; against the number of defined operands.
1302 (defun check-operand-types (parse ops more-op types load-p)
1303   (declare (type vop-parse parse) (list ops)
1304            (type (or list (member :unspecified)) types)
1305            (type (or operand-parse null) more-op))
1306   (unless (eq types :unspecified)
1307     (let ((num (+ (length ops) (if more-op 1 0))))
1308       (unless (= (count-if-not (lambda (x)
1309                                  (and (consp x)
1310                                       (eq (car x) :constant)))
1311                                types)
1312                  num)
1313         (error "expected ~W ~:[result~;argument~] type~P: ~S"
1314                num load-p types num)))
1315
1316     (when more-op
1317       (let ((mtype (car (last types))))
1318         (when (and (consp mtype) (eq (first mtype) :constant))
1319           (error "can't use :CONSTANT on VOP more args")))))
1320
1321   (when (vop-parse-translate parse)
1322     (let ((types (specify-operand-types types ops more-op)))
1323       (mapc (lambda (x y)
1324               (check-operand-type-scs parse x y load-p))
1325             (if more-op (butlast ops) ops)
1326             (remove-if (lambda (x)
1327                          (and (consp x)
1328                               (eq (car x) ':constant)))
1329                        (if more-op (butlast types) types)))))
1330
1331   (values))
1332
1333 ;;; Compute stuff that can only be computed after we are done parsing
1334 ;;; everying. We set the VOP-Parse-Operands, and do various error checks.
1335 (defun !grovel-vop-operands (parse)
1336   (declare (type vop-parse parse))
1337
1338   (setf (vop-parse-operands parse)
1339         (append (vop-parse-args parse)
1340                 (if (vop-parse-more-args parse)
1341                     (list (vop-parse-more-args parse)))
1342                 (vop-parse-results parse)
1343                 (if (vop-parse-more-results parse)
1344                     (list (vop-parse-more-results parse)))
1345                 (vop-parse-temps parse)))
1346
1347   (check-operand-types parse
1348                        (vop-parse-args parse)
1349                        (vop-parse-more-args parse)
1350                        (vop-parse-arg-types parse)
1351                        t)
1352
1353   (check-operand-types parse
1354                        (vop-parse-results parse)
1355                        (vop-parse-more-results parse)
1356                        (vop-parse-result-types parse)
1357                        nil)
1358
1359   (values))
1360 \f
1361 ;;;; function translation stuff
1362
1363 ;;; Return forms to establish this VOP as a IR2 translation template
1364 ;;; for the :TRANSLATE functions specified in the VOP-Parse. We also
1365 ;;; set the Predicate attribute for each translated function when the
1366 ;;; VOP is conditional, causing IR1 conversion to ensure that a call
1367 ;;; to the translated is always used in a predicate position.
1368 (defun !set-up-fun-translation (parse n-template)
1369   (declare (type vop-parse parse))
1370   (mapcar (lambda (name)
1371             `(let ((info (fun-info-or-lose ',name)))
1372                (setf (fun-info-templates info)
1373                      (adjoin-template ,n-template (fun-info-templates info)))
1374                ,@(when (vop-parse-conditional-p parse)
1375                    '((setf (fun-info-attributes info)
1376                            (attributes-union
1377                             (ir1-attributes predicate)
1378                             (fun-info-attributes info)))))))
1379           (vop-parse-translate parse)))
1380
1381 ;;; Return a form that can be evaluated to get the TEMPLATE operand type
1382 ;;; restriction from the given specification.
1383 (defun make-operand-type (type)
1384   (cond ((eq type '*) ''*)
1385         ((symbolp type)
1386          ``(:or ,(primitive-type-or-lose ',type)))
1387         (t
1388          (ecase (first type)
1389            (:or
1390             ``(:or ,,@(mapcar (lambda (type)
1391                                 `(primitive-type-or-lose ',type))
1392                               (rest type))))
1393            (:constant
1394             ``(:constant ,#'(lambda (x)
1395                               (typep x ',(second type)))
1396                          ,',(second type)))))))
1397
1398 (defun specify-operand-types (types ops more-ops)
1399   (if (eq types :unspecified)
1400       (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
1401       types))
1402
1403 ;;; Return a list of forms to use as &KEY args to MAKE-VOP-INFO for
1404 ;;; setting up the template argument and result types. Here we make an
1405 ;;; initial dummy TEMPLATE-TYPE, since it is awkward to compute the
1406 ;;; type until the template has been made.
1407 (defun make-vop-info-types (parse)
1408   (let* ((more-args (vop-parse-more-args parse))
1409          (all-args (specify-operand-types (vop-parse-arg-types parse)
1410                                           (vop-parse-args parse)
1411                                           more-args))
1412          (args (if more-args (butlast all-args) all-args))
1413          (more-arg (when more-args (car (last all-args))))
1414          (more-results (vop-parse-more-results parse))
1415          (all-results (specify-operand-types (vop-parse-result-types parse)
1416                                              (vop-parse-results parse)
1417                                              more-results))
1418          (results (if more-results (butlast all-results) all-results))
1419          (more-result (when more-results (car (last all-results))))
1420          (conditional (vop-parse-conditional-p parse)))
1421
1422     `(:type (specifier-type '(function () nil))
1423       :arg-types (list ,@(mapcar #'make-operand-type args))
1424       :more-args-type ,(when more-args (make-operand-type more-arg))
1425       :result-types ,(if conditional
1426                          :conditional
1427                          `(list ,@(mapcar #'make-operand-type results)))
1428       :more-results-type ,(when more-results
1429                             (make-operand-type more-result)))))
1430 \f
1431 ;;;; setting up VOP-INFO
1432
1433 (eval-when (:compile-toplevel :load-toplevel :execute)
1434   (defparameter *slot-inherit-alist*
1435     '((:generator-function . vop-info-generator-function))))
1436
1437 ;;; This is something to help with inheriting VOP-Info slots. We
1438 ;;; return a keyword/value pair that can be passed to the constructor.
1439 ;;; SLOT is the keyword name of the slot, Parse is a form that
1440 ;;; evaluates to the VOP-Parse structure for the VOP inherited. If
1441 ;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to
1442 ;;; true, then we return a form that selects the named slot from the
1443 ;;; VOP-Info structure corresponding to PARSE. Otherwise, we return
1444 ;;; the FORM so that the slot is recomputed.
1445 (defmacro inherit-vop-info (slot parse test form)
1446   `(if (and ,parse ,test)
1447        (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*))
1448                             (error "unknown slot ~S" slot))
1449                      (template-or-lose ',(vop-parse-name ,parse))))
1450        (list ,slot ,form)))
1451
1452 ;;; Return a form that creates a VOP-Info structure which describes VOP.
1453 (defun set-up-vop-info (iparse parse)
1454   (declare (type vop-parse parse) (type (or vop-parse null) iparse))
1455   (let ((same-operands
1456          (and iparse
1457               (equal (vop-parse-operands parse)
1458                      (vop-parse-operands iparse))
1459               (equal (vop-parse-info-args iparse)
1460                      (vop-parse-info-args parse))))
1461         (variant (vop-parse-variant parse)))
1462
1463     (let ((nvars (length (vop-parse-variant-vars parse))))
1464       (unless (= (length variant) nvars)
1465         (error "expected ~W variant values: ~S" nvars variant)))
1466
1467     `(make-vop-info
1468       :name ',(vop-parse-name parse)
1469       ,@(make-vop-info-types parse)
1470       :guard ,(when (vop-parse-guard parse)
1471                 `(lambda () ,(vop-parse-guard parse)))
1472       :note ',(vop-parse-note parse)
1473       :info-arg-count ,(length (vop-parse-info-args parse))
1474       :ltn-policy ',(vop-parse-ltn-policy parse)
1475       :save-p ',(vop-parse-save-p parse)
1476       :move-args ',(vop-parse-move-args parse)
1477       :effects (vop-attributes ,@(vop-parse-effects parse))
1478       :affected (vop-attributes ,@(vop-parse-affected parse))
1479       ,@(make-costs-and-restrictions parse)
1480       ,@(make-emit-function-and-friends parse)
1481       ,@(inherit-vop-info :generator-function iparse
1482           (and same-operands
1483                (equal (vop-parse-body parse) (vop-parse-body iparse)))
1484           (unless (eq (vop-parse-body parse) :unspecified)
1485             (make-generator-function parse)))
1486       :variant (list ,@variant))))
1487 \f
1488 ;;; Define the symbol NAME to be a Virtual OPeration in the compiler.
1489 ;;; If specified, INHERITS is the name of a VOP that we default
1490 ;;; unspecified information from. Each SPEC is a list beginning with a
1491 ;;; keyword indicating the interpretation of the other forms in the
1492 ;;; SPEC:
1493 ;;;
1494 ;;; :Args {(Name {Key Value}*)}*
1495 ;;; :Results {(Name {Key Value}*)}*
1496 ;;;     The Args and Results are specifications of the operand TNs passed
1497 ;;;     to the VOP. If there is an inherited VOP, any unspecified options
1498 ;;;     are defaulted from the inherited argument (or result) of the same
1499 ;;;     name. The following operand options are defined:
1500 ;;;
1501 ;;; :SCs (SC*)
1502 ;;;     :SCs specifies good SCs for this operand. Other SCs will be
1503 ;;;     penalized according to move costs. A load TN will be allocated if
1504 ;;;     necessary, guaranteeing that the operand is always one of the
1505 ;;;     specified SCs.
1506 ;;;
1507 ;;;     :Load-TN Load-Name
1508 ;;;         Load-Name is bound to the load TN allocated for this operand,
1509 ;;;         or to NIL if no load TN was allocated.
1510 ;;;
1511 ;;;     :Load-If EXPRESSION
1512 ;;;         Controls whether automatic operand loading is done.
1513 ;;;         EXPRESSION is evaluated with the fixed operand TNs bound.
1514 ;;;         If EXPRESSION is true,then loading is done and the variable
1515 ;;;         is bound to the load TN in the generator body. Otherwise,
1516 ;;;         loading is not done, and the variable is bound to the actual
1517 ;;;         operand.
1518 ;;;
1519 ;;;     :More T-or-NIL
1520 ;;;         If specified, Name is bound to the TN-Ref for the first
1521 ;;;         argument or result following the fixed arguments or results.
1522 ;;;         A :MORE operand must appear last, and cannot be targeted or
1523 ;;;         restricted.
1524 ;;;
1525 ;;;     :Target Operand
1526 ;;;         This operand is targeted to the named operand, indicating a
1527 ;;;         desire to pack in the same location. Not legal for results.
1528 ;;;
1529 ;;;     :From Time-Spec
1530 ;;;     :To Time-Spec
1531 ;;;         Specify the beginning or end of the operand's lifetime.
1532 ;;;         :FROM can only be used with results, and :TO only with
1533 ;;;         arguments. The default for the N'th argument/result is
1534 ;;;         (:ARGUMENT N)/(:RESULT N). These options are necessary
1535 ;;;         primarily when operands are read or written out of order.
1536 ;;;
1537 ;;; :Conditional
1538 ;;;     This is used in place of :RESULTS with conditional branch VOPs.
1539 ;;;     There are no result values: the result is a transfer of control.
1540 ;;;     The target label is passed as the first :INFO arg. The second
1541 ;;;     :INFO arg is true if the sense of the test should be negated.
1542 ;;;     A side-effect is to set the PREDICATE attribute for functions
1543 ;;;     in the :TRANSLATE option.
1544 ;;;
1545 ;;; :Temporary ({Key Value}*) Name*
1546 ;;;     Allocate a temporary TN for each Name, binding that variable to
1547 ;;;     the TN within the body of the generators. In addition to :TARGET
1548 ;;;     (which is is the same as for operands), the following options are
1549 ;;;     defined:
1550 ;;;
1551 ;;;     :SC SC-Name
1552 ;;;     :Offset SB-Offset
1553 ;;;         Force the temporary to be allocated in the specified SC with the
1554 ;;;         specified offset. Offset is evaluated at macroexpand time. If
1555 ;;;         Offset is emitted, the register allocator chooses a free
1556 ;;;         location in SC. If both SC and Offset are omitted, then the
1557 ;;;         temporary is packed according to its primitive type.
1558 ;;;
1559 ;;;     :From Time-Spec
1560 ;;;     :To Time-Spec
1561 ;;;         Similar to the argument/result option, this specifies the start and
1562 ;;;         end of the temporaries' lives. The defaults are :Load and :Save,
1563 ;;;         i.e. the duration of the VOP. The other intervening phases are
1564 ;;;         :Argument,:Eval and :Result. Non-zero sub-phases can be specified
1565 ;;;         by a list, e.g. by default the second argument's life ends at
1566 ;;;         (:Argument 1).
1567 ;;;
1568 ;;; :Generator Cost Form*
1569 ;;;     Specifies the translation into assembly code. Cost is the
1570 ;;;     estimated cost of the code emitted by this generator. The body
1571 ;;;     is arbitrary Lisp code that emits the assembly language
1572 ;;;     translation of the VOP. An ASSEMBLE form is wrapped around
1573 ;;;     the body, so code may be emitted by using the local INST macro.
1574 ;;;     During the evaluation of the body, the names of the operands
1575 ;;;     and temporaries are bound to the actual TNs.
1576 ;;;
1577 ;;; :Effects Effect*
1578 ;;; :Affected Effect*
1579 ;;;     Specifies the side effects that this VOP has and the side
1580 ;;;     effects that effect its execution. If unspecified, these
1581 ;;;     default to the worst case.
1582 ;;;
1583 ;;; :Info Name*
1584 ;;;     Define some magic arguments that are passed directly to the code
1585 ;;;     generator. The corresponding trailing arguments to VOP or
1586 ;;;     %PRIMITIVE are stored in the VOP structure. Within the body
1587 ;;;     of the generators, the named variables are bound to these
1588 ;;;     values. Except in the case of :Conditional VOPs, :Info arguments
1589 ;;;     cannot be specified for VOPS that are the direct translation
1590 ;;;     for a function (specified by :Translate).
1591 ;;;
1592 ;;; :Ignore Name*
1593 ;;;     Causes the named variables to be declared IGNORE in the
1594 ;;;     generator body.
1595 ;;;
1596 ;;; :Variant Thing*
1597 ;;; :Variant-Vars Name*
1598 ;;;     These options provide a way to parameterize families of VOPs
1599 ;;;     that differ only trivially. :Variant makes the specified
1600 ;;;     evaluated Things be the "variant" associated with this VOP.
1601 ;;;     :VARIANT-VARS causes the named variables to be bound to the
1602 ;;;     corresponding Things within the body of the generator.
1603 ;;;
1604 ;;; :Variant-Cost Cost
1605 ;;;     Specifies the cost of this VOP, overriding the cost of any
1606 ;;;     inherited generator.
1607 ;;;
1608 ;;; :Note {String | NIL}
1609 ;;;     A short noun-like phrase describing what this VOP "does", i.e.
1610 ;;;     the implementation strategy. If supplied, efficiency notes will
1611 ;;;     be generated when type uncertainty prevents :TRANSLATE from
1612 ;;;     working. NIL inhibits any efficiency note.
1613 ;;;
1614 ;;; :Arg-Types    {* | PType | (:OR PType*) | (:CONSTANT Type)}*
1615 ;;; :Result-Types {* | PType | (:OR PType*)}*
1616 ;;;     Specify the template type restrictions used for automatic translation.
1617 ;;;     If there is a :More operand, the last type is the more type. :CONSTANT
1618 ;;;     specifies that the argument must be a compile-time constant of the
1619 ;;;     specified Lisp type. The constant values of :CONSTANT arguments are
1620 ;;;     passed as additional :INFO arguments rather than as :ARGS.
1621 ;;;
1622 ;;; :Translate Name*
1623 ;;;     This option causes the VOP template to be entered as an IR2
1624 ;;;     translation for the named functions.
1625 ;;;
1626 ;;; :Policy {:Small | :Fast | :Safe | :Fast-Safe}
1627 ;;;     Specifies the policy under which this VOP is the best translation.
1628 ;;;
1629 ;;; :Guard Form
1630 ;;;     Specifies a Form that is evaluated in the global environment. If
1631 ;;;     form returns NIL, then emission of this VOP is prohibited even when
1632 ;;;     all other restrictions are met.
1633 ;;;
1634 ;;; :VOP-Var Name
1635 ;;; :Node-Var Name
1636 ;;;     In the generator, bind the specified variable to the VOP or
1637 ;;;     the Node that generated this VOP.
1638 ;;;
1639 ;;; :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
1640 ;;;     Indicates how a VOP wants live registers saved.
1641 ;;;
1642 ;;; :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
1643 ;;;     Indicates if and how the more args should be moved into a
1644 ;;;     different frame.
1645 (def!macro define-vop ((name &optional inherits) &rest specs)
1646   (declare (type symbol name))
1647   ;; Parse the syntax into a VOP-PARSE structure, and then expand into
1648   ;; code that creates the appropriate VOP-INFO structure at load time.
1649   ;; We implement inheritance by copying the VOP-PARSE structure for
1650   ;; the inherited structure.
1651   (let* ((inherited-parse (when inherits
1652                             (vop-parse-or-lose inherits)))
1653          (parse (if inherits
1654                     (copy-vop-parse inherited-parse)
1655                     (make-vop-parse)))
1656          (n-res (gensym)))
1657     (setf (vop-parse-name parse) name)
1658     (setf (vop-parse-inherits parse) inherits)
1659
1660     (parse-define-vop parse specs)
1661     (!grovel-vop-operands parse)
1662
1663     `(progn
1664        (eval-when (:compile-toplevel :load-toplevel :execute)
1665          (setf (gethash ',name *backend-parsed-vops*)
1666                ',parse))
1667
1668        (let ((,n-res ,(set-up-vop-info inherited-parse parse)))
1669          (setf (gethash ',name *backend-template-names*) ,n-res)
1670          (setf (template-type ,n-res)
1671                (specifier-type (template-type-specifier ,n-res)))
1672          ,@(!set-up-fun-translation parse n-res))
1673        ',name)))
1674 \f
1675 ;;;; emission macros
1676
1677 ;;; Return code to make a list of VOP arguments or results, linked by
1678 ;;; TN-Ref-Across. The first value is code, the second value is LET*
1679 ;;; forms, and the third value is a variable that evaluates to the
1680 ;;; head of the list, or NIL if there are no operands. Fixed is a list
1681 ;;; of forms that evaluate to TNs for the fixed operands. TN-Refs will
1682 ;;; be made for these operands according using the specified value of
1683 ;;; Write-P. More is an expression that evaluates to a list of TN-Refs
1684 ;;; that will be made the tail of the list. If it is constant NIL,
1685 ;;; then we don't bother to set the tail.
1686 (defun make-operand-list (fixed more write-p)
1687   (collect ((forms)
1688             (binds))
1689     (let ((n-head nil)
1690           (n-prev nil))
1691       (dolist (op fixed)
1692         (let ((n-ref (gensym)))
1693           (binds `(,n-ref (reference-tn ,op ,write-p)))
1694           (if n-prev
1695               (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
1696               (setq n-head n-ref))
1697           (setq n-prev n-ref)))
1698
1699       (when more
1700         (let ((n-more (gensym)))
1701           (binds `(,n-more ,more))
1702           (if n-prev
1703               (forms `(setf (tn-ref-across ,n-prev) ,n-more))
1704               (setq n-head n-more))))
1705
1706       (values (forms) (binds) n-head))))
1707
1708 ;;; Emit-Template Node Block Template Args Results [Info]
1709 ;;;
1710 ;;; Call the emit function for Template, linking the result in at the
1711 ;;; end of Block.
1712 (defmacro emit-template (node block template args results &optional info)
1713   (let ((n-first (gensym))
1714         (n-last (gensym)))
1715     (once-only ((n-node node)
1716                 (n-block block)
1717                 (n-template template))
1718       `(multiple-value-bind (,n-first ,n-last)
1719            (funcall (template-emit-function ,n-template)
1720                     ,n-node ,n-block ,n-template ,args ,results
1721                     ,@(when info `(,info)))
1722          (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
1723
1724 ;;; VOP Name Node Block Arg* Info* Result*
1725 ;;;
1726 ;;; Emit the VOP (or other template) Name at the end of the IR2-Block
1727 ;;; Block, using Node for the source context. The interpretation of
1728 ;;; the remaining arguments depends on the number of operands of
1729 ;;; various kinds that are declared in the template definition. VOP
1730 ;;; cannot be used for templates that have more-args or more-results,
1731 ;;; since the number of arguments and results is indeterminate for
1732 ;;; these templates. Use VOP* instead.
1733 ;;;
1734 ;;; Args and Results are the TNs that are to be referenced by the
1735 ;;; template as arguments and results. If the template has
1736 ;;; codegen-info arguments, then the appropriate number of Info forms
1737 ;;; following the Arguments are used for codegen info.
1738 (defmacro vop (name node block &rest operands)
1739   (let* ((parse (vop-parse-or-lose name))
1740          (arg-count (length (vop-parse-args parse)))
1741          (result-count (length (vop-parse-results parse)))
1742          (info-count (length (vop-parse-info-args parse)))
1743          (noperands (+ arg-count result-count info-count))
1744          (n-node (gensym))
1745          (n-block (gensym))
1746          (n-template (gensym)))
1747
1748     (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
1749       (error "cannot use VOP with variable operand count templates"))
1750     (unless (= noperands (length operands))
1751       (error "called with ~W operands, but was expecting ~W"
1752              (length operands) noperands))
1753
1754     (multiple-value-bind (acode abinds n-args)
1755         (make-operand-list (subseq operands 0 arg-count) nil nil)
1756       (multiple-value-bind (rcode rbinds n-results)
1757           (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
1758
1759         (collect ((ibinds)
1760                   (ivars))
1761           (dolist (info (subseq operands arg-count (+ arg-count info-count)))
1762             (let ((temp (gensym)))
1763               (ibinds `(,temp ,info))
1764               (ivars temp)))
1765
1766           `(let* ((,n-node ,node)
1767                   (,n-block ,block)
1768                   (,n-template (template-or-lose ',name))
1769                   ,@abinds
1770                   ,@(ibinds)
1771                   ,@rbinds)
1772              ,@acode
1773              ,@rcode
1774              (emit-template ,n-node ,n-block ,n-template ,n-args
1775                             ,n-results
1776                             ,@(when (ivars)
1777                                 `((list ,@(ivars)))))
1778              (values)))))))
1779
1780 ;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
1781 ;;;
1782 ;;; This is like VOP, but allows for emission of templates with
1783 ;;; arbitrary numbers of arguments, and for emission of templates
1784 ;;; using already-created TN-Ref lists.
1785 ;;;
1786 ;;; The Arguments and Results are TNs to be referenced as the first
1787 ;;; arguments and results to the template. More-Args and More-Results
1788 ;;; are heads of TN-Ref lists that are added onto the end of the
1789 ;;; TN-Refs for the explicitly supplied operand TNs. The TN-Refs for
1790 ;;; the more operands must have the TN and Write-P slots correctly
1791 ;;; initialized.
1792 ;;;
1793 ;;; As with VOP, the Info forms are evaluated and passed as codegen
1794 ;;; info arguments.
1795 (defmacro vop* (name node block args results &rest info)
1796   (declare (type cons args results))
1797   (let* ((parse (vop-parse-or-lose name))
1798          (arg-count (length (vop-parse-args parse)))
1799          (result-count (length (vop-parse-results parse)))
1800          (info-count (length (vop-parse-info-args parse)))
1801          (fixed-args (butlast args))
1802          (fixed-results (butlast results))
1803          (n-node (gensym))
1804          (n-block (gensym))
1805          (n-template (gensym)))
1806
1807     (unless (or (vop-parse-more-args parse)
1808                 (<= (length fixed-args) arg-count))
1809       (error "too many fixed arguments"))
1810     (unless (or (vop-parse-more-results parse)
1811                 (<= (length fixed-results) result-count))
1812       (error "too many fixed results"))
1813     (unless (= (length info) info-count)
1814       (error "expected ~W info args" info-count))
1815
1816     (multiple-value-bind (acode abinds n-args)
1817         (make-operand-list fixed-args (car (last args)) nil)
1818       (multiple-value-bind (rcode rbinds n-results)
1819           (make-operand-list fixed-results (car (last results)) t)
1820
1821         `(let* ((,n-node ,node)
1822                 (,n-block ,block)
1823                 (,n-template (template-or-lose ',name))
1824                 ,@abinds
1825                 ,@rbinds)
1826            ,@acode
1827            ,@rcode
1828            (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
1829                           ,@(when info
1830                               `((list ,@info))))
1831            (values))))))
1832 \f
1833 ;;;; miscellaneous macros
1834
1835 ;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
1836 ;;;
1837 ;;; Case off of TN's SC. The first clause containing TN's SC is
1838 ;;; evaluated, returning the values of the last form. A clause
1839 ;;; beginning with T specifies a default. If it appears, it must be
1840 ;;; last. If no default is specified, and no clause matches, then an
1841 ;;; error is signalled.
1842 (def!macro sc-case (tn &rest forms)
1843   (let ((n-sc (gensym))
1844         (n-tn (gensym)))
1845     (collect ((clauses))
1846       (do ((cases forms (rest cases)))
1847           ((null cases)
1848            (clauses `(t (error "unknown SC to SC-Case for ~S:~%  ~S" ,n-tn
1849                                (sc-name (tn-sc ,n-tn))))))
1850         (let ((case (first cases)))
1851           (when (atom case)
1852             (error "illegal SC-Case clause: ~S" case))
1853           (let ((head (first case)))
1854             (when (eq head t)
1855               (when (rest cases)
1856                 (error "T case is not last in SC-Case."))
1857               (clauses `(t nil ,@(rest case)))
1858               (return))
1859             (clauses `((or ,@(mapcar (lambda (x)
1860                                        `(eql ,(meta-sc-number-or-lose x)
1861                                              ,n-sc))
1862                                      (if (atom head) (list head) head)))
1863                        nil ,@(rest case))))))
1864
1865       `(let* ((,n-tn ,tn)
1866               (,n-sc (sc-number (tn-sc ,n-tn))))
1867          (cond ,@(clauses))))))
1868
1869 ;;; Return true if TNs SC is any of the named SCs, false otherwise.
1870 (defmacro sc-is (tn &rest scs)
1871   (once-only ((n-sc `(sc-number (tn-sc ,tn))))
1872     `(or ,@(mapcar (lambda (x)
1873                      `(eql ,n-sc ,(meta-sc-number-or-lose x)))
1874                    scs))))
1875
1876 ;;; Iterate over the IR2 blocks in component, in emission order.
1877 (defmacro do-ir2-blocks ((block-var component &optional result)
1878                          &body forms)
1879   `(do ((,block-var (block-info (component-head ,component))
1880                     (ir2-block-next ,block-var)))
1881        ((null ,block-var) ,result)
1882      ,@forms))
1883
1884 ;;; Iterate over all the TNs live at some point, with the live set
1885 ;;; represented by a local conflicts bit-vector and the IR2-Block
1886 ;;; containing the location.
1887 (defmacro do-live-tns ((tn-var live block &optional result) &body body)
1888   (let ((n-conf (gensym))
1889         (n-bod (gensym))
1890         (i (gensym))
1891         (ltns (gensym)))
1892     (once-only ((n-live live)
1893                 (n-block block))
1894       `(block nil
1895          (flet ((,n-bod (,tn-var) ,@body))
1896            ;; Do component-live TNs.
1897            (dolist (,tn-var (ir2-component-component-tns
1898                              (component-info
1899                               (block-component
1900                                (ir2-block-block ,n-block)))))
1901              (,n-bod ,tn-var))
1902
1903            (let ((,ltns (ir2-block-local-tns ,n-block)))
1904              ;; Do TNs always-live in this block and live :More TNs.
1905              (do ((,n-conf (ir2-block-global-tns ,n-block)
1906                            (global-conflicts-next ,n-conf)))
1907                  ((null ,n-conf))
1908                (when (or (eq (global-conflicts-kind ,n-conf) :live)
1909                          (let ((,i (global-conflicts-number ,n-conf)))
1910                            (and (eq (svref ,ltns ,i) :more)
1911                                 (not (zerop (sbit ,n-live ,i))))))
1912                  (,n-bod (global-conflicts-tn ,n-conf))))
1913              ;; Do TNs locally live in the designated live set.
1914              (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
1915                (unless (zerop (sbit ,n-live ,i))
1916                  (let ((,tn-var (svref ,ltns ,i)))
1917                    (when (and ,tn-var (not (eq ,tn-var :more)))
1918                      (,n-bod ,tn-var)))))))))))
1919
1920 ;;; Iterate over all the IR2 blocks in PHYSENV, in emit order.
1921 (defmacro do-physenv-ir2-blocks ((block-var physenv &optional result)
1922                                  &body body)
1923   (once-only ((n-physenv physenv))
1924     (once-only ((n-first `(lambda-block (physenv-lambda ,n-physenv))))
1925       (once-only ((n-tail `(block-info
1926                             (component-tail
1927                              (block-component ,n-first)))))
1928         `(do ((,block-var (block-info ,n-first)
1929                           (ir2-block-next ,block-var)))
1930              ((or (eq ,block-var ,n-tail)
1931                   (not (eq (ir2-block-physenv ,block-var) ,n-physenv)))
1932               ,result)
1933            ,@body)))))