home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / vmdef.lisp < prev    next >
Encoding:
Text File  |  1991-12-15  |  82.0 KB  |  2,450 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: vmdef.lisp,v 1.40 91/12/15 12:10:17 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains implementation-independent facilities used for
  15. ;;; defining the compiler's interface to the VM in a given implementation.
  16. ;;;
  17. ;;; Written by Rob MacLachlan
  18. ;;;
  19. (in-package 'c)
  20.  
  21. (export '(template-or-lose sc-or-lose sb-or-lose sc-number-or-lose
  22.       meta-sc-or-lose meta-sb-or-lose meta-sc-number-or-lose
  23.       define-storage-base define-storage-class define-move-function
  24.       define-move-function define-move-vop 
  25.       primitive-type-or-lose meta-primitive-type-or-lose
  26.       def-primitive-type def-primitive-type-alias
  27.       primitive-type-vop define-vop sc-case sc-is note-this-location))
  28.  
  29. ;;; Template-Or-Lose  --  Internal
  30. ;;;
  31. ;;;    Return the template having the specified name, or die trying.
  32. ;;;
  33. (defun template-or-lose (x &optional (backend *target-backend*))
  34.   (the template
  35.        (or (gethash x (backend-template-names backend))
  36.        (error "~S is not a defined template." x))))
  37.  
  38.  
  39. ;;; SC-Or-Lose, SB-Or-Lose, SC-Number-Or-Lose  --  Internal
  40. ;;;
  41. ;;;    Return the SC structure, SB structure or SC number corresponding to a
  42. ;;; name, or die trying.
  43. ;;;
  44. (defun sc-or-lose (x &optional (backend *target-backend*))
  45.   (the sc
  46.        (or (gethash x (backend-sc-names backend))
  47.        (error "~S is not a defined storage class." x))))
  48. ;;;
  49. (defun sb-or-lose (x &optional (backend *target-backend*))
  50.   (the sb
  51.        (or (gethash x (backend-sb-names backend))
  52.        (error "~S is not a defined storage base." x))))
  53. ;;;
  54. (defun sc-number-or-lose (x &optional (backend *target-backend*))
  55.   (the sc-number (sc-number (sc-or-lose x backend))))
  56.  
  57.  
  58. (eval-when (compile eval load)
  59.  
  60. ;;; META-SC-OR-LOSE, META-SB-OR-LOSE, META-SC-NUMBER-OR-LOSE  --  Internal
  61. ;;;
  62. ;;;    Like the non-meta versions, but go for the meta-compile-time info.
  63. ;;; These should not be used after load time, since compiling the compiler
  64. ;;; changes the definitions.
  65. ;;;
  66. (defun meta-sc-or-lose (x)
  67.   (the sc
  68.        (or (gethash x (backend-meta-sc-names *target-backend*))
  69.        (error "~S is not a defined storage class." x))))
  70. ;;;
  71. (defun meta-sb-or-lose (x)
  72.   (the sb
  73.        (or (gethash x (backend-meta-sb-names *target-backend*))
  74.        (error "~S is not a defined storage base." x))))
  75. ;;;
  76. (defun meta-sc-number-or-lose (x)
  77.   (the sc-number (sc-number (meta-sc-or-lose x))))
  78.  
  79. ); eval-when
  80.  
  81.  
  82. ;;;; Storage class and storage base definition:
  83.  
  84. ;;; Define-Storage-Base  --  Public
  85. ;;;
  86. ;;;    Enter the basic structure at meta-compile time, and then fill in the
  87. ;;; missing slots at load time.
  88. ;;;
  89. (defmacro define-storage-base (name kind &key size)
  90.   "Define-Storage-Base Name Kind {Key Value}*
  91.   Define a storage base having the specified Name.  Kind may be :Finite,
  92.   :Unbounded or :Non-Packed.  The following keywords are legal:
  93.  
  94.   :Size <Size>
  95.       Specify the number of locations in a :Finite SB or the initial size of a
  96.       :Unbounded SB."
  97.   (check-type name symbol)
  98.   (check-type kind (member :finite :unbounded :non-packed))
  99.   (ecase kind
  100.     (:non-packed
  101.      (when size
  102.        (error "Size specification meaningless in a ~S SB." kind)))
  103.     ((:finite :unbounded)
  104.      (unless size (error "Size not specified in a ~S SB." kind))
  105.      (check-type size unsigned-byte)))
  106.     
  107.   (let ((res (if (eq kind :non-packed)
  108.          (make-sb :name name :kind kind)
  109.          (make-finite-sb :name name :kind kind :size size))))
  110.     `(progn
  111.        (eval-when (compile load eval)
  112.      (setf (gethash ',name (backend-meta-sb-names *target-backend*))
  113.            ',res))
  114.        ,(if (eq kind :non-packed)
  115.         `(setf (gethash ',name (backend-sb-names *target-backend*))
  116.            (copy-sb ',res))
  117.         `(let ((res (copy-finite-sb ',res)))
  118.            (setf (finite-sb-always-live res)
  119.              (make-array ',size :initial-element #*))
  120.            (setf (finite-sb-conflicts res)
  121.              (make-array ',size :initial-element '#()))
  122.            (setf (finite-sb-live-tns res)
  123.              (make-array ',size :initial-element nil))
  124.            (setf (gethash ',name (backend-sb-names *target-backend*))
  125.              res)))
  126.  
  127.        (setf (backend-sb-list *target-backend*)
  128.          (cons (sb-or-lose ',name)
  129.            (remove ',name (backend-sb-list *target-backend*)
  130.                :key #'sb-name)))
  131.        ',name)))
  132.  
  133.  
  134. ;;; Define-Storage-Class  --  Public
  135. ;;;
  136. ;;;
  137. (defmacro define-storage-class (name number sb-name &key (element-size '1)
  138.                      (alignment '1) locations reserve-locations
  139.                      save-p alternate-scs constant-scs)
  140.   "Define-Storage-Class Name Number Storage-Base {Key Value}*
  141.   Define a storage class Name that uses the named Storage-Base.  Number is a
  142.   small, non-negative integer that is used as an alias.  The following
  143.   keywords are defined:
  144.  
  145.   :Element-Size Size
  146.       The size of objects in this SC in whatever units the SB uses.  This
  147.       defaults to 1.
  148.  
  149.   :Alignment Size
  150.       The alignment restrictions for this SC.  TNs will only be allocated at
  151.       offsets that are an even multiple of this number.  Defaults to 1.
  152.  
  153.   :Locations (Location*)
  154.       If the SB is :Finite, then this is a list of the offsets within the SB
  155.       that are in this SC.
  156.  
  157.   :Reserve-Locations (Location*)
  158.       A subset of the Locations that the register allocator should try to
  159.       reserve for operand loading (instead of to hold variable values.)
  160.  
  161.   :Save-P {T | NIL}
  162.       If T, then values stored in this SC must be saved in one of the
  163.       non-save-p :Alternate-SCs across calls.
  164.  
  165.   :Alternate-SCs (SC*)
  166.       Indicates other SCs that can be used to hold values from this SC across
  167.       calls or when storage in this SC is exhausted.  The SCs should be
  168.       specified in order of decreasing \"goodness\".  There must be at least
  169.       one SC in an unbounded SB, unless this SC is only used for restricted or
  170.       wired TNs.
  171.  
  172.   :Constant-SCs (SC*)
  173.       A list of the names of all the constant SCs that can be loaded into this
  174.       SC by a move function."
  175.   
  176.   (check-type name symbol)
  177.   (check-type number sc-number)
  178.   (check-type sb-name symbol)
  179.   (check-type locations list)
  180.   (check-type reserve-locations list)
  181.   (check-type save-p boolean)
  182.   (check-type alternate-scs list)
  183.   (check-type constant-scs list)
  184.  
  185.   (let ((sb (meta-sb-or-lose sb-name)))
  186.     (if (eq (sb-kind sb) :finite)
  187.     (let ((size (sb-size sb))
  188.           (element-size (eval element-size)))
  189.       (check-type element-size unsigned-byte)
  190.       (dolist (el locations)
  191.         (check-type el unsigned-byte)
  192.         (unless (<= 1 (+ el element-size) size)
  193.           (error "SC element ~D out of bounds for ~S." el sb))))
  194.     (when locations
  195.       (error ":Locations is meaningless in a ~S SB." (sb-kind sb))))
  196.  
  197.     (unless (subsetp reserve-locations locations)
  198.       (error "Reserve-Locations not a subset of Locations."))
  199.  
  200.     (when (and (or alternate-scs constant-scs)
  201.            (eq (sb-kind sb) :non-packed))
  202.       (error "Meaningless to specify alternate or constant SCs in a ~S SB."
  203.          (sb-kind sb))))
  204.  
  205.   (let ((nstack-p
  206.      (if (or (eq sb-name 'non-descriptor-stack)
  207.          (find 'non-descriptor-stack
  208.                (mapcar #'meta-sc-or-lose alternate-scs)
  209.                :key #'(lambda (x)
  210.                 (sb-name (sc-sb x)))))
  211.          t nil)))
  212.     `(progn
  213.        (eval-when (compile load eval)
  214.      (let ((res (make-sc :name ',name :number ',number
  215.                  :sb (meta-sb-or-lose ',sb-name)
  216.                  :element-size ,element-size
  217.                  :alignment ,alignment
  218.                  :locations ',locations
  219.                  :reserve-locations ',reserve-locations
  220.                  :save-p ',save-p
  221.                  :number-stack-p ,nstack-p
  222.                  :alternate-scs (mapcar #'meta-sc-or-lose
  223.                             ',alternate-scs)
  224.                  :constant-scs (mapcar #'meta-sc-or-lose
  225.                            ',constant-scs))))
  226.        (setf (gethash ',name (backend-meta-sc-names *target-backend*)) res)
  227.        (setf (svref (backend-meta-sc-numbers *target-backend*) ',number)
  228.          res)
  229.        (setf (svref (sc-load-costs res) ',number) 0)))
  230.  
  231.        (let ((old (svref (backend-sc-numbers *target-backend*) ',number)))
  232.      (when (and old (not (eq (sc-name old) ',name)))
  233.        (warn "Redefining SC number ~D from ~S to ~S." ',number
  234.          (sc-name old) ',name)))
  235.        
  236.        (setf (svref (backend-sc-numbers *target-backend*) ',number)
  237.          (meta-sc-or-lose ',name))
  238.        (setf (gethash ',name (backend-sc-names *target-backend*))
  239.          (meta-sc-or-lose ',name))
  240.        (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
  241.        ',name)))
  242.  
  243.  
  244. ;;;; Side-Effect Classes
  245.  
  246. (def-boolean-attribute vop
  247.   any)
  248.  
  249.  
  250.  
  251. ;;;; Move/coerce definition:
  252.  
  253.  
  254. ;;; DO-SC-PAIRS  --  Internal
  255. ;;;
  256. ;;;    Given a list of paris of lists of SCs (as given to DEFINE-MOVE-VOP,
  257. ;;; etc.), bind TO-SC and FROM-SC to all the combinations.
  258. ;;;
  259. (eval-when (compile load eval)
  260.   (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
  261.     `(do ((froms ,scs (cddr froms))
  262.       (tos (cdr ,scs) (cddr tos)))
  263.      ((null froms))
  264.        (dolist (from (car froms))
  265.      (let ((,from-sc-var (meta-sc-or-lose from)))
  266.        (dolist (to (car tos))
  267.          (let ((,to-sc-var (meta-sc-or-lose to)))
  268.            ,@body)))))))
  269.  
  270.  
  271. ;;; DEFINE-MOVE-FUNCTION  --  Public
  272. ;;;
  273. (defmacro define-move-function ((name cost) lambda-list scs &body body)
  274.   "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
  275.   Define the function Name and note it as the function used for moving operands
  276.   from the From-SCs to the To-SCs.  Cost is the cost of this move operation.
  277.   The function is called with three arguments: the VOP (for context), and the
  278.   source and destination TNs.  An ASSEMBLE form is wrapped around the body.
  279.   All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
  280.   DEFINE-VOP."
  281.   (when (or (oddp (length scs)) (null scs))
  282.     (error "Malformed SCs spec: ~S." scs))
  283.   (check-type cost index)
  284.   `(progn
  285.      (eval-when (compile load eval)
  286.        (do-sc-pairs (from-sc to-sc ',scs)
  287.      (unless (eq from-sc to-sc)
  288.        (let ((num (sc-number from-sc)))
  289.          (setf (svref (sc-move-functions to-sc) num) ',name)
  290.          (setf (svref (sc-load-costs to-sc) num) ',cost)))))
  291.  
  292.      (defun ,name ,lambda-list
  293.        (assemble (*code-segment* ,(first lambda-list))
  294.      ,@body))))
  295.  
  296.  
  297. (defconstant sc-vop-slots '((:move . sc-move-vops)
  298.                 (:move-argument . sc-move-arg-vops)))
  299.  
  300.  
  301. ;;; COMPUTE-MOVE-COSTS  --  Internal
  302. ;;;
  303. ;;;    Compute at meta-compile time the costs for moving between all SCs that
  304. ;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
  305. ;;;
  306. (defun compute-move-costs (from-sc to-sc cost)
  307.   (declare (type sc from-sc to-sc) (type index cost))
  308.   (let ((to-scn (sc-number to-sc))
  309.     (from-costs (sc-load-costs from-sc)))
  310.     (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
  311.       (let ((vec (sc-move-costs dest-sc))
  312.         (dest-costs (sc-load-costs dest-sc)))
  313.     (setf (svref vec (sc-number from-sc)) cost)
  314.     (dolist (sc (append (sc-alternate-scs from-sc)
  315.                 (sc-constant-scs from-sc)))
  316.       (let* ((scn (sc-number sc))
  317.          (total (+ (svref from-costs scn)
  318.                (svref dest-costs to-scn)
  319.                cost))
  320.          (old (svref vec scn)))
  321.         (unless (and old (< old total))
  322.           (setf (svref vec scn) total))))))))
  323.     
  324.     
  325. ;;; DEFINE-MOVE-VOP  --  Public
  326. ;;;
  327. ;;;    We record the VOP and costs for all SCs that we can move between
  328. ;;; (including implicit loading).
  329. ;;;
  330. (defmacro define-move-vop (name kind &rest scs)
  331.   "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*
  332.   Make Name be the VOP used to move values in the specified From-SCs to the
  333.   representation of the To-SCs.  If kind is :Move-Argument, then the VOP takes
  334.   an extra argument, which is the frame pointer of the frame to move into." 
  335.   (when (or (oddp (length scs)) (null scs))
  336.     (error "Malformed SCs spec: ~S." scs))
  337.   (let ((accessor (or (cdr (assoc kind sc-vop-slots))
  338.               (error "Unknown kind ~S." kind))))
  339.     `(progn
  340.        ,@(when (eq kind :move)
  341.        `((eval-when (compile load eval)
  342.            (do-sc-pairs (from-sc to-sc ',scs)
  343.          (compute-move-costs from-sc to-sc
  344.                      ,(vop-parse-cost
  345.                        (vop-parse-or-lose name)))))))
  346.        
  347.        (let ((vop (template-or-lose ',name)))
  348.      (do-sc-pairs (from-sc to-sc ',scs)
  349.        (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
  350.          (let ((vec (,accessor dest-sc)))
  351.            (let ((scn (sc-number from-sc)))
  352.          (setf (svref vec scn)
  353.                (adjoin-template vop (svref vec scn))))
  354.            (dolist (sc (append (sc-alternate-scs from-sc)
  355.                    (sc-constant-scs from-sc)))
  356.          (let ((scn (sc-number sc)))
  357.            (setf (svref vec scn)
  358.              (adjoin-template vop (svref vec scn))))))))))))
  359.  
  360.  
  361. ;;;; Primitive type definition:
  362.  
  363. ;;; PRIMITIVE-TYPE-OR-LOSE, META-PRIMITIVE-TYPE-OR-LOSE  --  Interface
  364. ;;;
  365. ;;;    Return the primitive type corresponding to the specified name, or die
  366. ;;; trying.
  367. ;;;
  368. (defun primitive-type-or-lose (name &optional (backend *target-backend*))
  369.   (the primitive-type
  370.        (or (gethash name (backend-primitive-type-names backend))
  371.        (error "~S is not a defined primitive type." name))))
  372. ;;;
  373. (eval-when (compile eval load)
  374.  
  375. (defun meta-primitive-type-or-lose (name)
  376.   (the primitive-type
  377.        (or (gethash name (backend-meta-primitive-type-names *target-backend*))
  378.        (error "~S is not a defined primitive type." name))))
  379.  
  380. ); eval-when
  381.  
  382. ;;; Def-Primitive-Type  --  Public
  383. ;;;
  384. ;;;    If the primitive-type structure already exists, we destructively modify
  385. ;;; it so that existing references in templates won't be invalidated.
  386. ;;; Primitive-type definition isn't done at meta-compile time, so this doesn't
  387. ;;; break the running compiler.
  388. ;;;
  389. (defmacro def-primitive-type (name scs &key (type name))
  390.   "Def-Primitive-Type Name (SC*) {Key Value}*
  391.    Define a primitive type Name.  Each SC specifies a Storage Class that values
  392.    of this type may be allocated in.  The following keyword options are
  393.    defined:
  394.   
  395.   :Type
  396.       The type descriptor for the Lisp type that is equivalent to this type
  397.       (defaults to Name.)"
  398.   (check-type name symbol)
  399.   (check-type scs list)
  400.   (let ((scns (mapcar #'meta-sc-number-or-lose scs))
  401.     (get-type `(specifier-type ',type)))
  402.     `(progn
  403.        (eval-when (compile load eval)
  404.      (setf (gethash ',name (backend-meta-primitive-type-names
  405.                 *target-backend*))
  406.            (make-primitive-type :name ',name  :scs ',scns
  407.                     :type ,get-type)))
  408.        ,(once-only ((n-old `(gethash ',name
  409.                      (backend-primitive-type-names
  410.                       *target-backend*)))
  411.             (n-type get-type))
  412.       `(progn
  413.          (cond (,n-old
  414.             (setf (primitive-type-scs ,n-old) ',scns)
  415.             (setf (primitive-type-type ,n-old) ,n-type))
  416.            (t
  417.             (setf (gethash ',name
  418.                    (backend-primitive-type-names
  419.                     *target-backend*))
  420.               (make-primitive-type :name ',name  :scs ',scns
  421.                            :type ,n-type))))
  422.          ',name)))))
  423.  
  424.  
  425. ;;; Def-Primitive-Type-Alias  --  Public
  426. ;;;
  427. ;;; Just record the translation.
  428. ;;; 
  429. (defmacro def-primitive-type-alias (name result)
  430.   "DEF-PRIMITIVE-TYPE-ALIAS Name Result
  431.   Define name to be an alias for Result in VOP operand type restrictions."
  432.   `(eval-when (compile load eval)
  433.      (setf (gethash ',name (backend-primitive-type-aliases *target-backend*))
  434.        ',result)
  435.      ',name))
  436.  
  437.  
  438. (eval-when (compile load eval)
  439.   (defparameter primitive-type-slot-alist
  440.     '((:check . primitive-type-check))))
  441.  
  442.  
  443. ;;; Primitive-Type-Vop  --  Public
  444. ;;;
  445. (defmacro primitive-type-vop (vop kinds &rest types)
  446.   "Primitive-Type-VOP Vop (Kind*) Type*
  447.   Annotate all the specified primitive Types with the named VOP under each of
  448.   the specified kinds:
  449.  
  450.   :Check
  451.       A one argument one result VOP that moves the argument to the result,
  452.       checking that the value is of this type in the process."
  453.   (let ((n-vop (gensym))
  454.     (n-type (gensym)))
  455.     `(let ((,n-vop (template-or-lose ',vop)))
  456.        ,@(mapcar
  457.       #'(lambda (type)
  458.           `(let ((,n-type (primitive-type-or-lose ',type)))
  459.          ,@(mapcar
  460.             #'(lambda (kind)
  461.             (let ((slot (or (cdr (assoc kind
  462.                             primitive-type-slot-alist))
  463.                     (error "Unknown kind: ~S." kind))))
  464.               `(setf (,slot ,n-type) ,n-vop)))
  465.             kinds)))
  466.       types)
  467.        nil)))
  468.  
  469.  
  470. ;;; SC-ALLOWED-BY-PRIMITIVE-TYPE  --  Interface
  471. ;;;
  472. ;;;    Return true if SC is either one of Ptype's SC's, or one of those SC's
  473. ;;; alternate or constant SCs.  The META- version uses meta-compile time info.
  474. ;;;
  475. (macrolet
  476.     ((frob (name sc-numbers-fun compile-time-also)
  477.        `(eval-when (load eval ,@(when compile-time-also '(compile)))
  478.       (defun ,name (sc ptype)
  479.         (declare (type sc sc) (type primitive-type ptype))
  480.         (let ((scn (sc-number sc)))
  481.           (dolist (allowed (primitive-type-scs ptype) nil)
  482.         (when (eql allowed scn)
  483.           (return t))
  484.         (let ((allowed-sc (svref ,sc-numbers-fun allowed)))
  485.           (when (or (member sc (sc-alternate-scs allowed-sc))
  486.                 (member sc (sc-constant-scs allowed-sc)))
  487.             (return t)))))))))
  488.   (frob sc-allowed-by-primitive-type (backend-sc-numbers *backend*) nil)
  489.   (frob meta-sc-allowed-by-primitive-type
  490.     (backend-meta-sc-numbers *target-backend*) t))
  491.  
  492.  
  493. ;;;; VOP definition structures:
  494. ;;;
  495. ;;;    Define-VOP uses some fairly complex data structures at meta-compile
  496. ;;; time, both to hold the results of parsing the elaborate syntax and to
  497. ;;; retain the information so that it can be inherited by other VOPs.
  498.  
  499. (eval-when (compile load eval)
  500.  
  501. ;;; The VOP-Parse structure holds everything we need to know about a VOP at
  502. ;;; meta-compile time.
  503. ;;;
  504. (defstruct (vop-parse
  505.         (:print-function %print-vop-parse)
  506.         (:make-load-form-fun :just-dump-it-normally))
  507.   ;;
  508.   ;; The name of this VOP.
  509.   (name nil :type symbol)
  510.   ;;
  511.   ;; If true, then the name of the VOP we inherit from.
  512.   (inherits nil :type (or symbol null))
  513.   ;;
  514.   ;; Lists of Operand-Parse structures describing the arguments, results and
  515.   ;; temporaries of the VOP.
  516.   (args nil :type list)
  517.   (results nil :type list)
  518.   (temps nil :type list)
  519.   ;;
  520.   ;; Operand-Parse structures containing information about more args and
  521.   ;; results.  If null, then there there are no more operands of that kind.
  522.   (more-args nil :type (or operand-parse null))
  523.   (more-results nil :type (or operand-parse null))
  524.   ;;
  525.   ;; A list of all the above together.
  526.   (operands nil :type list)
  527.   ;;
  528.   ;; Names of variables that should be declared ignore.
  529.   (ignores () :type list)
  530.   ;;
  531.   ;; True if this is a :Conditional VOP.
  532.   (conditional-p nil)
  533.   ;;
  534.   ;; Argument and result primitive types.  These are pulled out of the
  535.   ;; operands, since we often want to change them without respecifying the
  536.   ;; operands.
  537.   (arg-types :unspecified :type (or (member :unspecified) list))
  538.   (result-types :unspecified :type (or (member :unspecified) list))
  539.   ;;
  540.   ;; The guard expression specified, or NIL if none.
  541.   (guard nil)
  542.   ;;
  543.   ;; The cost of and body code for the generator.
  544.   (cost 0 :type unsigned-byte)
  545.   (body :unspecified :type (or (member :unspecified) list))
  546.   ;;
  547.   ;; Info for VOP variants.  The list of forms to be evaluated to get the
  548.   ;; variant args for this VOP, and the list of variables to be bound to the
  549.   ;; variant args.
  550.   (variant () :type list)
  551.   (variant-vars () :type list)
  552.   ;;
  553.   ;; Variables bound to the VOP and Vop-Node when in the generator body.
  554.   (vop-var (gensym) :type symbol)
  555.   (node-var nil :type (or symbol null))
  556.   ;;
  557.   ;; A list of the names of the codegen-info arguments to this VOP.
  558.   (info-args () :type list)
  559.   ;;
  560.   ;; An efficiency note associated with this VOP.
  561.   (note nil :type (or string null))
  562.   ;;
  563.   ;; A list of the names of the Effects and Affected attributes for this VOP.
  564.   (effects '(any) :type list)
  565.   (affected '(any) :type list)
  566.   ;;
  567.   ;; A list of the names of functions this VOP is a translation of and the
  568.   ;; policy that allows this translation to be done.  :Fast is a safe default,
  569.   ;; since it isn't a safe policy.
  570.   (translate () :type list)
  571.   (policy :fast :type policies)
  572.   ;;
  573.   ;; Stuff used by life analysis.
  574.   (save-p nil :type (member t nil :compute-only :force-to-stack))
  575.   ;;
  576.   ;; Info about how to emit move-argument VOPs for the more operand in
  577.   ;; call/return VOPs.
  578.   (move-args nil :type (member nil :local-call :full-call :known-return)))
  579.  
  580.  
  581. (defprinter vop-parse
  582.   name
  583.   (inherits :test inherits)
  584.   args
  585.   results
  586.   temps
  587.   (more-args :test more-args)
  588.   (more-results :test more-results)
  589.   (conditional-p :test conditional-p)
  590.   ignores
  591.   arg-types
  592.   result-types
  593.   cost
  594.   body
  595.   (variant :test variant)
  596.   (variant-vars :test variant-vars)
  597.   (info-args :test info-args)
  598.   (note :test note)
  599.   effects
  600.   affected
  601.   translate
  602.   policy
  603.   (save-p :test save-p)
  604.   (move-args :test move-args))
  605.  
  606. ;;; The Operand-Parse structure contains stuff we need to know about and
  607. ;;; operand or temporary at meta-compile time.  Besides the obvious stuff, we
  608. ;;; also store the names of per-operand temporaries here.
  609. ;;;
  610. (defstruct (operand-parse
  611.         (:print-function %print-operand-parse)
  612.         (:make-load-form-fun :just-dump-it-normally))
  613.   ;;
  614.   ;; Name of the operand (which we bind to the TN).
  615.   (name nil :type symbol)
  616.   ;;
  617.   ;; The way this operand is used:
  618.   (kind (required-argument)
  619.     :type (member :argument :result :temporary
  620.               :more-argument :more-result))
  621.   ;;
  622.   ;; If true, the name of an operand that this operand is targeted to.  This is
  623.   ;; only meaningful in :Argument and :Temporary operands.
  624.   (target nil :type (or symbol null))
  625.   ;;
  626.   ;; Temporary that holds the TN-Ref for this operand.  Temp-Temp holds the
  627.   ;; write reference that begins a temporary's lifetime.
  628.   (temp (gensym) :type symbol)
  629.   (temp-temp nil :type (or symbol null))
  630.   ;;
  631.   ;; The time that this operand is first live and the time at which it becomes
  632.   ;; dead again.  These are time-specs, as returned by parse-time-spec. 
  633.   born
  634.   dies
  635.   ;;
  636.   ;; A list of the names of the SCs that this operand is allowed into.  If
  637.   ;; false, there is no restriction.
  638.   (scs nil :type list)
  639.   ;;
  640.   ;; Variable that is bound to the load TN allocated for this operand, or to
  641.   ;; NIL if no load-TN was allocated.
  642.   (load-tn (gensym) :type symbol)
  643.   ;;
  644.   ;; An expression that tests whether to do automatic operand loading.
  645.   (load t)
  646.   ;;
  647.   ;; In a wired or restricted temporary this is the SC the TN is to be packed
  648.   ;; in.  Null otherwise.
  649.   (sc nil :type (or symbol null))
  650.   ;;
  651.   ;; If non-null, we are a temp wired to this offset in SC.
  652.   (offset nil :type (or unsigned-byte null)))
  653.  
  654.  
  655. (defprinter operand-parse
  656.   name
  657.   kind
  658.   (target :test target)
  659.   born
  660.   dies
  661.   (scs :test scs)
  662.   (load :test load)
  663.   (sc :test sc)
  664.   (offset :test offset))
  665.  
  666. ); Eval-When (Compile Load Eval)
  667.  
  668.  
  669. ;;;; Random utilities:
  670.  
  671. (eval-when (compile load eval)
  672.  
  673. ;;; Find-Operand  --  Internal
  674. ;;;
  675. ;;;    Find the operand or temporary with the specifed Name in the VOP Parse.
  676. ;;; If there is no such operand, signal an error.  Also error if the operand
  677. ;;; kind isn't one of the specified Kinds.  If Error-P is NIL, just return NIL
  678. ;;; if there is no such operand.
  679. ;;;
  680. (defun find-operand (name parse &optional
  681.               (kinds '(:argument :result :temporary))
  682.               (error-p t))
  683.   (declare (symbol name) (type vop-parse parse) (list kinds))
  684.   (let ((found (find name (vop-parse-operands parse)
  685.              :key #'operand-parse-name)))
  686.     (if found
  687.     (unless (member (operand-parse-kind found) kinds)
  688.       (error "Operand ~S isn't one of these kinds: ~S." name kinds))
  689.     (when error-p
  690.       (error "~S is not an operand to ~S." name (vop-parse-name parse))))
  691.     found))
  692.  
  693.  
  694. ;;; VOP-Parse-Or-Lose  --  Internal
  695. ;;;
  696. ;;;    Get the VOP-Parse structure for Name or die trying.  For all
  697. ;;; meta-compile time uses, the VOP-Parse should be used instead of the
  698. ;;; VOP-Info
  699. ;;;
  700. (defun vop-parse-or-lose (name &optional (backend *target-backend*))
  701.   (the vop-parse
  702.        (or (gethash name (backend-parsed-vops backend))
  703.        (error "~S is not the name of a defined VOP." name))))
  704.  
  705.  
  706. ;;; Access-Operands  --  Internal
  707. ;;;
  708. ;;;    Return a list of let-forms to parse a tn-ref list into a the temps
  709. ;;; specified by the operand-parse structures.  More-Operand is the
  710. ;;; Operand-Parse describing any more operand, or NIL if none.  Refs is an
  711. ;;; expression that evaluates into the first tn-ref.
  712. ;;;
  713. (defun access-operands (operands more-operand refs)
  714.   (declare (list operands))
  715.   (collect ((res))
  716.     (let ((prev refs))
  717.       (dolist (op operands)
  718.     (let ((n-ref (operand-parse-temp op)))
  719.       (res `(,n-ref ,prev))
  720.       (setq prev `(tn-ref-across ,n-ref))))
  721.  
  722.       (when more-operand
  723.     (res `(,(operand-parse-name more-operand) ,prev))))
  724.     (res)))
  725.  
  726.  
  727. ;;; Ignore-Unreferenced-Temps --  Internal
  728. ;;;
  729. ;;;    Used with Access-Operands to prevent warnings for TN-Ref temps not used
  730. ;;; by some particular function.  It returns the name of the last operand, or
  731. ;;; NIL if Operands is NIL.
  732. ;;;
  733. (defun ignore-unreferenced-temps (operands)
  734.   (when operands
  735.     (operand-parse-temp (car (last operands)))))
  736.  
  737.  
  738. ;;; VOP-Spec-Arg  --  Internal
  739. ;;;
  740. ;;;    Grab an arg out of a VOP spec, checking the type and syntax and stuff.
  741. ;;;
  742. (defun vop-spec-arg (spec type &optional (n 1) (last t))
  743.   (let ((len (length spec)))
  744.     (when (<= len n)
  745.       (error "~:R argument missing: ~S." n spec))
  746.     (when (and last (> len (1+ n)))
  747.       (error "Extra junk at end of ~S." spec))
  748.     (let ((thing (elt spec n)))
  749.       (unless (typep thing type)
  750.     (error "~:R argument is not a ~S: ~S." n type spec))
  751.       thing)))
  752.  
  753.  
  754. ;;;; Time specs:
  755.  
  756. ;;; Parse-Time-Spec  --  Internal
  757. ;;;
  758. ;;;    Return a time spec describing a time during the evaluation of a VOP,
  759. ;;; used to delimit operand and temporary lifetimes.  The representation is a
  760. ;;; cons whose CAR is the number of the evaluation phase and the CDR is the
  761. ;;; sub-phase.  The sub-phase is 0 in the :Load and :Save phases. 
  762. ;;;
  763. (defun parse-time-spec (spec)
  764.   (let ((dspec (if (atom spec) (list spec 0) spec)))
  765.     (unless (and (= (length dspec) 2)
  766.          (typep (second dspec) 'unsigned-byte))
  767.       (error "Malformed time specifier: ~S." spec))
  768.  
  769.     (cons (case (first dspec)
  770.         (:load 0)
  771.         (:argument 1)
  772.         (:eval 2)
  773.         (:result 3)
  774.         (:save 4)
  775.         (t
  776.          (error "Unknown phase in time specifier: ~S." spec)))
  777.       (second dspec))))
  778.  
  779.  
  780. ;;; Time-Spec-Order  --  Internal
  781. ;;;
  782. ;;;    Return true if the time spec X is the same or later time than Y.
  783. ;;;
  784. (defun time-spec-order (x y)
  785.   (or (> (car x) (car y))
  786.       (and (= (car x) (car y))
  787.        (>= (cdr x) (cdr y)))))
  788.  
  789.  
  790. ;;;; Emit function generation:
  791.  
  792. ;;; Compute-Reference-Order  --  Internal
  793. ;;;
  794. ;;;    Return a list of 2-lists (<Temporary> <More-P>) in reverse reference
  795. ;;; order describing how to build the next-ref linkage for Parse.  If More-P is
  796. ;;; false, then the Temporary points to a single TN-Ref that should be linked
  797. ;;; in.  If More-P is true, then Temporary points to a chain of Tn-Refs linked
  798. ;;; together by Tn-Ref-Across that should be linked in reverse order.
  799. ;;;
  800. ;;;    In implementation, we build a temporary list containing the result
  801. ;;; tuples augmented with reference time and whether the reference is a write.
  802. ;;; We sort this list using Time-Spec-Order augmented by the subsidiary rule
  803. ;;; that when the specs are equal, we do read references first.  This
  804. ;;; implements the desired semantics of open intervals for temporary lifetimes.
  805. ;;;
  806. (defun compute-reference-order (parse)
  807.   (declare (type vop-parse parse))
  808.   (collect ((refs))
  809.     (dolist (op (vop-parse-operands parse))
  810.       (let ((born (operand-parse-born op))
  811.         (dies (operand-parse-dies op))
  812.         (name (operand-parse-name op))
  813.         (temp (operand-parse-temp op))
  814.         (temp-temp (operand-parse-temp-temp op)))
  815.     (ecase (operand-parse-kind op)
  816.       (:argument
  817.        (refs (list (cons dies nil) temp nil)))
  818.       (:more-argument
  819.        (refs (list (cons dies nil) name t)))
  820.       (:result
  821.        (refs (list (cons born t) temp nil)))
  822.       (:more-result
  823.        (refs (list (cons born t) name t)))
  824.       (:temporary
  825.        (refs (list (cons born t) temp nil))
  826.        (refs (list (cons dies nil) temp-temp nil))))))
  827.  
  828.     (mapcar #'cdr
  829.         (sort (refs)
  830.           #'(lambda (x y)
  831.               (let ((x-time (car x))
  832.                 (y-time (car y)))
  833.               (if (time-spec-order x-time y-time)
  834.               (if (time-spec-order y-time x-time)
  835.                   (or (cdr x) (not (cdr y)))
  836.                   t)
  837.               nil)))
  838.           :key #'first))))
  839.  
  840.  
  841. ;;; Make-Next-Ref-Linkage  --  Internal
  842. ;;;
  843. ;;;    Use the operand lifetime annotations to set up the next-ref slots in all
  844. ;;; the TN-Refs used in the VOP.  We set the Refs in the VOP to point to the
  845. ;;; head of this list.  More operands make life a bit interesting, since they
  846. ;;; introduce uncertainty as to whether we have seen any operands yet, and also
  847. ;;; must be linked together contiguously with the other TN-Refs.
  848. ;;;
  849. (defun make-next-ref-linkage (parse n-vop)
  850.   (declare (type vop-parse parse))
  851.   (collect ((forms)
  852.         (binds))
  853.     (let ((first-seen :no)
  854.       (prev nil))
  855.       (dolist (x (compute-reference-order parse))
  856.     (let* ((var (first x))
  857.            (more-p (second x))
  858.            (n-tail (if more-p (gensym) var)))
  859.       (ecase first-seen
  860.         (:no
  861.          (forms `(setf (vop-refs ,n-vop) ,n-tail)))
  862.         (:yes
  863.          (forms `(setf (tn-ref-next-ref ,prev) ,n-tail)))
  864.         (:maybe
  865.          (forms `(if ,prev
  866.              (setf (tn-ref-next-ref ,prev) ,n-tail)
  867.              (setf (vop-refs ,n-vop) ,n-tail)))))
  868.       
  869.       (unless (eq first-seen :yes)
  870.         (setq first-seen (if more-p :maybe :yes)))
  871.       
  872.       (if more-p
  873.           (let ((n-current (gensym))
  874.             (n-prev (gensym))
  875.             (n-head (gensym)))
  876.         (binds `(,n-head (or ,var ,prev)))
  877.         (binds
  878.          `(,n-tail
  879.            (do ((,n-current ,var (tn-ref-across ,n-current))
  880.             (,n-prev nil ,n-current))
  881.                ((null ,n-current) ,n-prev)
  882.              (setf (tn-ref-next-ref ,n-current) ,n-prev))))
  883.         (setq prev n-head))
  884.           (setq prev var)))))
  885.     
  886.     `((let* ,(binds)
  887.     ,@(forms)))))
  888.  
  889.  
  890. ;;; Make-Temporary  --  Internal
  891. ;;;
  892. ;;;    Return a form that creates a TN as specified by Temp.  This requires
  893. ;;; deciding whether the temp is wired or restricted.
  894. ;;;
  895. (defun make-temporary (temp)
  896.   (declare (type operand-parse temp))
  897.   (let ((sc (operand-parse-sc temp))
  898.     (offset (operand-parse-offset temp)))
  899.     (assert sc)
  900.     (if offset
  901.     `(make-wired-tn nil ,(meta-sc-number-or-lose sc) ,offset)
  902.     `(make-restricted-tn nil ,(meta-sc-number-or-lose sc)))))
  903.  
  904.   
  905. ;;; Allocate-Temporaries  --  Internal
  906. ;;;
  907. ;;;    Allocate VOP temporary TNs, making TN-Refs for their start and end, and
  908. ;;; setting up various per-ref information.  N-Vop is the temporary holding the
  909. ;;; VOP we are emitting.  We return a list of let* binding forms that create
  910. ;;; the TN-Refs, a list of forms that initialize the TN-Refs.
  911. ;;;
  912. (defun allocate-temporaries (parse n-vop)
  913.   (declare (type vop-parse parse))
  914.   (collect ((binds)
  915.         (forms))
  916.     (let ((prev-write nil))
  917.       (dolist (temp (vop-parse-temps parse))
  918.     (let ((n-write (operand-parse-temp temp))
  919.           (n-read (operand-parse-temp-temp temp))
  920.           (n-tn (gensym)))
  921.       (binds `(,n-tn ,(make-temporary temp)))
  922.       (binds `(,n-write (reference-tn ,n-tn t)))
  923.       (binds `(,n-read (reference-tn ,n-tn nil)))
  924.       (if prev-write
  925.           (forms `(setf (tn-ref-across ,prev-write) ,n-write))
  926.           (forms `(setf (vop-temps ,n-vop) ,n-write)))
  927.       (setq prev-write n-write)
  928.       (forms `(setf (tn-ref-vop ,n-read) ,n-vop))
  929.       (forms `(setf (tn-ref-vop ,n-write) ,n-vop)))))
  930.  
  931.     (values (binds) (forms))))
  932.  
  933.  
  934. ;;; Set-VOP-Pointers  --  Internal
  935. ;;;
  936. ;;;    Return code to set the TN-Ref-Vop slots in some operands to the value of
  937. ;;; N-Vop.  If there is no more operand, set the set the slots individually,
  938. ;;; otherwise loop over the whole list N-Refs.
  939. ;;;
  940. (defun set-vop-pointers (operands more-operand n-vop n-refs)
  941.   (if more-operand
  942.       `((do ((,n-refs ,n-refs (tn-ref-across ,n-refs)))
  943.         ((null ,n-refs))
  944.       (setf (tn-ref-vop ,n-refs) ,n-vop)))
  945.       (mapcar #'(lambda (op)
  946.           `(setf (tn-ref-vop ,(operand-parse-temp op)) ,n-vop))
  947.           operands)))
  948.  
  949.  
  950. ;;; Make-Emit-Function  --  Internal
  951. ;;;
  952. ;;;    Make the Template Emit-Function for a VOP.
  953. ;;;
  954. (defun make-emit-function (parse)
  955.   (declare (type vop-parse parse))
  956.   (let ((n-node (gensym)) (n-block (gensym))
  957.     (n-template (gensym)) (n-args (gensym))
  958.     (n-results (gensym)) (n-info (gensym))
  959.     (n-vop (gensym))
  960.     (info-args (vop-parse-info-args parse)))
  961.     (multiple-value-bind (temp-binds temp-forms)
  962.              (allocate-temporaries parse n-vop)
  963.       `#'(lambda (,n-node ,n-block ,n-template ,n-args ,n-results
  964.               ,@(when info-args `(,n-info)))
  965.        (let ((,n-vop (make-vop ,n-block ,n-node ,n-template
  966.                    ,n-args ,n-results)))
  967.  
  968.          ,@(when info-args
  969.          `((setf (vop-codegen-info ,n-vop) ,n-info)))
  970.          
  971.          (let* (,@(access-operands (vop-parse-args parse)
  972.                        (vop-parse-more-args parse)
  973.                        n-args)
  974.             ,@(access-operands (vop-parse-results parse)
  975.                        (vop-parse-more-results parse)
  976.                        n-results)
  977.             ,@temp-binds)
  978.            ,@temp-forms
  979.            ,@(set-vop-pointers (vop-parse-args parse)
  980.                    (vop-parse-more-args parse)
  981.                    n-vop n-args)
  982.            ,@(set-vop-pointers (vop-parse-results parse)
  983.                    (vop-parse-more-results parse)
  984.                    n-vop n-results)
  985.            ,@(make-next-ref-linkage parse n-vop))
  986.          (values ,n-vop ,n-vop))))))
  987.  
  988.  
  989. ;;; Make-Target-Function  --  Internal
  990. ;;;
  991. ;;;    Make lambda that does operand targeting as indicated by the
  992. ;;; Operand-Parse-Target slots.  We do some meta-compile-time consistency
  993. ;;; checking, and the emit a call to Target-If-Desirable for each operand
  994. ;;; with a target specified.
  995. ;;;
  996. ;;;    If we are targeting from a temporary, then we indirect through the TN to
  997. ;;; find the read ref.  This exploits the fact that a temp has exactly one
  998. ;;; read.
  999. ;;;
  1000. (defun make-target-function (parse)
  1001.   (collect ((forms))
  1002.     (dolist (op (vop-parse-operands parse))
  1003.       (when (operand-parse-target op)
  1004.     (unless (member (operand-parse-kind op) '(:argument :temporary))
  1005.       (error "Cannot target a ~S operand: ~S." (operand-parse-kind op)
  1006.          (operand-parse-name op)))
  1007.     (let ((target (find-operand (operand-parse-target op) parse
  1008.                     '(:temporary :result))))
  1009.       (forms `(target-if-desirable
  1010.            ,(ecase (operand-parse-kind op)
  1011.               (:temporary
  1012.                `(tn-reads (tn-ref-tn ,(operand-parse-temp op))))
  1013.               (:argument
  1014.                (operand-parse-temp op)))
  1015.            ,(operand-parse-temp target))))))
  1016.  
  1017.     (let ((n-vop (gensym)))
  1018.       `#'(lambda (,n-vop)
  1019.        (let* (,@(access-operands (vop-parse-args parse) nil
  1020.                      `(vop-args ,n-vop))
  1021.           ,@(access-operands (vop-parse-results parse) nil
  1022.                      `(vop-results ,n-vop))
  1023.           ,@(access-operands (vop-parse-temps parse) nil
  1024.                      `(vop-temps ,n-vop)))
  1025.          ,(ignore-unreferenced-temps (vop-parse-args parse))
  1026.          ,(ignore-unreferenced-temps (vop-parse-results parse))
  1027.          ,(ignore-unreferenced-temps (vop-parse-temps parse))
  1028.          ,@(forms))))))
  1029.  
  1030.  
  1031. ;;;; Generator functions:
  1032.  
  1033. ;;; FIND-MOVE-FUNCTIONS  --  Internal
  1034. ;;;
  1035. ;;;    Return an alist that translates from lists of SCs we can load OP from to
  1036. ;;; the move function used for loading those SCs.  We quietly ignore
  1037. ;;; restrictions to :non-packed (constant) and :unbounded SCs, since we don't
  1038. ;;; load into those SCs.
  1039. ;;;
  1040. (eval-when (compile load eval)
  1041.  
  1042. (defun find-move-functions (op load-p)
  1043.   (collect ((funs))
  1044.     (dolist (sc-name (operand-parse-scs op))
  1045.       (let* ((sc (meta-sc-or-lose sc-name))
  1046.          (scn (sc-number sc))
  1047.          (load-scs (append (when load-p
  1048.                  (sc-constant-scs sc))
  1049.                    (sc-alternate-scs sc))))
  1050.     (cond
  1051.      (load-scs
  1052.       (dolist (alt load-scs)
  1053.         (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
  1054.           (let* ((altn (sc-number alt))
  1055.              (name (if load-p
  1056.                    (svref (sc-move-functions sc) altn)
  1057.                    (svref (sc-move-functions alt) scn)))
  1058.              (found (or (assoc alt (funs) :test #'member)
  1059.                 (rassoc name (funs)))))
  1060.         (unless name
  1061.           (error "No move function defined to ~:[save~;load~] SC ~S~
  1062.               ~:[to~;from~] from SC ~S."
  1063.              load-p sc-name load-p (sc-name alt)))
  1064.         
  1065.         (cond (found
  1066.                (unless (eq (cdr found) name)
  1067.              (error "Can't tell whether to ~:[save~;load~] with ~S~@
  1068.                  or ~S when operand is in SC ~S."
  1069.                 load-p name (cdr found) (sc-name alt)))
  1070.                (pushnew alt (car found)))
  1071.               (t
  1072.                (funs (cons (list alt) name))))))))
  1073.      ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
  1074.      (t
  1075.       (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
  1076.               mentioned in the restriction for operand ~S."
  1077.          sc-name load-p (operand-parse-name op))))))
  1078.     (funs)))
  1079.  
  1080. ); eval-when
  1081.  
  1082. ;;; CALL-MOVE-FUNCTION  --  Internal
  1083. ;;;
  1084. ;;;    Return a form to load/save the specified operand when it has a load TN.
  1085. ;;; For any given SC that we can load from, there must be a unique load
  1086. ;;; function.  If all SCs we can load from have the same move function, then we
  1087. ;;; just call that when there is a load TN.  If there are multiple possible
  1088. ;;; move functions, then we dispatch off of the operand TN's type to see which
  1089. ;;; move function to use.
  1090. ;;;
  1091. (defun call-move-function (parse op load-p)
  1092.   (let ((funs (find-move-functions op load-p))
  1093.     (load-tn (operand-parse-load-tn op)))
  1094.     (if funs
  1095.     (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
  1096.            (n-vop (or (vop-parse-vop-var parse)
  1097.               (setf (vop-parse-vop-var parse) (gensym))))
  1098.            (form (if (rest funs)
  1099.              `(sc-case ,tn
  1100.                 ,@(mapcar #'(lambda (x)
  1101.                       `(,(mapcar #'sc-name (car x))
  1102.                         ,(if load-p
  1103.                          `(,(cdr x) ,n-vop ,tn
  1104.                            ,load-tn)
  1105.                          `(,(cdr x) ,n-vop ,load-tn
  1106.                            ,tn))))
  1107.                       funs))
  1108.              (if load-p
  1109.                  `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
  1110.                  `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
  1111.       (if (eq (operand-parse-load op) t)
  1112.           `(when ,load-tn ,form)
  1113.           `(when (eq ,load-tn ,(operand-parse-name op))
  1114.          ,form)))
  1115.     `(when ,load-tn
  1116.        (error "Load TN allocated, but no move function?~@
  1117.                VM definition inconsistent, recompile and try again.")))))
  1118.  
  1119.  
  1120. ;;; DECIDE-TO-LOAD  --  Internal
  1121. ;;;
  1122. ;;;    Return the TN that we should bind to the operand's var in the generator
  1123. ;;; body.  In general, this involves evaluating the :LOAD-IF test expression.
  1124. ;;;
  1125. (defun decide-to-load (parse op)
  1126.   (let ((load (operand-parse-load op))
  1127.     (load-tn (operand-parse-load-tn op))
  1128.     (temp (operand-parse-temp op)))
  1129.     (if (eq load t)
  1130.     `(or ,load-tn (tn-ref-tn ,temp))
  1131.     (collect ((binds)
  1132.           (ignores))
  1133.       (dolist (x (vop-parse-operands parse))
  1134.         (when (member (operand-parse-kind x) '(:argument :result))
  1135.           (let ((name (operand-parse-name x)))
  1136.         (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
  1137.         (ignores name))))
  1138.       `(if (and ,load-tn
  1139.             (let ,(binds)
  1140.               #+new-compiler
  1141.               (declare (ignorable ,@(ignores)))
  1142.               #-new-compiler
  1143.               (progn ,@(ignores))
  1144.               ,load))
  1145.            ,load-tn
  1146.            (tn-ref-tn ,temp))))))
  1147.  
  1148.  
  1149. ;;; Make-Generator-Function  --  Internal
  1150. ;;;
  1151. ;;;    Make a lambda that parses the VOP TN-Refs, does automatic operand
  1152. ;;; loading, and runs the appropriate code generator.
  1153. ;;;
  1154. (defun make-generator-function (parse)
  1155.   (declare (type vop-parse parse))
  1156.   (let ((n-vop (vop-parse-vop-var parse))
  1157.     (operands (vop-parse-operands parse))
  1158.     (n-info (gensym)) (n-variant (gensym)))
  1159.     (collect ((binds)
  1160.           (loads)
  1161.           (saves))
  1162.       (dolist (op operands)
  1163.     (ecase (operand-parse-kind op)
  1164.       ((:argument :result)
  1165.        (let ((temp (operand-parse-temp op))
  1166.          (name (operand-parse-name op)))
  1167.          (cond ((and (operand-parse-load op) (operand-parse-scs op))
  1168.             (binds `(,(operand-parse-load-tn op)
  1169.                  (tn-ref-load-tn ,temp)))
  1170.             (binds `(,name ,(decide-to-load parse op)))
  1171.             (if (eq (operand-parse-kind op) :argument)
  1172.             (loads (call-move-function parse op t))
  1173.             (saves (call-move-function parse op nil))))
  1174.            (t
  1175.             (binds `(,name (tn-ref-tn ,temp)))))))
  1176.       (:temporary
  1177.        (binds `(,(operand-parse-name op)
  1178.             (tn-ref-tn ,(operand-parse-temp op)))))
  1179.       ((:more-argument :more-result))))
  1180.  
  1181.       `#'(lambda (,n-vop)
  1182.        (let* (,@(access-operands (vop-parse-args parse)
  1183.                      (vop-parse-more-args parse)
  1184.                      `(vop-args ,n-vop))
  1185.           ,@(access-operands (vop-parse-results parse)
  1186.                      (vop-parse-more-results parse)
  1187.                      `(vop-results ,n-vop))
  1188.           ,@(access-operands (vop-parse-temps parse) nil
  1189.                      `(vop-temps ,n-vop))
  1190.           ,@(when (vop-parse-info-args parse)
  1191.               `((,n-info (vop-codegen-info ,n-vop))
  1192.             ,@(mapcar #'(lambda (x) `(,x (pop ,n-info)))
  1193.                   (vop-parse-info-args parse))))
  1194.           ,@(when (vop-parse-variant-vars parse)
  1195.               `((,n-variant (vop-info-variant (vop-info ,n-vop)))
  1196.             ,@(mapcar #'(lambda (x) `(,x (pop ,n-variant)))
  1197.                   (vop-parse-variant-vars parse))))
  1198.           ,@(when (vop-parse-node-var parse)
  1199.               `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
  1200.           ,@(binds))
  1201.          (declare (ignore ,@(vop-parse-ignores parse)))
  1202.          ,@(loads)
  1203.          (assemble (*code-segment* ,n-vop)
  1204.            ,@(vop-parse-body parse))
  1205.          ,@(saves))))))
  1206.  
  1207.  
  1208. ;;; Parse-Operands  --  Internal
  1209. ;;;
  1210. ;;;    Given a list of operand specifications as given to Define-VOP, return a
  1211. ;;; list of Operand-Parse structures describing the fixed operands, and a
  1212. ;;; single Operand-Parse describing any more operand.  If we are inheriting a
  1213. ;;; VOP, we default attributes to the inherited operand of the same name.
  1214. ;;;
  1215. (defun parse-operands (parse specs kind)
  1216.   (declare (list specs)
  1217.        (type (member :argument :result) kind))
  1218.   (let ((num -1)
  1219.     (more nil))
  1220.     (collect ((operands))
  1221.       (dolist (spec specs)
  1222.     (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
  1223.       (error "Malformed operand specifier: ~S." spec))
  1224.     (when more
  1225.       (error "More operand isn't last: ~S." specs)) 
  1226.     (let* ((name (first spec))
  1227.            (old (if (vop-parse-inherits parse)
  1228.             (find-operand name
  1229.                       (vop-parse-or-lose
  1230.                        (vop-parse-inherits parse))
  1231.                       (list kind)
  1232.                       nil)
  1233.             nil))
  1234.            (res (if old
  1235.             (make-operand-parse
  1236.              :name name
  1237.              :kind kind
  1238.              :target (operand-parse-target old)
  1239.              :born (operand-parse-born old)
  1240.              :dies (operand-parse-dies old)
  1241.              :scs (operand-parse-scs old)
  1242.              :load-tn (operand-parse-load-tn old)
  1243.              :load (operand-parse-load old))
  1244.             (ecase kind
  1245.               (:argument
  1246.                (make-operand-parse
  1247.                 :name (first spec)  :kind :argument
  1248.                 :born (parse-time-spec :load)
  1249.                 :dies (parse-time-spec `(:argument ,(incf num)))))
  1250.               (:result
  1251.                (make-operand-parse
  1252.                 :name (first spec)  :kind :result
  1253.                 :born (parse-time-spec `(:result ,(incf num)))
  1254.                 :dies (parse-time-spec :save)))))))
  1255.       (do ((key (rest spec) (cddr key)))
  1256.           ((null key))
  1257.         (let ((value (second key)))
  1258.           (case (first key)
  1259.         (:scs
  1260.          (check-type value list)
  1261.          (setf (operand-parse-scs res) (remove-duplicates value)))
  1262.         (:load-tn
  1263.          (check-type value symbol)
  1264.          (setf (operand-parse-load-tn res) value))
  1265.         (:load-if
  1266.          (setf (operand-parse-load res) value))
  1267.         (:more
  1268.          (check-type value boolean)
  1269.          (setf (operand-parse-kind res)
  1270.                (if (eq kind :argument) :more-argument :more-result))
  1271.          (setf (operand-parse-load res) nil)
  1272.          (setq more res))
  1273.         (:target
  1274.          (check-type value symbol)
  1275.          (setf (operand-parse-target res) value))
  1276.         (:from
  1277.          (unless (eq kind :result)
  1278.            (error "Can only specify :FROM in a result: ~S" spec))
  1279.          (setf (operand-parse-born res) (parse-time-spec value)))
  1280.         (:to
  1281.          (unless (eq kind :argument)
  1282.            (error "Can only specify :TO in an argument: ~S" spec))
  1283.          (setf (operand-parse-dies res) (parse-time-spec value)))
  1284.         (t
  1285.          (error "Unknown keyword in operand specifier: ~S." spec)))))
  1286.  
  1287.       (cond ((not more)
  1288.          (operands res))
  1289.         ((operand-parse-target more)
  1290.          (error "Cannot specify :TARGET in a :MORE operand."))
  1291.         ((operand-parse-load more)
  1292.          (error "Cannot specify :LOAD-IF in a :MORE operand.")))))
  1293.       (values (the list (operands)) more))))
  1294.  
  1295.  
  1296. ;;; Parse-Temporary  --  Internal
  1297. ;;;
  1298. ;;;    Parse a temporary specification, entering the Operand-Parse structures
  1299. ;;; in the Parse structure.
  1300. ;;;
  1301. (defun parse-temporary (spec parse)
  1302.   (declare (list spec)
  1303.        (type vop-parse parse))
  1304.   (let ((len (length spec)))
  1305.     (unless (>= len 2)
  1306.       (error "Malformed temporary spec: ~S." spec))
  1307.     (unless (listp (second spec))
  1308.       (error "Malformed options list: ~S." (second spec)))
  1309.     (unless (evenp (length (second spec)))
  1310.       (error "Odd number of arguments in keyword options: ~S." spec))
  1311.     (unless (consp (cddr spec))
  1312.       (warn "Temporary spec allocates no temps:~%  ~S" spec))
  1313.     (dolist (name (cddr spec))
  1314.       (unless (symbolp name)
  1315.     (error "Bad temporary name: ~S." name))
  1316.       (let ((res (make-operand-parse :name name  :kind :temporary
  1317.                      :temp-temp (gensym)
  1318.                      :born (parse-time-spec :load)
  1319.                      :dies (parse-time-spec :save))))
  1320.     (do ((opt (second spec) (cddr opt)))
  1321.         ((null opt))
  1322.       (case (first opt)
  1323.         (:target
  1324.          (setf (operand-parse-target res)
  1325.            (vop-spec-arg opt 'symbol 1 nil)))
  1326.         (:sc
  1327.          (setf (operand-parse-sc res)
  1328.            (vop-spec-arg opt 'symbol 1 nil)))
  1329.         (:offset
  1330.          (let ((offset (eval (second opt))))
  1331.            (check-type offset unsigned-byte)
  1332.            (setf (operand-parse-offset res) offset)))
  1333.         (:from
  1334.          (setf (operand-parse-born res) (parse-time-spec (second opt))))
  1335.         (:to
  1336.          (setf (operand-parse-dies res) (parse-time-spec (second opt))))
  1337.         ;;
  1338.         ;; Backward compatibility...
  1339.         (:scs
  1340.          (let ((scs (vop-spec-arg opt 'list 1 nil)))
  1341.            (unless (= (length scs) 1)
  1342.          (error "Must specify exactly one SC for a temporary."))
  1343.            (setf (operand-parse-sc res) (first scs))))
  1344.         (:type)
  1345.         (t
  1346.          (error "Unknown temporary option: ~S." opt))))
  1347.  
  1348.     (unless (and (time-spec-order (operand-parse-dies res)
  1349.                       (operand-parse-born res))
  1350.              (not (time-spec-order (operand-parse-born res)
  1351.                        (operand-parse-dies res))))
  1352.       (error "Temporary lifetime doesn't begin before it ends: ~S." spec))
  1353.  
  1354.     (unless (operand-parse-sc res)
  1355.       (error "Must specifiy :SC for all temporaries: ~S" spec))
  1356.  
  1357.     (setf (vop-parse-temps parse)
  1358.           (cons res
  1359.             (remove name (vop-parse-temps parse)
  1360.                 :key #'operand-parse-name))))))
  1361.   (undefined-value))
  1362.  
  1363.  
  1364. ;;; Parse-Define-VOP  --  Internal
  1365. ;;;
  1366. ;;;    Top-level parse function.  Clobber Parse to represent the specified
  1367. ;;; options.
  1368. ;;;
  1369. (defun parse-define-vop (parse specs)
  1370.   (declare (type vop-parse parse) (list specs))
  1371.   (dolist (spec specs)
  1372.     (unless (consp spec)
  1373.       (error "Malformed option specification: ~S." spec))
  1374.     (case (first spec)
  1375.       (:args
  1376.        (multiple-value-bind
  1377.        (fixed more)
  1378.        (parse-operands parse (rest spec) :argument)
  1379.      (setf (vop-parse-args parse) fixed)
  1380.      (setf (vop-parse-more-args parse) more)))
  1381.       (:results
  1382.        (multiple-value-bind
  1383.        (fixed more)
  1384.        (parse-operands parse (rest spec) :result)
  1385.      (setf (vop-parse-results parse) fixed)
  1386.      (setf (vop-parse-more-results parse) more))
  1387.        (setf (vop-parse-conditional-p parse) nil))
  1388.       (:conditional
  1389.        (setf (vop-parse-result-types parse) ())
  1390.        (setf (vop-parse-results parse) ())
  1391.        (setf (vop-parse-more-results parse) nil)
  1392.        (setf (vop-parse-conditional-p parse) t))
  1393.       (:temporary
  1394.        (parse-temporary spec parse))
  1395.       (:generator
  1396.        (setf (vop-parse-cost parse)
  1397.          (vop-spec-arg spec 'unsigned-byte 1 nil))
  1398.        (setf (vop-parse-body parse) (cddr spec)))
  1399.       (:effects
  1400.        (setf (vop-parse-effects parse) (rest spec)))
  1401.       (:affected
  1402.        (setf (vop-parse-affected parse) (rest spec)))
  1403.       (:info
  1404.        (setf (vop-parse-info-args parse) (rest spec)))
  1405.       (:ignore
  1406.        (setf (vop-parse-ignores parse) (rest spec)))
  1407.       (:variant
  1408.        (setf (vop-parse-variant parse) (rest spec)))
  1409.       (:variant-vars
  1410.        (let ((vars (rest spec)))
  1411.      (setf (vop-parse-variant-vars parse) vars)
  1412.      (setf (vop-parse-variant parse)
  1413.            (make-list (length vars) :initial-element nil))))
  1414.       (:variant-cost
  1415.        (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
  1416.       (:vop-var
  1417.        (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
  1418.       (:move-args
  1419.        (setf (vop-parse-move-args parse)
  1420.          (vop-spec-arg spec '(member nil :local-call :full-call
  1421.                      :known-return))))
  1422.       (:node-var
  1423.        (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
  1424.       (:note
  1425.        (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
  1426.       (:arg-types
  1427.        (setf (vop-parse-arg-types parse)
  1428.          (parse-operand-types (rest spec) t)))
  1429.       (:result-types
  1430.        (setf (vop-parse-result-types parse)
  1431.          (parse-operand-types (rest spec) nil)))
  1432.       (:translate
  1433.        (setf (vop-parse-translate parse) (rest spec)))
  1434.       (:guard
  1435.        (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
  1436.       (:policy
  1437.        (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies)))
  1438.       (:save-p
  1439.        (setf (vop-parse-save-p parse)
  1440.          (vop-spec-arg spec
  1441.                '(member t nil :compute-only :force-to-stack))))
  1442.       (t
  1443.        (error "Unknown option specifier: ~S." (first spec)))))
  1444.   (undefined-value))
  1445.  
  1446.  
  1447. ;;;; Make costs and restrictions:
  1448.  
  1449. ;;; Compute-Loading-Costs  --  Internal
  1450. ;;;
  1451. ;;; Given an operand, returns two values:
  1452. ;;; 1] A SC-vector of the cost for the operand being in that SC, including both
  1453. ;;;    the costs for move functions and coercion VOPs.
  1454. ;;; 2] A SC-vector holding the SC that we load into, for any SC that we can
  1455. ;;;    directly load from.
  1456. ;;;
  1457. ;;; In both vectors, unused entries are NIL.  Load-P specifies the direction:
  1458. ;;; if true, we are loading, if false we are saving.
  1459. ;;;
  1460. (eval-when (compile load eval)
  1461.  
  1462. (defun compute-loading-costs (op load-p)
  1463.   (declare (type operand-parse op))
  1464.   (let ((scs (operand-parse-scs op))
  1465.     (costs (make-array sc-number-limit :initial-element nil))
  1466.     (load-scs (make-array sc-number-limit :initial-element nil)))
  1467.     (dolist (sc-name scs)
  1468.       (let* ((load-sc (meta-sc-or-lose sc-name))
  1469.          (load-scn (sc-number load-sc)))
  1470.     (setf (svref costs load-scn) 0)
  1471.     (setf (svref load-scs load-scn) t)
  1472.     (dolist (op-sc (append (when load-p
  1473.                  (sc-constant-scs load-sc))
  1474.                    (sc-alternate-scs load-sc)))
  1475.       (let* ((op-scn (sc-number op-sc))
  1476.          (load (if load-p
  1477.                (aref (sc-load-costs load-sc) op-scn)
  1478.                (aref (sc-load-costs op-sc) load-scn))))
  1479.         (unless load
  1480.           (error "No move function defined to move ~:[from~;to~] SC ~
  1481.                   ~S~%~:[to~;from~] alternate or constant SC ~S."
  1482.              load-p sc-name load-p (sc-name op-sc)))
  1483.         
  1484.         (let ((op-cost (svref costs op-scn)))
  1485.           (when (or (not op-cost) (< load op-cost))
  1486.         (setf (svref costs op-scn) load)))
  1487.  
  1488.         (let ((op-load (svref load-scs op-scn)))
  1489.           (unless (eq op-load t)
  1490.         (pushnew load-scn (svref load-scs op-scn))))))
  1491.  
  1492.     (dotimes (i sc-number-limit)
  1493.       (unless (svref costs i)
  1494.         (let ((op-sc (svref (backend-meta-sc-numbers *target-backend*) i)))
  1495.           (when op-sc
  1496.         (let ((cost (if load-p
  1497.                 (svref (sc-move-costs load-sc) i)
  1498.                 (svref (sc-move-costs op-sc) load-scn))))
  1499.           (when cost
  1500.             (setf (svref costs i) cost)))))))))
  1501.  
  1502.     (values costs load-scs)))
  1503.  
  1504. ); eval-when
  1505.  
  1506. (defparameter no-costs
  1507.   (make-array sc-number-limit  :initial-element 0))
  1508.  
  1509. (defparameter no-loads
  1510.   (make-array sc-number-limit :initial-element 't))
  1511.  
  1512.  
  1513. ;;; COMPUTE-LOADING-COSTS-IF-ANY  --  Internal
  1514. ;;;
  1515. ;;;    Pick off the case of operands with no restrictions.
  1516. ;;;
  1517. (defun compute-loading-costs-if-any (op load-p)
  1518.   (declare (type operand-parse op))
  1519.   (if (operand-parse-scs op)
  1520.       (compute-loading-costs op load-p)
  1521.       (values no-costs no-loads)))
  1522.       
  1523.  
  1524. ;;; COMPUTE-COSTS-AND-RESTRICTIONS-LIST  --  Internal
  1525. ;;;
  1526. (defun compute-costs-and-restrictions-list (ops load-p)
  1527.   (declare (list ops))
  1528.   (collect ((costs)
  1529.         (scs))
  1530.     (dolist (op ops)
  1531.       (multiple-value-bind (costs scs)
  1532.                (compute-loading-costs-if-any op load-p)
  1533.     (costs costs)
  1534.     (scs scs)))
  1535.     (values (costs) (scs))))
  1536.  
  1537.  
  1538. ;;; Make-Costs-And-Restrictions  --  Internal
  1539. ;;;
  1540. (defun make-costs-and-restrictions (parse)
  1541.   (multiple-value-bind
  1542.       (arg-costs arg-scs)
  1543.       (compute-costs-and-restrictions-list (vop-parse-args parse) t)
  1544.     (multiple-value-bind
  1545.     (result-costs result-scs)
  1546.     (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
  1547.       `(
  1548.     :cost ,(vop-parse-cost parse)
  1549.     
  1550.     :arg-costs ',arg-costs
  1551.     :arg-load-scs ',arg-scs
  1552.     :result-costs ',result-costs
  1553.     :result-load-scs ',result-scs
  1554.     
  1555.     :more-arg-costs
  1556.     ',(if (vop-parse-more-args parse)
  1557.           (compute-loading-costs-if-any (vop-parse-more-args parse) t)
  1558.           nil)
  1559.     
  1560.     :more-result-costs
  1561.     ',(if (vop-parse-more-results parse)
  1562.           (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
  1563.           nil)))))
  1564.  
  1565.  
  1566. ;;;; Operand checking and stuff:
  1567.  
  1568. ;;; PARSE-OPERAND-TYPES  --  Internal
  1569. ;;;
  1570. ;;;    Given a list of arg/result restrictions, check for valid syntax and
  1571. ;;; convert to canonical form.
  1572. ;;;
  1573. (defun parse-operand-types (specs args-p)
  1574.   (declare (list specs))
  1575.   (labels ((parse-operand-type (spec)
  1576.          (cond ((eq spec '*) spec)
  1577.            ((symbolp spec)
  1578.             (let ((alias (gethash spec
  1579.                       (backend-primitive-type-aliases
  1580.                        *target-backend*))))
  1581.               (if alias
  1582.               (parse-operand-type alias)
  1583.               `(:or ,spec))))
  1584.            ((atom spec)
  1585.             (error "Bad thing to be a operand type: ~S." spec))
  1586.            (t
  1587.             (case (first spec)
  1588.               (:or
  1589.                (collect ((results))
  1590.              (results :or)
  1591.              (dolist (item (cdr spec))
  1592.                (unless (symbolp item)
  1593.                  (error "Bad PRIMITIVE-TYPE name in ~S: ~S"
  1594.                     spec item))
  1595.                (let ((alias
  1596.                   (gethash item
  1597.                        (backend-primitive-type-aliases
  1598.                         *target-backend*))))
  1599.                  (if alias
  1600.                  (let ((alias (parse-operand-type alias)))
  1601.                    (unless (eq (car alias) :or)
  1602.                      (error "Can't include primitive-type ~
  1603.                              alias ~S in a :OR restriction: ~S."
  1604.                         item spec))
  1605.                    (dolist (x (cdr alias))
  1606.                      (results x)))
  1607.                  (results item))))
  1608.              (remove-duplicates (results)
  1609.                         :test #'eq
  1610.                         :start 1)))
  1611.               (:constant
  1612.                (unless args-p
  1613.              (error "Can't :CONSTANT for a result."))
  1614.                (unless (= (length spec) 2)
  1615.              (error "Bad :CONSTANT argument type spec: ~S." spec))
  1616.                spec)
  1617.               (t
  1618.                (error "Bad thing to be a operand type: ~S." spec)))))))
  1619.     (mapcar #'parse-operand-type specs)))
  1620.  
  1621.  
  1622. ;;; CHECK-OPERAND-TYPE-SCS  --  Internal
  1623. ;;;
  1624. ;;;    Check the consistency of Op's Sc restrictions with the specified
  1625. ;;; primitive-type restriction.  :CONSTANT operands have already been filtered
  1626. ;;; out, so only :OR and * restrictions are left.
  1627. ;;;
  1628. ;;;    We check that every representation allowed by the type can be directly
  1629. ;;; loaded into some SC in the restriction, and that the type allows every SC
  1630. ;;; in the restriction.  With *, we require that T satisfy the first test, and
  1631. ;;; omit the second.
  1632. ;;;
  1633. (eval-when (compile eval load)
  1634.  
  1635. (defun check-operand-type-scs (parse op type load-p)
  1636.   (declare (type vop-parse parse) (type operand-parse op))
  1637.   (let ((ptypes (if (eq type '*) (list 't) (rest type)))
  1638.     (scs (operand-parse-scs op)))
  1639.     (when scs
  1640.       (multiple-value-bind (costs load-scs)
  1641.                (compute-loading-costs op load-p)
  1642.     (declare (ignore costs))
  1643.     (dolist (ptype ptypes)
  1644.       (unless (dolist (rep (primitive-type-scs
  1645.                 (meta-primitive-type-or-lose ptype))
  1646.                    nil)
  1647.             (when (svref load-scs rep) (return t)))
  1648.         (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
  1649.                 none of the SCs allowed by the operand type ~S can ~
  1650.             directly be loaded~@
  1651.             into any of the restriction's SCs:~%  ~S~:[~;~@
  1652.             [* type operand must allow T's SCs.]~]"
  1653.            (operand-parse-name op) load-p (vop-parse-name parse)
  1654.            ptype
  1655.            scs (eq type '*)))))
  1656.       
  1657.       (dolist (sc scs)
  1658.     (unless (or (eq type '*)
  1659.             (dolist (ptype ptypes nil)
  1660.               (when (meta-sc-allowed-by-primitive-type
  1661.                  (meta-sc-or-lose sc)
  1662.                  (meta-primitive-type-or-lose ptype))
  1663.             (return t))))
  1664.       (warn "~:[Result~;Argument~] ~A to VOP ~S~@
  1665.              has SC restriction ~S which is ~
  1666.          not allowed by the operand type:~%  ~S"
  1667.         load-p (operand-parse-name op) (vop-parse-name parse)
  1668.         sc type)))))
  1669.  
  1670.   (undefined-value))
  1671.  
  1672. ); eval-when
  1673.  
  1674. ;;; Check-Operand-Types  --  Internal
  1675. ;;;
  1676. ;;;    If the operand types are specified, then check the number specified
  1677. ;;; against the number of defined operands.
  1678. ;;;
  1679. (defun check-operand-types (parse ops more-op types load-p)
  1680.   (declare (type vop-parse parse) (list ops)
  1681.        (type (or list (member :unspecified)) types)
  1682.        (type (or operand-parse null) more-op))
  1683.   (unless (eq types :unspecified)
  1684.     (let ((num (+ (length ops) (if more-op 1 0))))
  1685.       (unless (= (count-if-not #'(lambda (x)
  1686.                    (and (consp x)
  1687.                     (eq (car x) :constant)))
  1688.                    types)
  1689.          num)
  1690.     (error "Expected ~D ~:[result~;argument~] type~P: ~S."
  1691.            num load-p types num)))
  1692.     
  1693.     (when more-op
  1694.       (let ((mtype (car (last types))))
  1695.     (when (and (consp mtype) (eq (first mtype) :constant))
  1696.       (error "Can't use :CONSTANT on VOP more args.")))))
  1697.   
  1698.   (when (vop-parse-translate parse)
  1699.     (let ((types (specify-operand-types types ops more-op)))
  1700.       (mapc #'(lambda (x y)
  1701.         (check-operand-type-scs parse x y load-p))
  1702.         (if more-op (butlast ops) ops)
  1703.         (remove-if #'(lambda (x)
  1704.                (and (consp x)
  1705.                 (eq (car x) ':constant)))
  1706.                (if more-op (butlast types) types)))))
  1707.   
  1708.   (undefined-value))
  1709.  
  1710.  
  1711. ;;; Grovel-Operands  --  Internal
  1712. ;;;
  1713. ;;;    Compute stuff that can only be computed after we are done parsing
  1714. ;;; everying.  We set the VOP-Parse-Operands, and do various error checks.
  1715. ;;;
  1716. (defun grovel-operands (parse)
  1717.   (declare (type vop-parse parse))
  1718.  
  1719.   (setf (vop-parse-operands parse)
  1720.     (append (vop-parse-args parse)
  1721.         (if (vop-parse-more-args parse)
  1722.             (list (vop-parse-more-args parse)))
  1723.         (vop-parse-results parse)
  1724.         (if (vop-parse-more-results parse)
  1725.             (list (vop-parse-more-results parse)))
  1726.         (vop-parse-temps parse)))
  1727.  
  1728.   (check-operand-types parse
  1729.                (vop-parse-args parse)
  1730.                (vop-parse-more-args parse)
  1731.                (vop-parse-arg-types parse)
  1732.                t)
  1733.  
  1734.   
  1735.   (check-operand-types parse
  1736.                (vop-parse-results parse)
  1737.                (vop-parse-more-results parse)
  1738.                (vop-parse-result-types parse)
  1739.                nil)
  1740.  
  1741.   (undefined-value))
  1742.  
  1743.  
  1744. ;;;; Function translation stuff:
  1745.  
  1746. ;;; Adjoin-Template  --  Internal
  1747. ;;;
  1748. ;;;    Add Template into List, removing any old template with the same name.
  1749. ;;; We also maintain the increasing cost ordering.
  1750. ;;;
  1751. (defun adjoin-template (template list)
  1752.   (declare (type template template) (list list))
  1753.   (sort (cons template
  1754.           (remove (template-name template) list
  1755.               :key #'template-name))
  1756.     #'<=
  1757.     :key #'template-cost))
  1758.  
  1759.  
  1760. ;;; Set-Up-Function-Translation  --  Internal
  1761. ;;;
  1762. ;;;    Return forms to establish this VOP as a IR2 translation template for the
  1763. ;;; :Translate functions specified in the VOP-Parse.  We also set the
  1764. ;;; Predicate attribute for each translated function when the VOP is
  1765. ;;; conditional, causing IR1 conversion to ensure that a call to the translated
  1766. ;;; is always used in a predicate position.
  1767. ;;;
  1768. (defun set-up-function-translation (parse n-template)
  1769.   (declare (type vop-parse parse))
  1770.   (mapcar #'(lambda (name)
  1771.           `(let ((info (function-info-or-lose ',name)))
  1772.          (setf (function-info-templates info)
  1773.                (adjoin-template ,n-template
  1774.                     (function-info-templates info)))
  1775.          ,@(when (vop-parse-conditional-p parse)
  1776.              '((setf (function-info-attributes info)
  1777.                  (attributes-union
  1778.                   (ir1-attributes predicate)
  1779.                   (function-info-attributes info)))))))
  1780.       (vop-parse-translate parse)))
  1781.  
  1782.  
  1783. ;;; Make-Operand-Type  --  Internal
  1784. ;;;
  1785. ;;;    Return a form that can be evaluated to get the TEMPLATE operand type
  1786. ;;; restriction from the given specification.
  1787. ;;;
  1788. (defun make-operand-type (type)
  1789.   (cond ((eq type '*) ''*)
  1790.     ((symbolp type)
  1791.      ``(:or ,(primitive-type-or-lose ',type)))
  1792.     (t
  1793.      (ecase (first type)
  1794.        (:or
  1795.         ``(:or ,,@(mapcar #'(lambda (type)
  1796.                    `(primitive-type-or-lose ',type))
  1797.                    (rest type))))
  1798.        (:constant
  1799.         ``(:constant ,#'(lambda (x)
  1800.                   (typep x ',(second type)))
  1801.              ,',(second type)))))))
  1802.  
  1803.  
  1804. ;;; Specify-Operand-Types  --  Internal
  1805. ;;;
  1806. (defun specify-operand-types (types ops more-ops)
  1807.   (if (eq types :unspecified)
  1808.       (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
  1809.       types))
  1810.  
  1811.  
  1812. ;;; Make-VOP-Info-Types  --  Internal
  1813. ;;;
  1814. ;;;    Return a list of forms to use as keyword args to Make-VOP-Info for
  1815. ;;; setting up the template argument and result types.  Here we make an initial
  1816. ;;; dummy Template-Type, since it is awkward to compute the type until the
  1817. ;;; template has been made.
  1818. ;;;
  1819. (defun make-vop-info-types (parse)
  1820.   (let* ((more-args (vop-parse-more-args parse))
  1821.      (all-args (specify-operand-types (vop-parse-arg-types parse)
  1822.                       (vop-parse-args parse)
  1823.                       more-args))
  1824.      (args (if more-args (butlast all-args) all-args))
  1825.      (more-arg (when more-args (car (last all-args))))
  1826.      (more-results (vop-parse-more-results parse))
  1827.      (all-results (specify-operand-types (vop-parse-result-types parse)
  1828.                          (vop-parse-results parse)
  1829.                          more-results))
  1830.      (results (if more-results (butlast all-results) all-results))
  1831.      (more-result (when more-results (car (last all-results))))
  1832.      (conditional (vop-parse-conditional-p parse)))
  1833.     
  1834.     `(
  1835.       :type (specifier-type '(function () nil))
  1836.       :arg-types (list ,@(mapcar #'make-operand-type args))
  1837.       :more-args-type ,(when more-args (make-operand-type more-arg))
  1838.       :result-types ,(if conditional
  1839.              :conditional
  1840.              `(list ,@(mapcar #'make-operand-type results)))
  1841.       :more-results-type ,(when more-results
  1842.                 (make-operand-type more-result)))))
  1843.  
  1844.  
  1845.  
  1846. ;;;; Set up VOP-Info:
  1847.  
  1848. (defconstant slot-inherit-alist
  1849.   '((:emit-function . vop-info-emit-function)
  1850.     (:generator-function . vop-info-generator-function)
  1851.     (:target-function . vop-info-target-function)))
  1852.  
  1853. ;;; Inherit-VOP-Info  --  Internal
  1854. ;;;
  1855. ;;;    Something to help with inheriting VOP-Info slots.  We return a
  1856. ;;; keyword/value pair that can be passed to the constructor.  Slot is the
  1857. ;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse
  1858. ;;; structure for the VOP inherited.  If Parse is NIL, then we do nothing.  If
  1859. ;;; the Test form evaluates to true, then we return a form that selects the
  1860. ;;; named slot from the VOP-Info structure corresponding to Parse.  Otherwise,
  1861. ;;; we return the Form so that the slot is recomputed.
  1862. ;;;
  1863. (defmacro inherit-vop-info (slot parse test form)
  1864.   `(if (and iparse ,test)
  1865.        (list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist))
  1866.                 (error "Unknown slot ~S." slot))
  1867.              (template-or-lose ',(vop-parse-name ,parse))))
  1868.        (list ,slot ,form)))
  1869.  
  1870.  
  1871. ;;; Set-Up-VOP-Info  --  Internal
  1872. ;;;
  1873. ;;;    Return a form that creates a VOP-Info structure which describes VOP.
  1874. ;;;
  1875. (defun set-up-vop-info (iparse parse)
  1876.   (declare (type vop-parse parse) (type (or vop-parse null) iparse))
  1877.   (let ((same-operands
  1878.      (and iparse
  1879.           (equal (vop-parse-operands parse)
  1880.              (vop-parse-operands iparse))
  1881.           (equal (vop-parse-info-args iparse)
  1882.              (vop-parse-info-args parse))))
  1883.     (variant (vop-parse-variant parse)))
  1884.  
  1885.     (let ((nvars (length (vop-parse-variant-vars parse))))
  1886.       (unless (= (length variant) nvars)
  1887.     (error "Expected ~D variant values: ~S." nvars variant)))
  1888.  
  1889.     `(make-vop-info
  1890.       :name ',(vop-parse-name parse)
  1891.       ,@(make-vop-info-types parse)
  1892.       :guard ,(when (vop-parse-guard parse)
  1893.         `#'(lambda () ,(vop-parse-guard parse)))
  1894.       :note ',(vop-parse-note parse)
  1895.       :info-arg-count ,(length (vop-parse-info-args parse))
  1896.       :policy ',(vop-parse-policy parse)
  1897.       :save-p ',(vop-parse-save-p parse)
  1898.       :move-args ',(vop-parse-move-args parse)
  1899.       :effects (vop-attributes ,@(vop-parse-effects parse))
  1900.       :affected (vop-attributes ,@(vop-parse-affected parse))
  1901.       ,@(make-costs-and-restrictions parse)
  1902.       ,@(inherit-vop-info :emit-function iparse
  1903.       same-operands
  1904.       (make-emit-function parse))
  1905.       ,@(inherit-vop-info :generator-function iparse
  1906.       (and same-operands
  1907.            (equal (vop-parse-body parse) (vop-parse-body iparse)))
  1908.       (unless (eq (vop-parse-body parse) :unspecified)
  1909.         (make-generator-function parse)))
  1910.       ,@(inherit-vop-info :target-function iparse
  1911.       same-operands
  1912.       (when (some #'operand-parse-target (vop-parse-operands parse))
  1913.         (make-target-function parse)))
  1914.       :variant (list ,@variant))))
  1915.  
  1916. ); Eval-When (Compile Load Eval)
  1917.  
  1918.  
  1919. ;;; Template-Type-Specifier  --  Internal
  1920. ;;;
  1921. ;;;    Return a function type specifier describing Template's type computed
  1922. ;;; from the operand type restrictions.
  1923. ;;;
  1924. (defun template-type-specifier (template)
  1925.   (declare (type template template))
  1926.   (flet ((convert (types more-types)
  1927.        (flet ((frob (x)
  1928.             (if (eq x '*)
  1929.             't
  1930.             (ecase (first x)
  1931.               (:or `(or ,@(mapcar #'(lambda (type)
  1932.                           (type-specifier
  1933.                            (primitive-type-type
  1934.                             type)))
  1935.                           (rest x))))
  1936.               (:constant `(constant-argument ,(third x)))))))
  1937.          `(,@(mapcar #'frob types)
  1938.            ,@(when more-types
  1939.            `(&rest ,(frob more-types)))))))
  1940.     (let* ((args (convert (template-arg-types template)
  1941.               (template-more-args-type template)))
  1942.        (result-restr (template-result-types template))
  1943.        (results (if (eq result-restr :conditional)
  1944.             '(boolean)
  1945.             (convert result-restr
  1946.                  (cond ((template-more-results-type template))
  1947.                        ((/= (length result-restr) 1) '*)
  1948.                        (t nil))))))
  1949.       `(function ,args
  1950.          ,(if (= (length results) 1)
  1951.               (first results)
  1952.               `(values ,@results))))))
  1953.  
  1954.  
  1955. ;;; Define-VOP  --  Public
  1956. ;;;
  1957. ;;;    Parse the syntax into a VOP-Parse structure, and then expand into code
  1958. ;;; that creates the appropriate VOP-Info structure at load time.  We implement
  1959. ;;; inheritance by copying the VOP-Parse structure for the inherited structure.
  1960. ;;;
  1961. (defmacro define-vop ((name &optional inherits) &rest specs)
  1962.   "Define-VOP (Name [Inherits]) Spec*
  1963.   Define the symbol Name to be a Virtual OPeration in the compiler.  If
  1964.   specified, Inherits is the name of a VOP that we default unspecified
  1965.   information from.  Each Spec is a list beginning with a keyword indicating
  1966.   the interpretation of the other forms in the Spec:
  1967.   
  1968.   :Args {(Name {Key Value}*)}*
  1969.   :Results {(Name {Key Value}*)}*
  1970.       The Args and Results are specifications of the operand TNs passed to the
  1971.       VOP.  If there is an inherited VOP, any unspecified options are defaulted
  1972.       from the inherited argument (or result) of the same name.  The following
  1973.       operand options are defined: 
  1974.  
  1975.       :SCs (SC*)
  1976.       :SCs specifies good SCs for this operand.  Other SCs will be
  1977.       penalized according to move costs.  A load TN will be allocated if
  1978.       necessary, guaranteeing that the operand is always one of the
  1979.       specified SCs.
  1980.  
  1981.       :Load-TN Load-Name
  1982.           Load-Name is bound to the load TN allocated for this operand, or to
  1983.       NIL if no load TN was allocated.
  1984.  
  1985.       :Load-If Expression
  1986.           Controls whether automatic operand loading is done.  Expression is
  1987.       evaluated with the fixed operand TNs bound.  If Expression is true,
  1988.       then loading is done and the variable is bound to the load TN in
  1989.       the generator body.  Otherwise, loading is not done, and the variable
  1990.       is bound to the actual operand.
  1991.  
  1992.       :More T-or-NIL
  1993.       If specified, Name is bound to the TN-Ref for the first argument or
  1994.       result following the fixed arguments or results.  A more operand must
  1995.       appear last, and cannot be targeted or restricted.
  1996.  
  1997.       :Target Operand
  1998.       This operand is targeted to the named operand, indicating a desire to
  1999.       pack in the same location.  Not legal for results.
  2000.  
  2001.       :From Time-Spec
  2002.       :To Time-Spec
  2003.       Specify the beginning or end of the operand's lifetime.  :From can
  2004.       only be used with results, and :To only with arguments.  The default
  2005.       for the N'th argument/result is (:ARGUMENT N)/(:RESULT N).  These
  2006.       options are necessary primarily when operands are read or written out
  2007.       of order.
  2008.    
  2009.   :Conditional
  2010.       This is used in place of :RESULTS with conditional branch VOPs.  There
  2011.       are no result values: the result is a transfer of control.  The target
  2012.       label is passed as the first :INFO arg.  The second :INFO arg is true if
  2013.       the sense of the test should be negated.  A side-effect is to set the
  2014.       PREDICATE attribute for functions in the :TRANSLATE option.
  2015.   
  2016.   :Temporary ({Key Value}*) Name*
  2017.       Allocate a temporary TN for each Name, binding that variable to the TN
  2018.       within the body of the generators.  In addition to :Target (which is 
  2019.       is the same as for operands), the following options are
  2020.       defined:
  2021.  
  2022.       :SC SC-Name
  2023.       :Offset SB-Offset
  2024.       Force the temporary to be allocated in the specified SC with the
  2025.       specified offset.  Offset is evaluated at macroexpand time.  If
  2026.       Offset is emitted, the register allocator chooses a free location in
  2027.       SC.  If both SC and Offset are omitted, then the temporary is packed
  2028.       according to its primitive type.
  2029.  
  2030.       :From Time-Spec
  2031.       :To Time-Spec
  2032.       Similar to the argument/result option, this specifies the start and
  2033.       end of the temporarys' lives.  The defaults are :Load and :Save, i.e.
  2034.       the duration of the VOP.  The other intervening phases are :Argument,
  2035.       :Eval and :Result.  Non-zero sub-phases can be specified by a list,
  2036.       e.g. by default the second argument's life ends at (:Argument 1).
  2037.  
  2038.   :Generator Cost Form*
  2039.       Specifies the translation into assembly code. Cost is the estimated cost
  2040.       of the code emitted by this generator. The body is arbitrary Lisp code
  2041.       that emits the assembly language translation of the VOP.  An Assemble
  2042.       form is wrapped around the body, so code may be emitted by using the
  2043.       local Inst macro.  During the evaluation of the body, the names of the
  2044.       operands and temporaries are bound to the actual TNs.
  2045.   
  2046.   :Effects Effect*
  2047.   :Affected Effect*
  2048.       Specifies the side effects that this VOP has and the side effects that
  2049.       effect its execution.  If unspecified, these default to the worst case.
  2050.   
  2051.   :Info Name*
  2052.       Define some magic arguments that are passed directly to the code
  2053.       generator.  The corresponding trailing arguments to VOP or %Primitive are
  2054.       stored in the VOP structure.  Within the body of the generators, the
  2055.       named variables are bound to these values.  Except in the case of
  2056.       :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
  2057.       the direct translation for a function (specified by :Translate).
  2058.  
  2059.   :Ignore Name*
  2060.       Causes the named variables to be declared IGNORE in the generator body.
  2061.  
  2062.   :Variant Thing*
  2063.   :Variant-Vars Name*
  2064.       These options provide a way to parameterize families of VOPs that differ
  2065.       only trivially.  :Variant makes the specified evaluated Things be the
  2066.       \"variant\" associated with this VOP.  :Variant-Vars causes the named
  2067.       variables to be bound to the corresponding Things within the body of the
  2068.       generator.
  2069.  
  2070.   :Variant-Cost Cost
  2071.       Specifies the cost of this VOP, overriding the cost of any inherited
  2072.       generator.
  2073.  
  2074.   :Note {String | NIL}
  2075.       A short noun-like phrase describing what this VOP \"does\", i.e. the
  2076.       implementation strategy.  If supplied, efficency notes will be generated
  2077.       when type uncertainty prevents :TRANSLATE from working.  NIL inhibits any
  2078.       efficency note.
  2079.  
  2080.   :Arg-Types    {* | PType | (:OR PType*) | (:CONSTANT Type)}*
  2081.   :Result-Types {* | PType | (:OR PType*)}*
  2082.       Specify the template type restrictions used for automatic translation.
  2083.       If there is a :More operand, the last type is the more type.  :CONSTANT
  2084.       specifies that the argument must be a compile-time constant of the
  2085.       specified Lisp type.  The constant values of :CONSTANT arguments are
  2086.       passed as additional :INFO arguments rather than as :ARGS.
  2087.   
  2088.   :Translate Name*
  2089.       This option causes the VOP template to be entered as an IR2 translation
  2090.       for the named functions.
  2091.  
  2092.   :Policy {:Small | :Fast | :Safe | :Fast-Safe}
  2093.       Specifies the policy under which this VOP is the best translation.
  2094.  
  2095.   :Guard Form
  2096.       Specifies a Form that is evaluated in the global environment.  If
  2097.       form returns NIL, then emission of this VOP is prohibited even when
  2098.       all other restrictions are met.
  2099.  
  2100.   :VOP-Var Name
  2101.   :Node-Var Name
  2102.       In the generator, bind the specified variable to the VOP or the Node that
  2103.       generated this VOP.
  2104.  
  2105.   :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
  2106.       Indicates how a VOP wants live registers saved.
  2107.  
  2108.   :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
  2109.       Indicates if and how the more args should be moved into a different
  2110.       frame."
  2111.   (check-type name symbol)
  2112.   
  2113.   (let* ((iparse (when inherits
  2114.            (vop-parse-or-lose inherits)))
  2115.      (parse (if inherits
  2116.             (copy-vop-parse iparse)
  2117.             (make-vop-parse)))
  2118.      (n-res (gensym)))
  2119.     (setf (vop-parse-name parse) name)
  2120.     (setf (vop-parse-inherits parse) inherits)
  2121.  
  2122.     (parse-define-vop parse specs)
  2123.     (grovel-operands parse)
  2124.       
  2125.     `(progn
  2126.        (eval-when (compile load eval)
  2127.      (setf (gethash ',name (backend-parsed-vops *target-backend*))
  2128.            ',parse))
  2129.  
  2130.        (let ((,n-res ,(set-up-vop-info iparse parse)))
  2131.      (setf (gethash ',name (backend-template-names *target-backend*))
  2132.            ,n-res)
  2133.      (setf (template-type ,n-res)
  2134.            (specifier-type (template-type-specifier ,n-res)))
  2135.      ,@(set-up-function-translation parse n-res))
  2136.        #-new-compiler
  2137.        (eval-when (compile)
  2138.      (clc::clc-mumble "vop ~S compiled.~%" ',name))
  2139.        ',name)))
  2140.  
  2141.  
  2142. ;;;; Emission macros:
  2143.  
  2144. (eval-when (compile load eval)
  2145.  
  2146. ;;; Make-Operand-List  --  Internal
  2147. ;;;
  2148. ;;;    Return code to make a list of VOP arguments or results, linked by
  2149. ;;; TN-Ref-Across.  The first value is code, the second value is LET* forms,
  2150. ;;; and the third value is a variable that evaluates to the head of the list,
  2151. ;;; or NIL if there are no operands.  Fixed is a list of forms that evaluate to
  2152. ;;; TNs for the fixed operands.  TN-Refs will be made for these operands
  2153. ;;; according using the specified value of Write-P.  More is an expression that
  2154. ;;; evaluates to a list of TN-Refs that will be made the tail of the list.  If
  2155. ;;; it is constant NIL, then we don't bother to set the tail.
  2156. ;;;
  2157. (defun make-operand-list (fixed more write-p)
  2158.   (collect ((forms)
  2159.         (binds))
  2160.     (let ((n-head nil)
  2161.       (n-prev nil))
  2162.       (dolist (op fixed)
  2163.     (let ((n-ref (gensym)))
  2164.       (binds `(,n-ref (reference-tn ,op ,write-p)))
  2165.       (if n-prev
  2166.           (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
  2167.         (setq n-head n-ref))
  2168.       (setq n-prev n-ref)))
  2169.  
  2170.       (when more
  2171.     (let ((n-more (gensym)))
  2172.       (binds `(,n-more ,more))
  2173.       (if n-prev
  2174.           (forms `(setf (tn-ref-across ,n-prev) ,n-more))
  2175.           (setq n-head n-more))))
  2176.  
  2177.       (values (forms) (binds) n-head))))
  2178.  
  2179. ); Eval-When (Compile Load Eval)
  2180.  
  2181.  
  2182. ;;; Emit-Template  -- Interface
  2183. ;;;
  2184. (defmacro emit-template (node block template args results &optional info)
  2185.   "Emit-Template Node Block Template Args Results [Info]
  2186.   Call the emit function for Template, linking the result in at the end of
  2187.   Block."
  2188.   (let ((n-first (gensym))
  2189.     (n-last (gensym)))
  2190.     (once-only ((n-node node)
  2191.         (n-block block)
  2192.         (n-template template))
  2193.       `(multiple-value-bind
  2194.        (,n-first ,n-last)
  2195.        (funcall (template-emit-function ,n-template)
  2196.             ,n-node ,n-block ,n-template ,args ,results
  2197.             ,@(when info `(,info)))
  2198.      (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
  2199.  
  2200.   
  2201. ;;; VOP  --  Interface
  2202. ;;;
  2203. (defmacro vop (name node block &rest operands)
  2204.   "VOP Name Node Block Arg* Info* Result*
  2205.   Emit the VOP (or other template) Name at the end of the IR2-Block Block,
  2206.   using Node for the source context.  The interpretation of the remaining
  2207.   arguments depends on the number of operands of various kinds that are
  2208.   declared in the template definition.  VOP cannot be used for templates that
  2209.   have more-args or more-results, since the number of arguments and results is
  2210.   indeterminate for these templates.  Use VOP* instead.
  2211.   
  2212.   Args and Results are the TNs that are to be referenced by the template
  2213.   as arguments and results.  If the template has codegen-info arguments, then
  2214.   the appropriate number of Info forms following the Arguments are used for
  2215.   codegen info."
  2216.   (let* ((parse (vop-parse-or-lose name))
  2217.      (arg-count (length (vop-parse-args parse)))
  2218.      (result-count (length (vop-parse-results parse)))
  2219.      (info-count (length (vop-parse-info-args parse)))
  2220.      (noperands (+ arg-count result-count info-count))
  2221.      (n-node (gensym))
  2222.      (n-block (gensym))
  2223.      (n-template (gensym)))
  2224.     
  2225.     (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
  2226.       (error "Cannot use VOP with variable operand count templates."))
  2227.     (unless (= noperands (length operands))
  2228.       (error "Called with ~D operands, but was expecting ~D."
  2229.          (length operands) noperands))
  2230.     
  2231.     (multiple-value-bind
  2232.     (acode abinds n-args)
  2233.     (make-operand-list (subseq operands 0 arg-count) nil nil)
  2234.       (multiple-value-bind
  2235.       (rcode rbinds n-results)
  2236.       (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
  2237.     
  2238.     (collect ((ibinds)
  2239.           (ivars))
  2240.       (dolist (info (subseq operands arg-count (+ arg-count info-count)))
  2241.         (let ((temp (gensym)))
  2242.           (ibinds `(,temp ,info))
  2243.           (ivars temp)))
  2244.       
  2245.       `(let* ((,n-node ,node)
  2246.           (,n-block ,block)
  2247.           (,n-template (template-or-lose ',name *backend*))
  2248.           ,@abinds
  2249.           ,@(ibinds)
  2250.           ,@rbinds)
  2251.          ,@acode
  2252.          ,@rcode
  2253.          (emit-template ,n-node ,n-block ,n-template ,n-args
  2254.                 ,n-results 
  2255.                 ,@(when (ivars)
  2256.                 `((list ,@(ivars)))))
  2257.          (undefined-value)))))))
  2258.  
  2259.  
  2260. ;;; VOP*  --  Interface
  2261. ;;;
  2262. (defmacro vop* (name node block args results &rest info)
  2263.   "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
  2264.   Like VOP, but allows for emission of templates with arbitrary numbers of
  2265.   arguments, and for emission of templates using already-created TN-Ref lists.
  2266.  
  2267.   The Arguments and Results are TNs to be referenced as the first arguments
  2268.   and results to the template.  More-Args and More-Results are heads of TN-Ref
  2269.   lists that are added onto the end of the TN-Refs for the explicitly supplied
  2270.   operand TNs.  The TN-Refs for the more operands must have the TN and Write-P
  2271.   slots correctly initialized.
  2272.  
  2273.   As with VOP, the Info forms are evaluated and passed as codegen info
  2274.   arguments."
  2275.   (check-type args cons)
  2276.   (check-type results cons)
  2277.   (let* ((parse (vop-parse-or-lose name))
  2278.      (arg-count (length (vop-parse-args parse)))
  2279.      (result-count (length (vop-parse-results parse)))
  2280.      (info-count (length (vop-parse-info-args parse)))
  2281.      (fixed-args (butlast args))
  2282.      (fixed-results (butlast results))
  2283.      (n-node (gensym))
  2284.      (n-block (gensym))
  2285.      (n-template (gensym)))
  2286.     
  2287.     (unless (or (vop-parse-more-args parse)
  2288.         (<= (length fixed-args) arg-count))
  2289.       (error "Too many fixed arguments."))
  2290.     (unless (or (vop-parse-more-results parse)
  2291.         (<= (length fixed-results) result-count))
  2292.       (error "Too many fixed results."))
  2293.     (unless (= (length info) info-count)
  2294.       (error "Expected ~D info args." info-count))
  2295.     
  2296.     (multiple-value-bind
  2297.     (acode abinds n-args)
  2298.     (make-operand-list fixed-args (car (last args)) nil)
  2299.       (multiple-value-bind
  2300.       (rcode rbinds n-results)
  2301.       (make-operand-list fixed-results (car (last results)) t)
  2302.     
  2303.     `(let* ((,n-node ,node)
  2304.         (,n-block ,block)
  2305.         (,n-template (template-or-lose ',name *backend*))
  2306.         ,@abinds
  2307.         ,@rbinds)
  2308.        ,@acode
  2309.        ,@rcode
  2310.        (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
  2311.               ,@(when info
  2312.                   `((list ,@info))))
  2313.        (undefined-value))))))
  2314.  
  2315.  
  2316. ;;;; Random macros:
  2317.  
  2318. ;;; SC-Case  --  Public
  2319. ;;;
  2320. (defmacro sc-case (tn &rest forms)
  2321.   "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
  2322.   Case off of TN's SC.  The first clause containing TN's SC is evaulated,
  2323.   returning the values of the last form.  A clause beginning with T specifies a
  2324.   default.  If it appears, it must be last.  If no default is specified, and no
  2325.   clause matches, then an error is signalled."
  2326.   (let ((n-sc (gensym))
  2327.     (n-tn (gensym)))
  2328.     (collect ((clauses))
  2329.       (do ((cases forms (rest cases)))
  2330.       ((null cases)
  2331.        (clauses `(t (error "Unknown SC to SC-Case for ~S:~%  ~S" ,n-tn
  2332.                    (sc-name (tn-sc ,n-tn))))))
  2333.     (let ((case (first cases)))
  2334.       (when (atom case) 
  2335.         (error "Illegal SC-Case clause: ~S." case))
  2336.       (let ((head (first case)))
  2337.         (when (eq head t)
  2338.           (when (rest cases)
  2339.         (error "T case is not last in SC-Case."))
  2340.           (clauses `(t nil ,@(rest case)))
  2341.           (return))
  2342.         (clauses `((or ,@(mapcar #'(lambda (x)
  2343.                      `(eql ,(meta-sc-number-or-lose x)
  2344.                            ,n-sc))
  2345.                      (if (atom head) (list head) head)))
  2346.                nil ,@(rest case))))))
  2347.  
  2348.       `(let* ((,n-tn ,tn)
  2349.           (,n-sc (sc-number (tn-sc ,n-tn))))
  2350.      (cond ,@(clauses))))))
  2351.  
  2352.  
  2353. ;;; SC-Is  --  Interface
  2354. ;;;
  2355. (defmacro sc-is (tn &rest scs)
  2356.   "SC-Is TN SC*
  2357.   Returns true if TNs SC is any of the named SCs, false otherwise."
  2358.   (once-only ((n-sc `(sc-number (tn-sc ,tn))))
  2359.     `(or ,@(mapcar #'(lambda (x)
  2360.                `(eql ,n-sc ,(meta-sc-number-or-lose x)))
  2361.            scs))))
  2362.  
  2363.  
  2364. ;;; Do-IR2-Blocks  --  Interface
  2365. ;;;
  2366. (defmacro do-ir2-blocks ((block-var component &optional result)
  2367.              &body forms)
  2368.   "Do-IR2-Blocks (Block-Var Component [Result]) Form*
  2369.   Iterate over the IR2 blocks in component, in emission order."
  2370.   `(do ((,block-var (block-info (component-head ,component))
  2371.             (ir2-block-next ,block-var)))
  2372.        ((null ,block-var) ,result)
  2373.      ,@forms)))
  2374.  
  2375.  
  2376. ;;; DO-LIVE-TNS  --  Interface
  2377. ;;;
  2378. (defmacro do-live-tns ((tn-var live block &optional result) &body body)
  2379.   "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
  2380.   Iterate over all the TNs live at some point, with the live set represented by
  2381.   a local conflicts bit-vector and the IR2-Block containing the location."
  2382.   (let ((n-conf (gensym))
  2383.     (n-bod (gensym))
  2384.     (i (gensym))
  2385.     (ltns (gensym)))
  2386.     (once-only ((n-live live)
  2387.         (n-block block))
  2388.       `(block nil
  2389.      (flet ((,n-bod (,tn-var) ,@body))
  2390.        ;;
  2391.        ;; Do component-live TNs.
  2392.        (dolist (,tn-var (ir2-component-component-tns
  2393.                  (component-info
  2394.                   (block-component
  2395.                    (ir2-block-block ,n-block)))))
  2396.          (,n-bod ,tn-var))
  2397.        
  2398.        (let ((,ltns (ir2-block-local-tns ,n-block)))
  2399.          ;;
  2400.          ;; Do TNs always-live in this block and live :More TNs.
  2401.          (do ((,n-conf (ir2-block-global-tns ,n-block)
  2402.                (global-conflicts-next ,n-conf)))
  2403.          ((null ,n-conf))
  2404.            (when (or (eq (global-conflicts-kind ,n-conf) :live)
  2405.              (let ((,i (global-conflicts-number ,n-conf)))
  2406.                (and (eq (svref ,ltns ,i) :more)
  2407.                 (not (zerop (sbit ,n-live ,i))))))
  2408.          (,n-bod (global-conflicts-tn ,n-conf))))
  2409.          ;;
  2410.          ;; Do TNs locally live in the designated live set.
  2411.          (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
  2412.            (unless (zerop (sbit ,n-live ,i))
  2413.          (let ((,tn-var (svref ,ltns ,i)))
  2414.            (when (and ,tn-var (not (eq ,tn-var :more)))
  2415.              (,n-bod ,tn-var)))))))))))
  2416.  
  2417.  
  2418. ;;; DO-ENVIRONMENT-IR2-BLOCKS  --  Interface
  2419. ;;;
  2420. (defmacro do-environment-ir2-blocks ((block-var env &optional result)
  2421.                      &body body)
  2422.   "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
  2423.   Iterate over all the IR2 blocks in the environment Env, in emit order."
  2424.   (once-only ((n-env env))
  2425.     (once-only ((n-first `(node-block
  2426.                (lambda-bind
  2427.                 (environment-function ,n-env)))))
  2428.       (once-only ((n-tail `(block-info
  2429.                 (component-tail
  2430.                  (block-component ,n-first)))))
  2431.     `(do ((,block-var (block-info ,n-first)
  2432.               (ir2-block-next ,block-var)))
  2433.          ((or (eq ,block-var ,n-tail)
  2434.           (not (eq (ir2-block-environment ,block-var) ,n-env)))
  2435.           ,result)
  2436.        ,@body)))))
  2437.  
  2438.  
  2439. ;;; NOTE-THIS-LOCATION  --  Interface
  2440. ;;;
  2441. (defun note-this-location (vop kind)
  2442.   "NOTE-THIS-LOCATION VOP Kind
  2443.   Node that the current code location is an interesting (to the debugger)
  2444.   location of the specified Kind.  VOP is the VOP responsible for this code.
  2445.   This VOP must specify some non-null :SAVE-P value (perhaps :COMPUTE-ONLY) so
  2446.   that the live set is computed."
  2447.   (let ((lab (gen-label)))
  2448.     (emit-label lab)
  2449.     (note-debug-location vop lab kind)))
  2450.