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