;;; walk.
(declaim (ftype (function (node) (values)) check-node-reached))
(defun check-node-reached (node)
- (unless (gethash (continuation-block (node-prev node)) *seen-blocks*)
+ (unless (gethash (ctran-block (node-prev node)) *seen-blocks*)
(barf "~S was not reached." node))
(values))
(let* ((fun (block-home-lambda block))
(fun-deleted (eq (functional-kind fun) :deleted))
- (this-cont (block-start block))
+ (this-ctran (block-start block))
(last (block-last block)))
(unless fun-deleted
(check-fun-reached fun block))
- (when (not this-cont)
+ (when (not this-ctran)
(barf "~S has no START." block))
(when (not last)
(barf "~S has no LAST." block))
- (unless (eq (continuation-kind this-cont) :block-start)
+ (unless (eq (ctran-kind this-ctran) :block-start)
(barf "The START of ~S has the wrong kind." block))
- (let ((use (continuation-use this-cont))
- (uses (block-start-uses block)))
- (when (and (null use) (= (length uses) 1))
- (barf "~S has a unique use, but no USE." this-cont))
- (dolist (node uses)
- (unless (eq (node-cont node) this-cont)
- (barf "The USE ~S for START in ~S has wrong CONT." node block))
- (check-node-reached node)))
-
- (let* ((last-cont (node-cont last))
- (cont-block (continuation-block last-cont))
- (dest (continuation-dest last-cont)))
- (ecase (continuation-kind last-cont)
- (:deleted)
- (:deleted-block-start
- (let ((dest (continuation-dest last-cont)))
- (when dest
- (check-node-reached dest)))
- (unless (member last (block-start-uses cont-block))
- (barf "LAST in ~S is missing from uses of its Cont." block)))
- (:block-start
- (check-node-reached (continuation-next last-cont))
- (unless (member last (block-start-uses cont-block))
- (barf "LAST in ~S is missing from uses of its Cont." block)))
- (:inside-block
- (unless (eq cont-block block)
- (barf "CONT of LAST in ~S is in a different BLOCK." block))
- (unless (eq (continuation-use last-cont) last)
- (barf "USE is not LAST in CONT of LAST in ~S." block))
- (when (continuation-next last-cont)
- (barf "CONT of LAST has a NEXT in ~S." block))))
-
- (when dest
- (check-node-reached dest)))
+ (when (ctran-use this-ctran)
+ (barf "The ctran ~S is used." this-ctran))
- (loop
- (unless (eq (continuation-block this-cont) block)
- (barf "BLOCK in ~S should be ~S." this-cont block))
+ (when (node-next last)
+ (barf "Last node ~S of ~S has next ctran." last block))
- (let ((dest (continuation-dest this-cont)))
- (when dest
- (check-node-reached dest)))
+ (loop
+ (unless (eq (ctran-block this-ctran) block)
+ (barf "BLOCK of ~S should be ~S." this-ctran block))
- (let ((node (continuation-next this-cont)))
+ (let ((node (ctran-next this-ctran)))
(unless (node-p node)
- (barf "~S has strange NEXT." this-cont))
- (unless (eq (node-prev node) this-cont)
- (barf "PREV in ~S should be ~S." node this-cont))
-
+ (barf "~S has strange NEXT." this-ctran))
+ (unless (eq (node-prev node) this-ctran)
+ (barf "PREV in ~S should be ~S." node this-ctran))
+
+ (when (valued-node-p node)
+ (binding* ((lvar (node-lvar node) :exit-if-null))
+ (unless (memq node (find-uses lvar))
+ (barf "~S is not used by its LVAR ~S." node lvar))
+ (when (singleton-p (lvar-uses lvar))
+ (barf "~S has exactly 1 use, but LVAR-USES is a list."
+ lvar))
+ (unless (lvar-dest lvar)
+ (barf "~S does not have dest." lvar))))
+
+ (check-node-reached node)
(unless fun-deleted
(check-node-consistency node))
- (let ((cont (node-cont node)))
- (when (not cont)
- (barf "~S has no CONT." node))
+ (let ((next (node-next node)))
+ (when (and (not next) (not (eq node last)))
+ (barf "~S has no NEXT." node))
(when (eq node last) (return))
- (unless (eq (continuation-kind cont) :inside-block)
- (barf "The interior continuation ~S in ~S has the wrong kind."
- cont
+ (unless (eq (ctran-kind next) :inside-block)
+ (barf "The interior ctran ~S in ~S has the wrong kind."
+ next
block))
- (unless (continuation-next cont)
- (barf "~S has no NEXT." cont))
- (unless (eq (continuation-use cont) node)
- (barf "USE in ~S should be ~S." cont node))
- (setq this-cont cont))))
+ (unless (ctran-next next)
+ (barf "~S has no NEXT." next))
+ (unless (eq (ctran-use next) node)
+ (barf "USE in ~S should be ~S." next node))
+ (setq this-ctran next))))
(check-block-successors block))
(values))
\f
;;;; node consistency checking
-;;; Check that the DEST for CONT is the specified NODE. We also mark
-;;; the block CONT is in as SEEN.
-(declaim (ftype (function (continuation node) (values)) check-dest))
-(defun check-dest (cont node)
- (let ((kind (continuation-kind cont)))
- (ecase kind
- (:deleted
- (unless (block-delete-p (node-block node))
- (barf "DEST ~S of deleted continuation ~S is not DELETE-P."
- cont node)))
- (:deleted-block-start
- (unless (eq (continuation-dest cont) node)
- (barf "DEST for ~S should be ~S." cont node)))
- ((:inside-block :block-start)
- (unless (gethash (continuation-block cont) *seen-blocks*)
- (barf "~S receives ~S, which is in an unknown block." node cont))
- (unless (eq (continuation-dest cont) node)
- (barf "DEST for ~S should be ~S." cont node)))))
+;;; Check that the DEST for LVAR is the specified NODE. We also mark
+;;; the block LVAR is in as SEEN.
+#+nil(declaim (ftype (function (lvar node) (values)) check-dest))
+(defun check-dest (lvar node)
+ (do-uses (use lvar)
+ (unless (gethash (node-block use) *seen-blocks*)
+ (barf "Node ~S using ~S is in an unknown block." use lvar)))
+ (unless (eq (lvar-dest lvar) node)
+ (barf "DEST for ~S should be ~S." lvar node))
+ (unless (find-uses lvar)
+ (barf "Lvar ~S has a destinatin, but no uses."
+ lvar))
(values))
;;; This function deals with checking for consistency of the
(check-dest (basic-combination-fun node) node)
(dolist (arg (basic-combination-args node))
(cond
- (arg (check-dest arg node))
- ((not (and (eq (basic-combination-kind node) :local)
- (combination-p node)))
- (barf "flushed arg not in local call: ~S" node))
- (t
- (locally
- ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
- ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
- ;; POSITION. It compiles it correctly, but it issues a type
- ;; mismatch warning because it can't eliminate the
- ;; possibility that control will flow through the
- ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
- (declare (notinline position))
- (let ((fun (ref-leaf (continuation-use
- (basic-combination-fun node))))
- (pos (position arg (basic-combination-args node))))
- (declare (type index pos))
- (when (leaf-refs (elt (lambda-vars fun) pos))
- (barf "flushed arg for referenced var in ~S" node)))))))
- (let ((dest (continuation-dest (node-cont node))))
+ (arg (check-dest arg node))
+ ((not (and (eq (basic-combination-kind node) :local)
+ (combination-p node)))
+ (barf "flushed arg not in local call: ~S" node))
+ (t
+ (locally
+ ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
+ ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
+ ;; POSITION. It compiles it correctly, but it issues a type
+ ;; mismatch warning because it can't eliminate the
+ ;; possibility that control will flow through the
+ ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
+ (declare (notinline position))
+ (let ((fun (ref-leaf (lvar-use
+ (basic-combination-fun node))))
+ (pos (position arg (basic-combination-args node))))
+ (declare (type index pos))
+ (when (leaf-refs (elt (lambda-vars fun) pos))
+ (barf "flushed arg for referenced var in ~S" node)))))))
+ (let* ((lvar (node-lvar node))
+ (dest (and lvar (lvar-dest lvar))))
(when (and (return-p dest)
(eq (basic-combination-kind node) :local)
(not (eq (lambda-tail-set (combination-lambda node))
(barf "IF not at block end: ~S" node)))
(cset
(check-dest (set-value node) node))
+ (cast
+ (check-dest (cast-value node) node))
(bind
(check-fun-reached (bind-lambda node) node))
(creturn
;;; keep garbage from being collected.
(macrolet ((def (counter vto vfrom fto ffrom)
`(progn
+ (declaim (type hash-table ,vto ,vfrom))
(defvar ,vto (make-hash-table :test 'eq))
(defvar ,vfrom (make-hash-table :test 'eql))
- (proclaim '(hash-table ,vto ,vfrom))
+ (declaim (type fixnum ,counter))
(defvar ,counter 0)
- (proclaim '(fixnum ,counter))
(defun ,fto (x)
(or (gethash x ,vto)
(format stream "~S ~S" (type-of leaf) (functional-debug-name leaf)))))
;;; Attempt to find a block given some thing that has to do with it.
-(declaim (ftype (function (t) cblock) block-or-lose))
+(declaim (ftype (sfunction (t) cblock) block-or-lose))
(defun block-or-lose (thing)
(ctypecase thing
(cblock thing)
(ir2-block (ir2-block-block thing))
(vop (block-or-lose (vop-block thing)))
(tn-ref (block-or-lose (tn-ref-vop thing)))
- (continuation (continuation-block thing))
+ (ctran (ctran-block thing))
(node (node-block thing))
(component (component-head thing))
#| (cloop (loop-head thing))|#
- (integer (continuation-block (num-cont thing)))
+ (integer (ctran-block (num-cont thing)))
(functional (lambda-block (main-entry thing)))
(null (error "Bad thing: ~S." thing))
(symbol (block-or-lose (gethash thing *free-funs*)))))
(format t " c~D" (cont-num cont))
(values))
+(defun print-ctran (cont)
+ (declare (type ctran cont))
+ (format t "c~D " (cont-num cont))
+ (values))
+(defun print-lvar (cont)
+ (declare (type lvar cont))
+ (format t "v~D " (cont-num cont))
+ (values))
+
;;; Print out the nodes in BLOCK in a format oriented toward
;;; representing what the code does.
(defun print-nodes (block)
(setq block (block-or-lose block))
(pprint-logical-block (nil nil)
(format t "~:@_IR1 block ~D start c~D"
- (block-number block) (cont-num (block-start block)))
-
- (let ((last (block-last block)))
- (pprint-newline :mandatory)
- (do ((cont (block-start block) (node-cont (continuation-next cont))))
- ((not cont))
- (let ((node (continuation-next cont)))
- (format t "~3D: " (cont-num (node-cont node)))
- (etypecase node
- (ref (print-leaf (ref-leaf node)))
- (basic-combination
- (let ((kind (basic-combination-kind node)))
- (format t "~(~A ~A~) c~D"
- (if (fun-info-p kind) "known" kind)
- (type-of node)
- (cont-num (basic-combination-fun node)))
- (dolist (arg (basic-combination-args node))
- (if arg
- (print-continuation arg)
- (format t " <none>")))))
- (cset
- (write-string "set ")
- (print-leaf (set-var node))
- (print-continuation (set-value node)))
- (cif
- (format t "if c~D" (cont-num (if-test node)))
- (print-continuation (block-start (if-consequent node)))
- (print-continuation (block-start (if-alternative node))))
- (bind
- (write-string "bind ")
- (print-leaf (bind-lambda node)))
- (creturn
- (format t "return c~D " (cont-num (return-result node)))
- (print-leaf (return-lambda node)))
- (entry
- (format t "entry ~S" (entry-exits node)))
- (exit
- (let ((value (exit-value node)))
- (cond (value
- (format t "exit c~D" (cont-num value)))
- ((exit-entry node)
- (format t "exit <no value>"))
- (t
- (format t "exit <degenerate>"))))))
- (pprint-newline :mandatory)
- (when (eq node last) (return)))))
-
- (let ((succ (block-succ block)))
- (format t "successors~{ c~D~}~%"
- (mapcar (lambda (x) (cont-num (block-start x))) succ))))
+ (block-number block) (cont-num (block-start block)))
+ (when (block-delete-p block)
+ (format t " <deleted>"))
+
+ (pprint-newline :mandatory)
+ (do ((ctran (block-start block) (node-next (ctran-next ctran))))
+ ((not ctran))
+ (let ((node (ctran-next ctran)))
+ (format t "~:[ ~;~:*~3D:~] "
+ (when (and (valued-node-p node) (node-lvar node))
+ (cont-num (node-lvar node))))
+ (etypecase node
+ (ref (print-leaf (ref-leaf node)))
+ (basic-combination
+ (let ((kind (basic-combination-kind node)))
+ (format t "~(~A~A ~A~) "
+ (if (node-tail-p node) "tail " "")
+ (if (fun-info-p kind) "known" kind)
+ (type-of node))
+ (print-lvar (basic-combination-fun node))
+ (dolist (arg (basic-combination-args node))
+ (if arg
+ (print-lvar arg)
+ (format t "<none> ")))))
+ (cset
+ (write-string "set ")
+ (print-leaf (set-var node))
+ (write-char #\space)
+ (print-lvar (set-value node)))
+ (cif
+ (write-string "if ")
+ (print-lvar (if-test node))
+ (print-ctran (block-start (if-consequent node)))
+ (print-ctran (block-start (if-alternative node))))
+ (bind
+ (write-string "bind ")
+ (print-leaf (bind-lambda node))
+ (when (functional-kind (bind-lambda node))
+ (format t " ~S ~S" :kind (functional-kind (bind-lambda node)))))
+ (creturn
+ (write-string "return ")
+ (print-lvar (return-result node))
+ (print-leaf (return-lambda node)))
+ (entry
+ (format t "entry ~S" (entry-exits node)))
+ (exit
+ (let ((value (exit-value node)))
+ (cond (value
+ (format t "exit ")
+ (print-lvar value))
+ ((exit-entry node)
+ (format t "exit <no value>"))
+ (t
+ (format t "exit <degenerate>")))))
+ (cast
+ (let ((value (cast-value node)))
+ (format t "cast v~D ~A[~S -> ~S]" (cont-num value)
+ (if (cast-%type-check node) #\+ #\-)
+ (cast-type-to-check node)
+ (cast-asserted-type node)))))
+ (pprint-newline :mandatory)))
+
+ (let ((succ (block-succ block)))
+ (format t "successors~{ c~D~}~%"
+ (mapcar (lambda (x) (cont-num (block-start x))) succ))))
(values))
;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
(defvar *list-conflicts-table* (make-hash-table :test 'eq))
-;;; Add all ALWAYS-LIVE TNs in Block to the conflicts. TN is ignored when
-;;; it appears in the global conflicts.
+;;; Add all ALWAYS-LIVE TNs in BLOCK to the conflicts. TN is ignored
+;;; when it appears in the global conflicts.
(defun add-always-live-tns (block tn)
(declare (type ir2-block block) (type tn tn))
(do ((conf (ir2-block-global-tns block)
(setf (gethash btn *list-conflicts-table*) t)))))
(values))
-;;; Add all local TNs in block to the conflicts.
+;;; Add all local TNs in BLOCK to the conflicts.
(defun add-all-local-tns (block)
(declare (type ir2-block block))
(let ((ltns (ir2-block-local-tns block)))
(do ((conf confs (global-conflicts-next-tnwise conf)))
((null conf))
(format t "~&#<block ~D kind ~S>~%"
- (block-number (ir2-block-block (global-conflicts-block conf)))
+ (block-number (ir2-block-block (global-conflicts-block
+ conf)))
(global-conflicts-kind conf))
(let ((block (global-conflicts-block conf)))
(add-always-live-tns block tn)
projects / sbcl.git / blobdiff