diff --git a/compiler/debug.lisp b/compiler/debug.lisp index 1184730fbeff53f5e820c47b8da1cd83fd610830..bfdafe881a3a63cf44a83e54a55b875d6ed1bd0d 100644 --- a/compiler/debug.lisp +++ b/compiler/debug.lisp @@ -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) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index c89546305c4f8d5340dbb404c7a076b40879a041..e6a8466beaf391591a0d1f1735a2af388e9d3ccd 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -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.) ;;; diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index 7ca13127ed4c6030a5762c9ad5f0849a307b2d8b..35f2fe47f1e4ea217d7fd99fe038a5ef229a422e 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -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 ;;; diff --git a/compiler/meta-vmdef.lisp b/compiler/meta-vmdef.lisp index 16f887537e5919f82ea7d27e094fe2a82482cb49..6054a8fa88e3bd1e3c0f5fcb7052d5a9cc62071e 100644 --- a/compiler/meta-vmdef.lisp +++ b/compiler/meta-vmdef.lisp @@ -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))) diff --git a/compiler/pack.lisp b/compiler/pack.lisp index 0fd0935e2b0380c013a56c104d18fada5d90b3bf..7f993a62e211be4741b42c64d473f220807638a3 100644 --- a/compiler/pack.lisp +++ b/compiler/pack.lisp @@ -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))