src/compiler/meta-vmdef.lisp

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