Skip to content
Snippets Groups Projects
ir1util.lisp 55.3 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice 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 Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;;    This file contains random utilities used for manipulating the IR1
;;; representation.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)


;;;; Cleanup hackery:


;;; Node-Enclosing-Cleanup  --  Interface
wlott's avatar
wlott committed
;;;
;;;    Return the innermost cleanup enclosing Node, or NIL if there is none in
;;; its function.  If Node has no cleanup, but is in a let, then we must still
;;; check the environment that the call is in.
wlott's avatar
wlott committed
;;;
(defun node-enclosing-cleanup (node)
  (declare (type node node))
  (let ((env (node-lexenv node)))
    (or (lexenv-cleanup env)
	(let ((lambda (lexenv-lambda env)))
	  (and (member (functional-kind lambda) '(:mv-let :let))
	       (node-enclosing-cleanup (let-combination lambda)))))))
wlott's avatar
wlott committed


;;; Insert-Cleanup-Code  --  Interface
;;;
;;;    Convert the Form in a block inserted between Block1 and Block2 as an
;;; implicit MV-Prog1.  The inserted block is returned.  Node is used for IR1
;;; context when converting the form.  Note that the block is not assigned a
;;; number, and is linked into the DFO at the beginning.  We indicate that we
;;; have trashed the DFO by setting Component-Reanalyze.  If Cleanup is
;;; supplied, then convert with that cleanup.
wlott's avatar
wlott committed
;;;
(defun insert-cleanup-code (block1 block2 node form &optional cleanup)
  (declare (type cblock block1 block2) (type node node)
	   (type (or cleanup null) cleanup))
wlott's avatar
wlott committed
  (with-ir1-environment node
    (let* ((start (make-continuation))
	   (block (continuation-starts-block start))
	   (cont (make-continuation))
	   (*lexical-environment*
	   (if cleanup
	       (make-lexenv :cleanup cleanup)
	       *lexical-environment*)))
wlott's avatar
wlott committed
      (change-block-successor block1 block2 block)
      (link-blocks block block2)
      (ir1-convert start cont form)
      (setf (block-last block) (continuation-use cont))
      block)))
  

;;;; Continuation use hacking:

;;; Find-Uses  --  Interface
;;;
;;;    Return a list of all the nodes which use Cont.
;;;
(proclaim '(function find-uses (continuation) list))
(defun find-uses (cont)
  (ecase (continuation-kind cont)
    ((:block-start :deleted-block-start)
     (block-start-uses (continuation-block cont)))
    (:inside-block (list (continuation-use cont)))
    (:unused nil)))

      
;;; Delete-Continuation-Use  --  Interface
;;;
;;;    Update continuation use information so that Node is no longer a use of
;;; its Cont.  If the old continuation doesn't start its block, then we don't
;;; update the Block-Start-Uses, since it will be deleted when we are done.
;;;
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
;;; changed.
;;;
(proclaim '(function delete-continuation-use (node) void))
(defun delete-continuation-use (node)
  (let* ((cont (node-cont node))
	 (block (continuation-block cont)))
    (ecase (continuation-kind cont)
      (:deleted)
      ((:block-start :deleted-block-start)
       (let ((uses (delete node (block-start-uses block))))
	 (setf (block-start-uses block) uses)
	 (setf (continuation-use cont)
	       (if (cdr uses) nil (car uses)))))
      (:inside-block
       (setf (continuation-kind cont) :unused)
       (setf (continuation-block cont) nil)
       (setf (continuation-use cont) nil)
       (setf (continuation-next cont) nil)))
    (setf (node-cont node) nil)))


;;; Add-Continuation-Use  --  Interface
;;;
;;;    Update continuation use information so that Node uses Cont.  If Cont is
;;; :Unused, then we set its block to Node's Node-Block (which must be set.)
;;;
;;; Note: if you call this function, you may have to do a
;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something has
;;; changed.
;;;
(proclaim '(function add-continuation-use (node continuation) void))
(defun add-continuation-use (node cont)
  (assert (not (node-cont node)))
  (let ((block (continuation-block cont)))
    (ecase (continuation-kind cont)
      (:deleted)
      (:unused
       (assert (not block))
       (let ((block (node-block node)))
	 (assert block)
	 (setf (continuation-block cont) block))
       (setf (continuation-kind cont) :inside-block)
       (setf (continuation-use cont) node))
      ((:block-start :deleted-block-start)
       (let ((uses (cons node (block-start-uses block))))
	 (setf (block-start-uses block) uses)
	 (setf (continuation-use cont)
	       (if (cdr uses) nil (car uses)))))))
  (setf (node-cont node) cont))


;;; Immediately-Used-P  --  Interface
;;;
;;;    Return true if Cont is the Node-Cont for Node and Cont is transferred to
;;; immediately after the evaluation of Node.
;;;
(defun immediately-used-p (cont node)
  (declare (type continuation cont) (type node node))
  (and (eq (node-cont node) cont)
       (not (eq (continuation-kind cont) :deleted))
       (let ((cblock (continuation-block cont))
	     (nblock (node-block node)))
	 (or (eq cblock nblock)
	     (let ((succ (block-succ nblock)))
	       (and (= (length succ) 1)
		    (eq (first succ) cblock)))))))


;;;; Continuation substitution:

;;; Substitute-Continuation  --  Interface
;;;
;;;    In Old's Dest, replace Old with New.  New's Dest must initially be NIL.
;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note
;;; potential optimization opportunities.
;;;
(defun substitute-continuation (new old)
  (declare (type continuation old new))
  (assert (not (continuation-dest new)))
  (let ((dest (continuation-dest old)))
    (etypecase dest
      ((or ref bind))
      (cif (setf (if-test dest) new))
      (cset (setf (set-value dest) new))
      (creturn (setf (return-result dest) new))
      (exit (setf (exit-value dest) new))
      (basic-combination
       (if (eq old (basic-combination-fun dest))
	   (setf (basic-combination-fun dest) new)
	   (setf (basic-combination-args dest)
		 (nsubst new old (basic-combination-args dest))))))

    (flush-dest old)
    (setf (continuation-dest new) dest))
  (undefined-value))


;;; Ensure-Block-Start  --  Interface
;;;
;;;    Ensure that Cont is the start of a block (or deleted) so that the use
;;; set can be freely manipulated.
;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last
;;;    in its block, then we make it the start of a new deleted block.
;;; -- If the continuation is :Inside-Block inside a block, then we split the
;;;    block using Node-Ends-Block, which makes the continuation be a
;;;    :Block-Start.
;;;
(defun ensure-block-start (cont)
  (declare (type continuation cont))
  (let ((kind (continuation-kind cont)))
    (ecase kind
      ((:deleted :block-start :deleted-block-start))
      ((:unused :inside-block)
       (let ((block (continuation-block cont)))
	 (cond ((or (eq kind :unused)
wlott's avatar
wlott committed
		    (eq (node-cont (block-last block)) cont))
		(setf (continuation-block cont)
		      (make-block-key :start cont  :component nil))
wlott's avatar
wlott committed
		(setf (continuation-kind cont) :deleted-block-start))
	       (t
		(node-ends-block (continuation-use cont))))))))
  (undefined-value))


;;; Substitute-Continuation-Uses  --  Interface
;;;
;;;    Replace all uses of Old with uses of New, where New has an arbitary
;;; number of uses.  If New will end up with more than one use, then we must
;;; arrange for it to start a block if it doesn't already.
wlott's avatar
wlott committed
;;;
(defun substitute-continuation-uses (new old)
  (declare (type continuation old new))
  (unless (and (eq (continuation-kind new) :unused)
	       (eq (continuation-kind old) :inside-block))
    (ensure-block-start new))
  
  (do-uses (node old)
    (delete-continuation-use node)
    (add-continuation-use node new))

  (reoptimize-continuation new)
  (undefined-value))


;;;; Misc shortand functions:

;;; NODE-xxx  --  Interface
wlott's avatar
wlott committed
;;;
(proclaim '(inline node-block node-home-lambda node-environment
		   node-tlf-number))
wlott's avatar
wlott committed
(defun node-block (node)
  (declare (type node node))
  (the cblock (continuation-block (node-prev node))))
;;;
(defun node-home-lambda (node)
wlott's avatar
wlott committed
  (declare (type node node))
  (lambda-home (lexenv-lambda (node-lexenv node))))
ram's avatar
ram committed
;;;
(defun node-environment (node)
ram's avatar
ram committed
  (declare (type node node))
  (the environment (lambda-environment (lexenv-lambda (node-lexenv node)))))



;;; BLOCK-xxx-CLEANUP  --  Interface
;;;
;;;    Return the enclosing cleanup for environment of the first or last node
;;; in Block.
;;;
(defun block-start-cleanup (block)
  (declare (type cblock block))
  (node-enclosing-cleanup (continuation-next (block-start block))))
;;;
(defun block-end-cleanup (block)
  (declare (type cblock block))
  (node-enclosing-cleanup (block-last block)))


;;; BLOCK-HOME-LAMBDA  --  Interface
;;;
;;;    Return the non-let lambda that holds Block's code.
;;;
(defun block-home-lambda (block)
  (declare (type cblock block))
  (lambda-home (lexenv-lambda (node-lexenv (block-last block)))))


;;; BLOCK-ENVIRONMENT  --  Interface
;;;
;;;    Return the IR1 environment for Block.
;;;
(defun block-environment (block)
  (declare (type cblock block))
  (lambda-environment (lexenv-lambda (node-lexenv (block-last block)))))


;;; SOURCE-PATH-TLF-NUMBER  --  Interface
;;;
;;;    Return the Top Level Form number of path, i.e. the ordinal number of
;;; its orignal source's top-level form in its compilation unit.
;;;
(defun source-path-tlf-number (path)
  (declare (list path))
  (car (last path)))


;;; SOURCE-PATH-ORIGINAL-SOURCE  --  Interface
;;;
;;;    Return the (reversed) list for the path in the orignal source (with the
;;; TLF number last.)
;;; 
(defun source-path-original-source (path)
  (declare (list path))
  (cddr (member 'original-source-start path)))


;;; SOURCE-PATH-FORM-NUMBER  --  Interface
;;;
;;;    Return the Form Number of Path's orignal source inside the Top Level
;;; Form that contains it.  This is determined by the order that we walk the
;;; subforms of the top level source form.
;;;
(defun source-path-form-number (path)
  (declare (list path))
  (cadr (member 'original-source-start path)))


;;; SOURCE-PATH-FORMS  --  Interface
;;;
;;;    Return a list of all the enclosing forms not in the original source that
;;; converted to get to this form, with the immediate source for node at the
;;; start of the list.
;;;
(defun source-path-forms (path)
  (subseq path 0 (position 'original-source-start path)))
wlott's avatar
wlott committed


;;; MAKE-LEXENV  --  Interface
;;;
;;;    Return a new LEXENV just like Default except for the specified slot
;;; values.  Values for the alist slots are NCONC'ed to the beginning of the
;;; current value, rather than replacing it entirely.
;;; 
(defun make-lexenv (&key (default *lexical-environment*)
			 functions variables blocks tags type-restrictions
			 inlines
			 (lambda (lexenv-lambda default))
			 (cleanup (lexenv-cleanup default))
			 (cookie (lexenv-cookie default)))
  (macrolet ((frob (var slot)
	       `(let ((old (,slot default)))
		  (if ,var
		      (nconc ,var old)
		      old))))
    (internal-make-lexenv
     (frob functions lexenv-functions)
     (frob variables lexenv-variables)
     (frob blocks lexenv-blocks)
     (frob tags lexenv-tags)
     (frob type-restrictions lexenv-type-restrictions)
     (frob inlines lexenv-inlines)
     lambda cleanup cookie)))
#|
functions
variables
blocks
tags
type-restrictions
inlines
|#
			   
wlott's avatar
wlott committed

;;;; Flow/DFO/Component hackery:

;;; Link-Blocks, Unlink-Blocks  --  Interface
;;;
;;;    Join or separate Block1 and Block2.
;;;
(defun link-blocks (block1 block2)
  (declare (type cblock block1 block2))
wlott's avatar
wlott committed
  (assert (not (member block2 (block-succ block1))))
  (push block2 (block-succ block1))
  (push block1 (block-pred block2))
  (undefined-value))
wlott's avatar
wlott committed
;;;
(defun unlink-blocks (block1 block2)
  (declare (type cblock block1 block2))
wlott's avatar
wlott committed
  (assert (member block2 (block-succ block1)))
  (setf (block-succ block1)
	(delete block2 (block-succ block1)))
  (setf (block-pred block2)
	(delete block1 (block-pred block2)))
  (undefined-value))
wlott's avatar
wlott committed


;;; Change-Block-Successor  --  Internal
;;;
;;;    Swing the succ/pred link between Block and Old to be between Block and
;;; New.  If Block ends in an IF, then we have to fix up the
;;; consequent/alternative blocks to point to New.
;;;
(defun change-block-successor (block old new)
  (declare (type cblock new old block))
  (unlink-blocks block old)
  (unless (member new (block-succ block))
    (link-blocks block new))
  
  (let ((last (block-last block)))
    (when (if-p last)
      (macrolet ((frob (slot)
		   `(when (eq (,slot last) old)
		      (setf (,slot last) new))))
	(frob if-consequent)
	(frob if-alternative))))
  
  (undefined-value))


;;; Remove-From-DFO  --  Interface
;;;
;;;    Unlink a block from the next/prev chain.  We also null out the
;;; Component.
;;;
(proclaim '(function remove-from-dfo (cblock) void))
(defun remove-from-dfo (block)
  (let ((next (block-next block))
	(prev (block-prev block)))
    (setf (block-component block)
Loading
Loading full blame...