Skip to content
Snippets Groups Projects
vmdef.lisp 82.6 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
ram's avatar
ram committed
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/vmdef.lisp,v 1.45 1992/08/03 19:06:50 wlott Exp $")
ram's avatar
ram committed
;;;
wlott's avatar
wlott committed
;;; **********************************************************************
;;;
;;;    This file contains implementation-independent facilities used for
;;; defining the compiler's interface to the VM in a given implementation.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)

(export '(template-or-lose sc-or-lose sb-or-lose sc-number-or-lose
	  meta-sc-or-lose meta-sb-or-lose meta-sc-number-or-lose
	  define-storage-base define-storage-class define-move-function
	  define-move-function define-move-vop 
	  primitive-type-or-lose meta-primitive-type-or-lose
	  def-primitive-type def-primitive-type-alias
	  primitive-type-vop define-vop sc-case sc-is
	  note-this-location note-next-instruction))
wlott's avatar
wlott committed

;;; Template-Or-Lose  --  Internal
;;;
;;;    Return the template having the specified name, or die trying.
;;;
(defun template-or-lose (x &optional (backend *target-backend*))
wlott's avatar
wlott committed
  (the template
       (or (gethash x (backend-template-names backend))
wlott's avatar
wlott committed
	   (error "~S is not a defined template." x))))


;;; SC-Or-Lose, SB-Or-Lose, SC-Number-Or-Lose  --  Internal
;;;
;;;    Return the SC structure, SB structure or SC number corresponding to a
wlott's avatar
wlott committed
;;;
(defun sc-or-lose (x &optional (backend *target-backend*))
wlott's avatar
wlott committed
  (the sc
       (or (gethash x (backend-sc-names backend))
wlott's avatar
wlott committed
	   (error "~S is not a defined storage class." x))))
;;;
(defun sb-or-lose (x &optional (backend *target-backend*))
wlott's avatar
wlott committed
  (the sb
       (or (gethash x (backend-sb-names backend))
wlott's avatar
wlott committed
	   (error "~S is not a defined storage base." x))))
;;;
(defun sc-number-or-lose (x &optional (backend *target-backend*))
  (the sc-number (sc-number (sc-or-lose x backend))))
wlott's avatar
wlott committed

;;; META-SC-OR-LOSE, META-SB-OR-LOSE, META-SC-NUMBER-OR-LOSE  --  Internal
;;;
;;;    Like the non-meta versions, but go for the meta-compile-time info.
;;; These should not be used after load time, since compiling the compiler
;;; changes the definitions.
;;;
(defun meta-sc-or-lose (x)
  (the sc
       (or (gethash x (backend-meta-sc-names *target-backend*))
	   (error "~S is not a defined storage class." x))))
;;;
(defun meta-sb-or-lose (x)
  (the sb
       (or (gethash x (backend-meta-sb-names *target-backend*))
	   (error "~S is not a defined storage base." x))))
;;;
(defun meta-sc-number-or-lose (x)
  (the sc-number (sc-number (meta-sc-or-lose x))))

wlott's avatar
wlott committed


;;;; Storage class and storage base definition:

;;; Define-Storage-Base  --  Public
;;;
;;;    Enter the basic structure at meta-compile time, and then fill in the
;;; missing slots at load time.
;;;
(defmacro define-storage-base (name kind &key size)
  "Define-Storage-Base Name Kind {Key Value}*
  Define a storage base having the specified Name.  Kind may be :Finite,
  :Unbounded or :Non-Packed.  The following keywords are legal:

  :Size <Size>
      Specify the number of locations in a :Finite SB or the initial size of a
      :Unbounded SB."
  (check-type name symbol)
  (check-type kind (member :finite :unbounded :non-packed))
  (ecase kind
    (:non-packed
     (when size
       (error "Size specification meaningless in a ~S SB." kind)))
    ((:finite :unbounded)
     (unless size (error "Size not specified in a ~S SB." kind))
     (check-type size unsigned-byte)))
    
  (let ((res (if (eq kind :non-packed)
		 (make-sb :name name :kind kind)
		 (make-finite-sb :name name :kind kind :size size))))
    `(progn
       (eval-when (compile load eval)
	 (setf (gethash ',name (backend-meta-sb-names *target-backend*))
	       ',res))
wlott's avatar
wlott committed
       ,(if (eq kind :non-packed)
	    `(setf (gethash ',name (backend-sb-names *target-backend*))
wlott's avatar
wlott committed
	    `(let ((res (copy-finite-sb ',res)))
	       (setf (finite-sb-always-live res)
		     (make-array ',size :initial-element #*))
	       (setf (finite-sb-conflicts res)
		     (make-array ',size :initial-element '#()))
	       (setf (finite-sb-live-tns res)
		     (make-array ',size :initial-element nil))
	       (setf (gethash ',name (backend-sb-names *target-backend*))
		     res)))
       (setf (backend-sb-list *target-backend*)
		   (remove ',name (backend-sb-list *target-backend*)
wlott's avatar
wlott committed
       ',name)))


;;; Define-Storage-Class  --  Public
;;;
;;;
(defmacro define-storage-class (name number sb-name &key (element-size '1)
				     (alignment '1) locations reserve-locations
				     save-p alternate-scs constant-scs)
wlott's avatar
wlott committed
  "Define-Storage-Class Name Number Storage-Base {Key Value}*
  Define a storage class Name that uses the named Storage-Base.  Number is a
  small, non-negative integer that is used as an alias.  The following
  keywords are defined:

ram's avatar
ram committed
  :Element-Size Size
wlott's avatar
wlott committed
      The size of objects in this SC in whatever units the SB uses.  This
      defaults to 1.

  :Alignment Size
      The alignment restrictions for this SC.  TNs will only be allocated at
      offsets that are an even multiple of this number.  Defaults to 1.

ram's avatar
ram committed
  :Locations (Location*)
wlott's avatar
wlott committed
      If the SB is :Finite, then this is a list of the offsets within the SB
ram's avatar
ram committed
      that are in this SC.

  :Reserve-Locations (Location*)
      A subset of the Locations that the register allocator should try to
      reserve for operand loading (instead of to hold variable values.)

ram's avatar
ram committed
  :Save-P {T | NIL}
      If T, then values stored in this SC must be saved in one of the
      non-save-p :Alternate-SCs across calls.

  :Alternate-SCs (SC*)
      Indicates other SCs that can be used to hold values from this SC across
      calls or when storage in this SC is exhausted.  The SCs should be
      specified in order of decreasing \"goodness\".  There must be at least
      one SC in an unbounded SB, unless this SC is only used for restricted or
      wired TNs.
ram's avatar
ram committed

  :Constant-SCs (SC*)
      A list of the names of all the constant SCs that can be loaded into this
wlott's avatar
wlott committed
  
  (check-type name symbol)
  (check-type number sc-number)
  (check-type sb-name symbol)
  (check-type locations list)
  (check-type reserve-locations list)
ram's avatar
ram committed
  (check-type save-p boolean)
  (check-type alternate-scs list)
  (check-type constant-scs list)
wlott's avatar
wlott committed

  (let ((sb (meta-sb-or-lose sb-name)))
wlott's avatar
wlott committed
    (if (eq (sb-kind sb) :finite)
	(let ((size (sb-size sb))
	      (element-size (eval element-size)))
	  (check-type element-size unsigned-byte)
	  (dolist (el locations)
	    (check-type el unsigned-byte)
	    (unless (<= 1 (+ el element-size) size)
	      (error "SC element ~D out of bounds for ~S." el sb))))
	(when locations
ram's avatar
ram committed
	  (error ":Locations is meaningless in a ~S SB." (sb-kind sb))))

    (unless (subsetp reserve-locations locations)
      (error "Reserve-Locations not a subset of Locations."))

ram's avatar
ram committed
    (when (and (or alternate-scs constant-scs)
	       (eq (sb-kind sb) :non-packed))
      (error "Meaningless to specify alternate or constant SCs in a ~S SB."
	     (sb-kind sb))))

  (let ((nstack-p
	 (if (or (eq sb-name 'non-descriptor-stack)
		 (find 'non-descriptor-stack
		       (mapcar #'meta-sc-or-lose alternate-scs)
ram's avatar
ram committed
		       :key #'(lambda (x)
				(sb-name (sc-sb x)))))
	     t nil)))
    `(progn
       (eval-when (compile load eval)
	 (let ((res (make-sc :name ',name :number ',number
ram's avatar
ram committed
			     :sb (meta-sb-or-lose ',sb-name)
ram's avatar
ram committed
			     :element-size ,element-size
ram's avatar
ram committed
			     :locations ',locations
			     :reserve-locations ',reserve-locations
ram's avatar
ram committed
			     :save-p ',save-p
			     :number-stack-p ,nstack-p
			     :alternate-scs (mapcar #'meta-sc-or-lose
ram's avatar
ram committed
						    ',alternate-scs)
			     :constant-scs (mapcar #'meta-sc-or-lose
ram's avatar
ram committed
						   ',constant-scs))))
	   (setf (gethash ',name (backend-meta-sc-names *target-backend*)) res)
	   (setf (svref (backend-meta-sc-numbers *target-backend*) ',number)
		 res)
ram's avatar
ram committed
	   (setf (svref (sc-load-costs res) ',number) 0)))
       (let ((old (svref (backend-sc-numbers *target-backend*) ',number)))
ram's avatar
ram committed
	 (when (and old (not (eq (sc-name old) ',name)))
	   (warn "Redefining SC number ~D from ~S to ~S." ',number
		 (sc-name old) ',name)))
       
       (setf (svref (backend-sc-numbers *target-backend*) ',number)
	     (meta-sc-or-lose ',name))
       (setf (gethash ',name (backend-sc-names *target-backend*))
ram's avatar
ram committed
       (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
ram's avatar
ram committed
       ',name)))
wlott's avatar
wlott committed

ram's avatar
ram committed

;;;; Move/coerce definition:
wlott's avatar
wlott committed


ram's avatar
ram committed
;;; DO-SC-PAIRS  --  Internal
;;;
;;;    Given a list of paris of lists of SCs (as given to DEFINE-MOVE-VOP,
;;; etc.), bind TO-SC and FROM-SC to all the combinations.
;;;
(eval-when (compile load eval)
  (defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
    `(do ((froms ,scs (cddr froms))
	  (tos (cdr ,scs) (cddr tos)))
	 ((null froms))
       (dolist (from (car froms))
	 (let ((,from-sc-var (meta-sc-or-lose from)))
ram's avatar
ram committed
	   (dolist (to (car tos))
	     (let ((,to-sc-var (meta-sc-or-lose to)))
ram's avatar
ram committed
	       ,@body)))))))


;;; DEFINE-MOVE-FUNCTION  --  Public
;;;
(defmacro define-move-function ((name cost) lambda-list scs &body body)
  "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
  Define the function Name and note it as the function used for moving operands
  from the From-SCs to the To-SCs.  Cost is the cost of this move operation.
  The function is called with three arguments: the VOP (for context), and the
  source and destination TNs.  An ASSEMBLE form is wrapped around the body.
  All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
ram's avatar
ram committed
  DEFINE-VOP."
  (when (or (oddp (length scs)) (null scs))
    (error "Malformed SCs spec: ~S." scs))
  (check-type cost index)
  `(progn
     (eval-when (compile load eval)
       (do-sc-pairs (from-sc to-sc ',scs)
	 (unless (eq from-sc to-sc)
	   (let ((num (sc-number from-sc)))
	     (setf (svref (sc-move-functions to-sc) num) ',name)
ram's avatar
ram committed
	     (setf (svref (sc-load-costs to-sc) num) ',cost)))))

     (defun ,name ,lambda-list
       (new-assem:assemble (*code-segment* ,(first lambda-list))
	 ,@body))))
ram's avatar
ram committed


(defconstant sc-vop-slots '((:move . sc-move-vops)
			    (:move-argument . sc-move-arg-vops)))


;;; COMPUTE-MOVE-COSTS  --  Internal
;;;
;;;    Compute at meta-compile time the costs for moving between all SCs that
;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
;;;
(defun compute-move-costs (from-sc to-sc cost)
  (declare (type sc from-sc to-sc) (type index cost))
  (let ((to-scn (sc-number to-sc))
	(from-costs (sc-load-costs from-sc)))
    (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
      (let ((vec (sc-move-costs dest-sc))
	    (dest-costs (sc-load-costs dest-sc)))
	(setf (svref vec (sc-number from-sc)) cost)
	(dolist (sc (append (sc-alternate-scs from-sc)
			    (sc-constant-scs from-sc)))
	  (let* ((scn (sc-number sc))
		 (total (+ (svref from-costs scn)
			   (svref dest-costs to-scn)
			   cost))
		 (old (svref vec scn)))
	    (unless (and old (< old total))
	      (setf (svref vec scn) total))))))))
    
    
;;; DEFINE-MOVE-VOP  --  Public
;;;
ram's avatar
ram committed
;;;    We record the VOP and costs for all SCs that we can move between
;;; (including implicit loading).
ram's avatar
ram committed
;;;
(defmacro define-move-vop (name kind &rest scs)
  "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*
  Make Name be the VOP used to move values in the specified From-SCs to the
  representation of the To-SCs.  If kind is :Move-Argument, then the VOP takes
  an extra argument, which is the frame pointer of the frame to move into." 
  (when (or (oddp (length scs)) (null scs))
    (error "Malformed SCs spec: ~S." scs))
  (let ((accessor (or (cdr (assoc kind sc-vop-slots))
		      (error "Unknown kind ~S." kind))))
    `(progn
       ,@(when (eq kind :move)
	   `((eval-when (compile load eval)
	       (do-sc-pairs (from-sc to-sc ',scs)
		 (compute-move-costs from-sc to-sc
				     ,(vop-parse-cost
				       (vop-parse-or-lose name)))))))
       
       (let ((vop (template-or-lose ',name)))
	 (do-sc-pairs (from-sc to-sc ',scs)
	   (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
	     (let ((vec (,accessor dest-sc)))
	       (let ((scn (sc-number from-sc)))
		 (setf (svref vec scn)
		       (adjoin-template vop (svref vec scn))))
ram's avatar
ram committed
	       (dolist (sc (append (sc-alternate-scs from-sc)
				   (sc-constant-scs from-sc)))
		 (let ((scn (sc-number sc)))
		   (setf (svref vec scn)
			 (adjoin-template vop (svref vec scn))))))))))))
wlott's avatar
wlott committed


;;;; Primitive type definition:

;;; PRIMITIVE-TYPE-OR-LOSE, META-PRIMITIVE-TYPE-OR-LOSE  --  Interface
;;;
;;;    Return the primitive type corresponding to the specified name, or die
;;; trying.
;;;
(defun primitive-type-or-lose (name &optional (backend *target-backend*))
       (or (gethash name (backend-primitive-type-names backend))
	   (error "~S is not a defined primitive type." name))))
;;;
(defun meta-primitive-type-or-lose (name)
  (the primitive-type
       (or (gethash name (backend-meta-primitive-type-names *target-backend*))
	   (error "~S is not a defined primitive type." name))))

wlott's avatar
wlott committed

;;; Def-Primitive-Type  --  Public
;;;
;;;    If the primitive-type structure already exists, we destructively modify
;;; it so that existing references in templates won't be invalidated.
;;; Primitive-type definition isn't done at meta-compile time, so this doesn't
;;; break the running compiler.
;;;
(defmacro def-primitive-type (name scs &key (type name))
  "Def-Primitive-Type Name (SC*) {Key Value}*
   Define a primitive type Name.  Each SC specifies a Storage Class that values
   of this type may be allocated in.  The following keyword options are
   defined:
  
wlott's avatar
wlott committed
  :Type
      The type descriptor for the Lisp type that is equivalent to this type
      (defaults to Name.)"
  (check-type name symbol)
  (check-type scs list)
  (let ((scns (mapcar #'meta-sc-number-or-lose scs))
	(get-type `(specifier-type ',type)))
wlott's avatar
wlott committed
    `(progn
       (eval-when (compile load eval)
	 (setf (gethash ',name (backend-meta-primitive-type-names
				*target-backend*))
	       (make-primitive-type :name ',name  :scs ',scns
       ,(once-only ((n-old `(gethash ',name
				     (backend-primitive-type-names
				      *target-backend*)))
		    (n-type get-type))
	  `(progn
	     (cond (,n-old
		    (setf (primitive-type-scs ,n-old) ',scns)
		    (setf (primitive-type-type ,n-old) ,n-type))
		   (t
				   (backend-primitive-type-names
				    *target-backend*))
			  (make-primitive-type :name ',name  :scs ',scns
					       :type ,n-type))))
	     ',name)))))
wlott's avatar
wlott committed


;;; Def-Primitive-Type-Alias  --  Public
wlott's avatar
wlott committed
;;;
;;; Just record the translation.
;;; 
(defmacro def-primitive-type-alias (name result)
  "DEF-PRIMITIVE-TYPE-ALIAS Name Result
  Define name to be an alias for Result in VOP operand type restrictions."
  `(eval-when (compile load eval)
     (setf (gethash ',name (backend-primitive-type-aliases *target-backend*))
wlott's avatar
wlott committed


(eval-when (compile load eval)
  (defparameter primitive-type-slot-alist
ram's avatar
ram committed
    '((:check . primitive-type-check))))
wlott's avatar
wlott committed


;;; Primitive-Type-Vop  --  Public
;;;
(defmacro primitive-type-vop (vop kinds &rest types)
  "Primitive-Type-VOP Vop (Kind*) Type*
  Annotate all the specified primitive Types with the named VOP under each of
  the specified kinds:

  :Check
      A one argument one result VOP that moves the argument to the result,
      checking that the value is of this type in the process."
  (let ((n-vop (gensym))
	(n-type (gensym)))
    `(let ((,n-vop (template-or-lose ',vop)))
       ,@(mapcar
	  #'(lambda (type)
	      `(let ((,n-type (primitive-type-or-lose ',type)))
		 ,@(mapcar
		    #'(lambda (kind)
			(let ((slot (or (cdr (assoc kind
						    primitive-type-slot-alist))
					(error "Unknown kind: ~S." kind))))
			  `(setf (,slot ,n-type) ,n-vop)))
		    kinds)))
	  types)
       nil)))


;;; SC-ALLOWED-BY-PRIMITIVE-TYPE  --  Interface
;;;
;;;    Return true if SC is either one of Ptype's SC's, or one of those SC's
;;; alternate or constant SCs.  The META- version uses meta-compile time info.
;;;
(macrolet
    ((frob (name sc-numbers-fun compile-time-also)
wlott's avatar
wlott committed
       `(eval-when (load eval ,@(when compile-time-also '(compile)))
	  (defun ,name (sc ptype)
	    (declare (type sc sc) (type primitive-type ptype))
	    (let ((scn (sc-number sc)))
	      (dolist (allowed (primitive-type-scs ptype) nil)
		(when (eql allowed scn)
		  (return t))
		(let ((allowed-sc (svref ,sc-numbers-fun allowed)))
wlott's avatar
wlott committed
		  (when (or (member sc (sc-alternate-scs allowed-sc))
			    (member sc (sc-constant-scs allowed-sc)))
		    (return t)))))))))
  (frob sc-allowed-by-primitive-type (backend-sc-numbers *backend*) nil)
  (frob meta-sc-allowed-by-primitive-type
    (backend-meta-sc-numbers *target-backend*) t))
wlott's avatar
wlott committed

;;;; VOP definition structures:
;;;
;;;    Define-VOP uses some fairly complex data structures at meta-compile
;;; time, both to hold the results of parsing the elaborate syntax and to
;;; retain the information so that it can be inherited by other VOPs.

(eval-when (compile load eval)

;;; The VOP-Parse structure holds everything we need to know about a VOP at
;;; meta-compile time.
;;;
(defstruct (vop-parse
	    (:print-function %print-vop-parse)
	    (:make-load-form-fun :just-dump-it-normally))
wlott's avatar
wlott committed
  ;;
  ;; The name of this VOP.
  (name nil :type symbol)
  ;;
  ;; If true, then the name of the VOP we inherit from.
  (inherits nil :type (or symbol null))
  ;;
  ;; Lists of Operand-Parse structures describing the arguments, results and
  ;; temporaries of the VOP.
  (args nil :type list)
  (results nil :type list)
  (temps nil :type list)
  ;;
  ;; Operand-Parse structures containing information about more args and
  ;; results.  If null, then there there are no more operands of that kind.
  (more-args nil :type (or operand-parse null))
  (more-results nil :type (or operand-parse null))
  ;;
  ;; A list of all the above together.
  (operands nil :type list)
  ;;
  ;; Names of variables that should be declared ignore.
  (ignores () :type list)
  ;;
  ;; True if this is a :Conditional VOP.
  (conditional-p nil)
  ;;
  ;; Argument and result primitive types.  These are pulled out of the
  ;; operands, since we often want to change them without respecifying the
  ;; operands.
  (arg-types :unspecified :type (or (member :unspecified) list))
  (result-types :unspecified :type (or (member :unspecified) list))
  ;;
  ;; The guard expression specified, or NIL if none.
  (guard nil)
  ;;
  ;; The cost of and body code for the generator.
  (cost 0 :type unsigned-byte)
  (body :unspecified :type (or (member :unspecified) list))
  ;;
  ;; Info for VOP variants.  The list of forms to be evaluated to get the
  ;; variant args for this VOP, and the list of variables to be bound to the
  ;; variant args.
  (variant () :type list)
  (variant-vars () :type list)
  ;;
  ;; Variables bound to the VOP and Vop-Node when in the generator body.
  (vop-var (gensym) :type symbol)
wlott's avatar
wlott committed
  (node-var nil :type (or symbol null))
  ;;
  ;; A list of the names of the codegen-info arguments to this VOP.
  (info-args () :type list)
  ;;
  ;; An efficiency note associated with this VOP.
  (note nil :type (or string null))
  ;;
  ;; A list of the names of the Effects and Affected attributes for this VOP.
  (effects '(any) :type list)
  (affected '(any) :type list)
  ;;
  ;; A list of the names of functions this VOP is a translation of and the
  ;; policy that allows this translation to be done.  :Fast is a safe default,
  ;; since it isn't a safe policy.
  (translate () :type list)
  (policy :fast :type policies)
  ;;
  ;; Stuff used by life analysis.
ram's avatar
ram committed
  (save-p nil :type (member t nil :compute-only :force-to-stack))
  ;;
  ;; Info about how to emit move-argument VOPs for the more operand in
  ;; call/return VOPs.
  (move-args nil :type (member nil :local-call :full-call :known-return)))

wlott's avatar
wlott committed

(defprinter vop-parse
  name
  (inherits :test inherits)
  args
  results
  temps
  (more-args :test more-args)
  (more-results :test more-results)
  (conditional-p :test conditional-p)
  ignores
  arg-types
  result-types
  cost
  body
  (variant :test variant)
  (variant-vars :test variant-vars)
  (info-args :test info-args)
  (note :test note)
  effects
  affected
  translate
ram's avatar
ram committed
  policy
  (save-p :test save-p)
  (move-args :test move-args))
wlott's avatar
wlott committed

;;; The Operand-Parse structure contains stuff we need to know about and
;;; operand or temporary at meta-compile time.  Besides the obvious stuff, we
;;; also store the names of per-operand temporaries here.
;;;
(defstruct (operand-parse
	    (:print-function %print-operand-parse)
	    (:make-load-form-fun :just-dump-it-normally))
wlott's avatar
wlott committed
  ;;
  ;; Name of the operand (which we bind to the TN).
  (name nil :type symbol)
  ;;
  ;; The way this operand is used:
  (kind (required-argument)
	:type (member :argument :result :temporary
		      :more-argument :more-result))
wlott's avatar
wlott committed
  ;;
  ;; If true, the name of an operand that this operand is targeted to.  This is
  ;; only meaningful in :Argument and :Temporary operands.
  (target nil :type (or symbol null))
  ;;
  ;; Temporary that holds the TN-Ref for this operand.  Temp-Temp holds the
  ;; write reference that begins a temporary's lifetime.
  (temp (gensym) :type symbol)
  (temp-temp nil :type (or symbol null))
  ;;
  ;; The time that this operand is first live and the time at which it becomes
  ;; dead again.  These are time-specs, as returned by parse-time-spec. 
  born
  dies
  ;;
  ;; A list of the names of the SCs that this operand is allowed into.  If
  ;; false, there is no restriction.
  (scs nil :type list)
  ;;
ram's avatar
ram committed
  ;; Variable that is bound to the load TN allocated for this operand, or to
  ;; NIL if no load-TN was allocated.
  (load-tn (gensym) :type symbol)
wlott's avatar
wlott committed
  ;;
  ;; An expression that tests whether to do automatic operand loading.
  (load t)
wlott's avatar
wlott committed
  ;;
ram's avatar
ram committed
  ;; In a wired or restricted temporary this is the SC the TN is to be packed
  ;; in.  Null otherwise.
wlott's avatar
wlott committed
  (sc nil :type (or symbol null))
ram's avatar
ram committed
  ;;
  ;; If non-null, we are a temp wired to this offset in SC.
wlott's avatar
wlott committed
  (offset nil :type (or unsigned-byte null)))


(defprinter operand-parse
  name
  kind
  (target :test target)
  born
  dies
  (scs :test scs)
ram's avatar
ram committed
  (load :test load)
wlott's avatar
wlott committed
  (sc :test sc)
  (offset :test offset))

); Eval-When (Compile Load Eval)


;;;; Random utilities:

(eval-when (compile load eval)

;;; Find-Operand  --  Internal
;;;
;;;    Find the operand or temporary with the specifed Name in the VOP Parse.
;;; If there is no such operand, signal an error.  Also error if the operand
;;; kind isn't one of the specified Kinds.  If Error-P is NIL, just return NIL
;;; if there is no such operand.
wlott's avatar
wlott committed
;;;
(defun find-operand (name parse &optional
			  (kinds '(:argument :result :temporary))
			  (error-p t))
wlott's avatar
wlott committed
  (declare (symbol name) (type vop-parse parse) (list kinds))
  (let ((found (find name (vop-parse-operands parse)
		     :key #'operand-parse-name)))
    (if found
	(unless (member (operand-parse-kind found) kinds)
	  (error "Operand ~S isn't one of these kinds: ~S." name kinds))
	(when error-p
	  (error "~S is not an operand to ~S." name (vop-parse-name parse))))
wlott's avatar
wlott committed
    found))


;;; VOP-Parse-Or-Lose  --  Internal
;;;
;;;    Get the VOP-Parse structure for Name or die trying.  For all
;;; meta-compile time uses, the VOP-Parse should be used instead of the
;;; VOP-Info
;;;
(defun vop-parse-or-lose (name &optional (backend *target-backend*))
wlott's avatar
wlott committed
  (the vop-parse
       (or (gethash name (backend-parsed-vops backend))
wlott's avatar
wlott committed
	   (error "~S is not the name of a defined VOP." name))))


;;; Access-Operands  --  Internal
;;;
;;;    Return a list of let-forms to parse a tn-ref list into a the temps
;;; specified by the operand-parse structures.  More-Operand is the
;;; Operand-Parse describing any more operand, or NIL if none.  Refs is an
;;; expression that evaluates into the first tn-ref.
;;;
(defun access-operands (operands more-operand refs)
  (declare (list operands))
wlott's avatar
wlott committed
  (collect ((res))
    (let ((prev refs))
      (dolist (op operands)
	(let ((n-ref (operand-parse-temp op)))
	  (res `(,n-ref ,prev))
	  (setq prev `(tn-ref-across ,n-ref))))

      (when more-operand
	(res `(,(operand-parse-name more-operand) ,prev))))
    (res)))


;;; Ignore-Unreferenced-Temps --  Internal
;;;
;;;    Used with Access-Operands to prevent warnings for TN-Ref temps not used
;;; by some particular function.  It returns the name of the last operand, or
;;; NIL if Operands is NIL.
;;;
(defun ignore-unreferenced-temps (operands)
  (when operands
    (operand-parse-temp (car (last operands)))))


;;; VOP-Spec-Arg  --  Internal
;;;
;;;    Grab an arg out of a VOP spec, checking the type and syntax and stuff.
;;;
(defun vop-spec-arg (spec type &optional (n 1) (last t))
  (let ((len (length spec)))
    (when (<= len n)
      (error "~:R argument missing: ~S." n spec))
    (when (and last (> len (1+ n)))
      (error "Extra junk at end of ~S." spec))
    (let ((thing (elt spec n)))
      (unless (typep thing type)
	(error "~:R argument is not a ~S: ~S." n type spec))
      thing)))


;;;; Time specs:

;;; Parse-Time-Spec  --  Internal
;;;
;;;    Return a time spec describing a time during the evaluation of a VOP,
;;; used to delimit operand and temporary lifetimes.  The representation is a
;;; cons whose CAR is the number of the evaluation phase and the CDR is the
;;; sub-phase.  The sub-phase is 0 in the :Load and :Save phases. 
;;;
(defun parse-time-spec (spec)
  (let ((dspec (if (atom spec) (list spec 0) spec)))
    (unless (and (= (length dspec) 2)
		 (typep (second dspec) 'unsigned-byte))
      (error "Malformed time specifier: ~S." spec))

    (cons (case (first dspec)
	    (:load 0)
	    (:argument 1)
	    (:eval 2)
	    (:result 3)
	    (:save 4)
	    (t
	     (error "Unknown phase in time specifier: ~S." spec)))
	  (second dspec))))


;;; Time-Spec-Order  --  Internal
;;;
;;;    Return true if the time spec X is the same or later time than Y.
;;;
(defun time-spec-order (x y)
  (or (> (car x) (car y))
      (and (= (car x) (car y))
	   (>= (cdr x) (cdr y)))))
 

;;;; Emit function generation:

;;; Compute-Reference-Order  --  Internal
;;;
;;;    Return a list of 2-lists (<Temporary> <More-P>) in reverse reference
;;; order describing how to build the next-ref linkage for Parse.  If More-P is
;;; false, then the Temporary points to a single TN-Ref that should be linked
;;; in.  If More-P is true, then Temporary points to a chain of Tn-Refs linked
;;; together by Tn-Ref-Across that should be linked in reverse order.
;;;
;;;    In implementation, we build a temporary list containing the result
;;; tuples augmented with reference time and whether the reference is a write.
;;; We sort this list using Time-Spec-Order augmented by the subsidiary rule
;;; that when the specs are equal, we do read references first.  This
;;; implements the desired semantics of open intervals for temporary lifetimes.
;;;
(defun compute-reference-order (parse)
  (declare (type vop-parse parse))
  (collect ((refs))
    (dolist (op (vop-parse-operands parse))
      (let ((born (operand-parse-born op))
	    (dies (operand-parse-dies op))
	    (name (operand-parse-name op))
	    (temp (operand-parse-temp op))
	    (temp-temp (operand-parse-temp-temp op)))
	(ecase (operand-parse-kind op)
	  (:argument
	   (refs (list (cons dies nil) temp nil)))
	  (:more-argument
	   (refs (list (cons dies nil) name t)))
	  (:result
	   (refs (list (cons born t) temp nil)))
	  (:more-result
	   (refs (list (cons born t) name t)))
	  (:temporary
	   (refs (list (cons born t) temp nil))
	   (refs (list (cons dies nil) temp-temp nil))))))

    (mapcar #'cdr
	    (sort (refs)
		  #'(lambda (x y)
		      (let ((x-time (car x))
			    (y-time (car y)))
		      (if (time-spec-order x-time y-time)
			  (if (time-spec-order y-time x-time)
			      (or (cdr x) (not (cdr y)))
			      t)
			  nil)))
		  :key #'first))))


;;; Make-Next-Ref-Linkage  --  Internal
;;;
;;;    Use the operand lifetime annotations to set up the next-ref slots in all
;;; the TN-Refs used in the VOP.  We set the Refs in the VOP to point to the
;;; head of this list.  More operands make life a bit interesting, since they
;;; introduce uncertainty as to whether we have seen any operands yet, and also
;;; must be linked together contiguously with the other TN-Refs.
;;;
(defun make-next-ref-linkage (parse n-vop)
  (declare (type vop-parse parse))
  (collect ((forms)
	    (binds))
    (let ((first-seen :no)
	  (prev nil))
      (dolist (x (compute-reference-order parse))
	(let* ((var (first x))
	       (more-p (second x))
	       (n-tail (if more-p (gensym) var)))
	  (ecase first-seen
	    (:no
	     (forms `(setf (vop-refs ,n-vop) ,n-tail)))
	    (:yes
	     (forms `(setf (tn-ref-next-ref ,prev) ,n-tail)))
	    (:maybe
	     (forms `(if ,prev
			 (setf (tn-ref-next-ref ,prev) ,n-tail)
			 (setf (vop-refs ,n-vop) ,n-tail)))))
	  
	  (unless (eq first-seen :yes)
	    (setq first-seen (if more-p :maybe :yes)))
	  
	  (if more-p
	      (let ((n-current (gensym))
		    (n-prev (gensym))
		    (n-head (gensym)))
		(binds `(,n-head (or ,var ,prev)))
		(binds
		 `(,n-tail
		   (do ((,n-current ,var (tn-ref-across ,n-current))
			(,n-prev nil ,n-current))
		       ((null ,n-current) ,n-prev)
		     (setf (tn-ref-next-ref ,n-current) ,n-prev))))
		(setq prev n-head))
	      (setq prev var)))))
    
    `((let* ,(binds)
	,@(forms)))))


;;; Make-Temporary  --  Internal
;;;
;;;    Return a form that creates a TN as specified by Temp.  This requires
ram's avatar
ram committed
;;; deciding whether the temp is wired or restricted.
wlott's avatar
wlott committed
;;;
(defun make-temporary (temp)
  (declare (type operand-parse temp))
ram's avatar
ram committed
  (let ((sc (operand-parse-sc temp))
	(offset (operand-parse-offset temp)))
    (assert sc)
    (if offset
	`(make-wired-tn nil ,(meta-sc-number-or-lose sc) ,offset)
	`(make-restricted-tn nil ,(meta-sc-number-or-lose sc)))))
wlott's avatar
wlott committed

  
;;; Allocate-Temporaries  --  Internal
;;;
;;;    Allocate VOP temporary TNs, making TN-Refs for their start and end, and
;;; setting up various per-ref information.  N-Vop is the temporary holding the
;;; VOP we are emitting.  We return a list of let* binding forms that create
;;; the TN-Refs, a list of forms that initialize the TN-Refs.
;;;
(defun allocate-temporaries (parse n-vop)
  (declare (type vop-parse parse))
  (collect ((binds)
	    (forms))
    (let ((prev-write nil))
      (dolist (temp (vop-parse-temps parse))
	(let ((n-write (operand-parse-temp temp))
	      (n-read (operand-parse-temp-temp temp))
	      (n-tn (gensym)))
	  (binds `(,n-tn ,(make-temporary temp)))
	  (binds `(,n-write (reference-tn ,n-tn t)))
	  (binds `(,n-read (reference-tn ,n-tn nil)))
	  (if prev-write
	      (forms `(setf (tn-ref-across ,prev-write) ,n-write))
	      (forms `(setf (vop-temps ,n-vop) ,n-write)))
	  (setq prev-write n-write)
	  (forms `(setf (tn-ref-vop ,n-read) ,n-vop))
	  (forms `(setf (tn-ref-vop ,n-write) ,n-vop)))))

    (values (binds) (forms))))


;;; Set-VOP-Pointers  --  Internal
;;;
;;;    Return code to set the TN-Ref-Vop slots in some operands to the value of
;;; N-Vop.  If there is no more operand, set the set the slots individually,
;;; otherwise loop over the whole list N-Refs.
;;;
(defun set-vop-pointers (operands more-operand n-vop n-refs)
  (if more-operand
      `((do ((,n-refs ,n-refs (tn-ref-across ,n-refs)))
	    ((null ,n-refs))
	  (setf (tn-ref-vop ,n-refs) ,n-vop)))
      (mapcar #'(lambda (op)
		  `(setf (tn-ref-vop ,(operand-parse-temp op)) ,n-vop))
	      operands)))


;;; Make-Emit-Function  --  Internal
;;;
;;;    Make the Template Emit-Function for a VOP.
;;;
(defun make-emit-function (parse)
  (declare (type vop-parse parse))
  (let ((n-node (gensym)) (n-block (gensym))
	(n-template (gensym)) (n-args (gensym))
	(n-results (gensym)) (n-info (gensym))
	(n-vop (gensym))
	(info-args (vop-parse-info-args parse)))
    (multiple-value-bind (temp-binds temp-forms)
			 (allocate-temporaries parse n-vop)
      `#'(lambda (,n-node ,n-block ,n-template ,n-args ,n-results
			  ,@(when info-args `(,n-info)))
	   (let ((,n-vop (make-vop ,n-block ,n-node ,n-template
				   ,n-args ,n-results)))

	     ,@(when info-args
		 `((setf (vop-codegen-info ,n-vop) ,n-info)))
	     
	     (let* (,@(access-operands (vop-parse-args parse)
				       (vop-parse-more-args parse)
				       n-args)
		    ,@(access-operands (vop-parse-results parse)
				       (vop-parse-more-results parse)
				       n-results)
		    ,@temp-binds)
	       ,@temp-forms
	       ,@(set-vop-pointers (vop-parse-args parse)
				   (vop-parse-more-args parse)
				   n-vop n-args)
	       ,@(set-vop-pointers (vop-parse-results parse)
				   (vop-parse-more-results parse)
				   n-vop n-results)
	       ,@(make-next-ref-linkage parse n-vop))
	     (values ,n-vop ,n-vop))))))


;;; Make-Target-Function  --  Internal
;;;
;;;    Make lambda that does operand targeting as indicated by the
;;; Operand-Parse-Target slots.  We do some meta-compile-time consistency
;;; checking, and the emit a call to Target-If-Desirable for each operand
;;; with a target specified.
;;;
;;;    If we are targeting from a temporary, then we indirect through the TN to
;;; find the read ref.  This exploits the fact that a temp has exactly one
;;; read.
;;;