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