Commit 2a176aec authored by toy's avatar toy
Browse files

From Eric Marsden:

   - fixes to the internal consistency of IR2, ported from the
     corresponding changes to SBCL by Alexey Dejneka

   - modification of the internal IR1 consistency checking code to
     accept objects of type HEAP-ALIEN-INFO in the *FREE-VARIABLES*
     list.


  With this change, it is possible to rebuild with
  c::*check-consistency* enabled, with only the "Unseen function ~S in
  ~S." check disabled.
parent d3288e31
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.34 2002/08/27 22:18:26 moore Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/debug.lisp,v 1.35 2002/12/07 18:19:33 toy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -137,16 +137,26 @@
(maphash #'(lambda (k v)
(declare (ignore k))
(cond ((alien::heap-alien-info-p v)
;; objects of type HEAP-ALIEN-INFO may be
;; present in *FREE-VARIABLES* due to the way
;; that the alien machinery automatically
;; dereferences an alien variable's name to
;; its value. Just ignore them.
t)
((leaf-p v)
(unless (or (constant-p v)
(and (global-var-p v)
(member (global-var-kind v)
'(:global :special :constant))))
(barf "Strange *free-variables* entry: ~S." v))
(barf "Strange *FREE-VARIABLES* entry: ~S." v))
(dolist (n (leaf-refs v))
(check-node-reached n))
(when (basic-var-p v)
(dolist (n (basic-var-sets v))
(check-node-reached n))))
(t
(barf "Member of *FREE-VARIABLES* is of unexpected type: ~S" v))))
*free-variables*)
(maphash #'(lambda (k v)
......@@ -402,11 +412,11 @@
(when dest
(check-node-reached dest)))
(unless (member last (block-start-uses cont-block))
(barf "Last in ~S is missing from uses of it's 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 it's 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))
......@@ -499,8 +509,8 @@
;;; Check-Dest -- Internal
;;;
;;; Check that the Dest for Cont is the specified Node. We also mark the
;;; block Cont is in as Seen.
;;; Check that the Dest for CONT is the specified NODE. We also mark the
;;; block that CONT is in as having been Seen.
;;;
(defun check-dest (cont node)
(declare (type continuation cont) (type node node))
......@@ -520,6 +530,7 @@
(barf "DEST for ~S should be ~S." cont node))))))
;;; Check-Node-Consistency -- Internal
;;;
;;; This function deals with checking for consistency the type-dependent
......@@ -711,12 +722,12 @@
;;; Check-IR2-Consistency -- Interface
;;;
;;; Check stuff about the IR2 representation of Component. This assumes the
;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
;;; sanity of the basic flow graph.
;;;
;;; [### Also grovel global TN data structures? Assume pack not
;;; done yet? Have separate check-tn-consistency for pre-pack and
;;; check-pack-consistency for post-pack?]
;;; done yet? Have separate CHECK-TN-CONSISTENCY for pre-pack and
;;; CHECK-PACK-CONSISTENCY for post-pack?]
;;;
(defun check-ir2-consistency (component)
(declare (type component component))
......@@ -783,7 +794,7 @@
;;; Check-More-TN-Entry -- Internal
;;;
;;; If the entry in Local-TNs for TN in Block is :More, then do some checks
;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks
;;; for the validity of the usage.
;;;
(defun check-more-tn-entry (tn block)
......@@ -1115,7 +1126,7 @@
;;; Print-TN -- Internal
;;;
;;; Print a useful representation of a TN. If the TN has a leaf, then do a
;;; Print-Leaf on that, otherwise print a generated ID.
;;; PRINT-LEAF on that, otherwise print a generated ID.
;;;
(defun print-tn (tn &optional (stream *standard-output*))
(declare (type tn tn))
......@@ -1131,8 +1142,8 @@
;;; Print-Operands -- Internal
;;;
;;; Print the TN-Refs representing some operands to a VOP, linked by
;;; TN-Ref-Across.
;;; Print the TN-REFS representing some operands to a VOP, linked by
;;; TN-REF-ACROSS.
;;;
(defun print-operands (refs)
(declare (type (or tn-ref null) refs))
......@@ -1153,7 +1164,7 @@
;;; Print-Vop -- internal
;;;
;;; Print the vop, putting args, info and results on separate lines, if
;;; Print the VOP, putting args, info and results on separate lines, if
;;; necessary.
;;;
(defun print-vop (vop)
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.132 2002/11/25 22:07:14 toy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.133 2002/12/07 18:19:33 toy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -71,9 +71,6 @@
(defvar *constants*)
(declaim (hash-table *constants*))
;;; When compiling Dylan, we don't coalesce constants, because the dylan
;;; test suite implies that doing so is a bozo-no-no.
;;;
(defvar *coalesce-constants*)
(declaim (type (member t nil) *coalesce-constants*))
......@@ -1784,8 +1781,9 @@
(default (arg-info-default info))
(hairy-default (not (constantp default)))
(supplied-p (arg-info-supplied-p info))
(n-val (make-symbol (format nil "~A-DEFAULTING-TEMP"
(leaf-name key))))
(n-val (with-standard-io-syntax
(make-symbol (format nil "~A-DEFAULTING-TEMP"
(leaf-name key)))))
(key-type (leaf-type key))
(val-temp (make-lambda-var
:name n-val
......@@ -3570,8 +3568,8 @@
;;; Also, emit top-level code to install the definition.
;;;
;;; This is one of the major places where the semantics of block compilation is
;;; handled. Substituion for global names is totally inhibited if
;;; *block-compile* it NIL. And if *block-compile* us true and entry points
;;; handled. Substitution for global names is totally inhibited if
;;; *block-compile* is NIL. And if *block-compile* is true and entry points
;;; are specified, then we don't install global definitions for non-entry
;;; functions (effectively turning them into local lexical functions.)
;;;
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.70 2002/11/21 21:51:24 toy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.71 2002/12/07 18:19:34 toy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -91,7 +91,7 @@ compilation policy")
;;; Find-In-Environment -- Internal
;;;
;;; Return the TN that holds the value of Thing in the environment Env.
;;; Return the TN that holds the value of THING in the environment ENV.
;;;
(defun find-in-environment (thing env)
(declare (type (or nlx-info lambda-var) thing) (type environment env)
......@@ -103,8 +103,8 @@ compilation policy")
(leaf-info thing))
(nlx-info
(assert (eq env (block-environment (nlx-info-target thing))))
(ir2-nlx-info-home (nlx-info-info thing))))))
(ir2-nlx-info-home (nlx-info-info thing))))
(error "~@<~2I~_~S ~_not found in ~_~S~:>" thing env)))
;;; Constant-TN -- Internal
;;;
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/meta-vmdef.lisp,v 1.7 1994/10/31 04:27:28 ram Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/meta-vmdef.lisp,v 1.8 2002/12/07 18:19:34 toy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -564,9 +564,9 @@
;;; Find-Operand -- Internal
;;;
;;; Find the operand or temporary with the specifed Name in the VOP Parse.
;;; 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
;;; kind isn't one of the specified KINDS. If ERROR-P is NIL, just return NIL
;;; if there is no such operand.
;;;
(defun find-operand (name parse &optional
......@@ -715,6 +715,7 @@
(operand-parse-name op)))
(let ((target (find-operand (operand-parse-target op) parse
'(:temporary :result))))
;; keep this magic consistent with %EMIT-GENERIC-VOP
(targets (+ (* index max-vop-tn-refs)
(ecase (operand-parse-kind target)
(:result
......@@ -722,6 +723,7 @@
num-args))
(:temporary
(+ (* (eposition target (vop-parse-temps parse)) 2)
1
num-args num-results)))))))
(let ((born (operand-parse-born op))
(dies (operand-parse-dies op)))
......
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.57 2002/07/10 16:14:46 toy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/pack.lisp,v 1.58 2002/12/07 18:19:34 toy Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -1342,12 +1342,14 @@
;;; Target-If-Desirable -- Internal
;;;
;;; Link the TN-Refs Read and Write together using the TN-Ref-Target when
;;; Link the TN-Refs READ and WRITE together using the TN-Ref-Target when
;;; this seems like a good idea. Currently we always do, as this increases the
;;; sucess of load-TN targeting.
;;;
(defun target-if-desirable (read write)
(declare (type tn-ref read write))
(assert (eq (tn-ref-write-p read)
(not (tn-ref-write-p write))))
(setf (tn-ref-target read) write)
(setf (tn-ref-target write) read))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment