From: William Harold Newman Date: Wed, 11 Jul 2001 00:03:02 +0000 (+0000) Subject: 0.6.12.45: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6879a37a9e6cceeab810636c5ef4a4da1444e275;p=sbcl.git 0.6.12.45: (This version/commit actually includes some stuff from the Dave MacDonald patch logged in the 0.6.12.44 message, since CVS got stuck somehow and didn't finish that commit.) (and also left a stale lock in place for days..) some *EVAL-STACK* fixes.. ..removed CURRENT-STACK-POINTER macro, since (1) its name is confusing (suggesting the system stack, not the eval stack; especially since the CURRENT-STACK-POINTER vop *does* refer to the system stack!) and (2) abstracting away the fact that this is a special variable is, given the INTERPRETER-GC-HOOK hack to scrub the eval stack, an unfortunate invitation to subtle GC bugs ..renamed STACK-COPY to EVAL-STACK-COPY ..made *EVAL-STACK-TRACE* stuff dependent on #!+SB-SHOW ..renamed EVAL-STACK-SET-TOP to EVAL-STACK-RESET-TOP I also made *INTERNAL-APPLY-NODE-TRACE* stuff dependent on #!+SB-SHOW, even though in retrospect that was probably silly, since it's only in IR1 interpreter code, which I hope to blow away next month anyway. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 3c73fa6..81881c8 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -479,7 +479,8 @@ like *STACK-TOP-HINT*" :name "SB!EVAL" :doc "private: the implementation of the IR1 interpreter" :use ("CL" "SB!KERNEL" "SB!INT") - :export ("*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*" + :export (#!+sb-show "*EVAL-STACK-TRACE*" + #!+sb-show "*INTERNAL-APPLY-NODE-TRACE*" "FLUSH-INTERPRETED-FUNCTION-CACHE" "INTERNAL-EVAL" "INTERPRETED-FUNCTION" "INTERPRETED-FUNCTION-ARGLIST" @@ -489,8 +490,7 @@ like *STACK-TOP-HINT*" "INTERPRETED-FUNCTION-P" "INTERPRETED-FUNCTION-TYPE" "MAKE-INTERPRETED-FUNCTION" - "PRINT-INTERPRETED-FUNCTION-OBJECT" - "TRACE-EVAL")) + "PRINT-INTERPRETED-FUNCTION-OBJECT")) #s(sb-cold:package-data :name "SB!EXT" diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index cb73c3c..cda6006 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -64,8 +64,6 @@ ;;; the index of the next free element of the interpreter's evaluation stack (defvar *eval-stack-top* 0) -(defmacro current-stack-pointer () '*eval-stack-top*) - #!-sb-fluid (declaim (inline eval-stack-ref)) (defun eval-stack-ref (offset) (declare (type stack-pointer offset)) @@ -78,24 +76,24 @@ (defun push-eval-stack (value) (let ((len (length (the simple-vector sb!eval::*eval-stack*))) - (sp (current-stack-pointer))) + (sp *eval-stack-top*)) (when (= len sp) (let ((new-stack (make-array (ash len 1)))) (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len) (setf sb!eval::*eval-stack* new-stack))) - (setf (current-stack-pointer) (1+ sp)) + (setf *eval-stack-top* (1+ sp)) (setf (eval-stack-ref sp) value))) (defun allocate-eval-stack (amount) (let* ((len (length (the simple-vector sb!eval::*eval-stack*))) - (sp (current-stack-pointer)) + (sp *eval-stack-top*) (new-sp (+ sp amount))) (declare (type index sp new-sp)) (when (>= new-sp len) (let ((new-stack (make-array (ash new-sp 1)))) (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len) (setf sb!eval::*eval-stack* new-stack))) - (setf (current-stack-pointer) new-sp) + (setf *eval-stack-top* new-sp) (let ((stack sb!eval::*eval-stack*)) (do ((i sp (1+ i))) ; FIXME: DOTIMES? or just :INITIAL-ELEMENT in MAKE-ARRAY? ((= i new-sp)) @@ -103,9 +101,9 @@ (values)) (defun pop-eval-stack () - (let* ((new-sp (1- (current-stack-pointer))) + (let* ((new-sp (1- *eval-stack-top*)) (value (eval-stack-ref new-sp))) - (setf (current-stack-pointer) new-sp) + (setf *eval-stack-top* new-sp) value)) (defmacro multiple-value-pop-eval-stack ((&rest vars) &body body) @@ -118,17 +116,17 @@ (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare)) (return)) (push (pop body) decls)) - `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars))) + `(let ((,new-sp-var (- *eval-stack-top* ,num-vars))) (declare (type stack-pointer ,new-sp-var)) (let ,(mapcar #'(lambda (var) `(,var (eval-stack-ref (+ ,new-sp-var ,(incf index))))) vars) ,@(nreverse decls) - (setf (current-stack-pointer) ,new-sp-var) + (setf *eval-stack-top* ,new-sp-var) ,@body)))) -(defun stack-copy (dest src count) +(defun eval-stack-copy (dest src count) (declare (type stack-pointer dest src count)) (let ((stack *eval-stack*)) (if (< dest src) @@ -244,7 +242,7 @@ sb!vm:code-trace-table-offset-slot)) (setf (funcallable-instance-function xep) #'(instance-lambda (&more context count) - (let ((old-sp (current-stack-pointer))) + (let ((old-sp *eval-stack-top*)) (declare (type stack-pointer old-sp)) (dotimes (i count) (push-eval-stack (%more-arg context i))) @@ -257,7 +255,7 @@ (let ((res (make-byte-closure xep closure-vars))) (setf (funcallable-instance-function res) #'(instance-lambda (&more context count) - (let ((old-sp (current-stack-pointer))) + (let ((old-sp *eval-stack-top*)) (declare (type stack-pointer old-sp)) (dotimes (i count) (push-eval-stack (%more-arg context i))) @@ -483,7 +481,7 @@ (ignore old-pc) (type pc pc) (type stack-pointer fp)) - (let ((value (eval-stack-ref (1- (current-stack-pointer))))) + (let ((value (eval-stack-ref (1- *eval-stack-top*)))) (push-eval-stack value)) (byte-interpret component pc fp)) @@ -521,13 +519,13 @@ (declare (type index src)) (multiple-value-bind (values-above dst) (grovel (1- remaining-blocks) (1- src)) - (stack-copy dst src block-count) + (eval-stack-copy dst src block-count) (values (+ values-above block-count) (+ dst block-count)))))))) (multiple-value-bind (total-count end-ptr) - (grovel (pop-eval-stack) (1- (current-stack-pointer))) + (grovel (pop-eval-stack) (1- *eval-stack-top*)) (setf (eval-stack-ref end-ptr) total-count) - (setf (current-stack-pointer) (1+ end-ptr)))) + (setf *eval-stack-top* (1+ end-ptr)))) (byte-interpret component pc fp)) (define-xop default-unknown-values (component old-pc pc fp) @@ -541,7 +539,7 @@ (declare (type index desired supplied) (type fixnum delta)) (cond ((minusp delta) - (incf (current-stack-pointer) delta)) + (incf *eval-stack-top* delta)) ((plusp delta) (dotimes (i delta) (push-eval-stack nil))))) @@ -766,7 +764,7 @@ (type pc old-pc pc) (type stack-pointer fp)) (with-extended-operand (component pc operand new-pc) - (let ((value (eval-stack-ref (1- (current-stack-pointer)))) + (let ((value (eval-stack-ref (1- *eval-stack-top*))) (type (code-header-ref component (+ operand sb!vm:code-constants-offset)))) (unless (if (functionp type) @@ -781,7 +779,7 @@ (byte-interpret component new-pc fp))) -;;;; the byte-interpreter +;;;; the actual byte-interpreter ;;; The various operations are encoded as follows. ;;; @@ -838,8 +836,8 @@ (let ((*byte-trace* nil)) (format *trace-output* "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%" - pc fp (current-stack-pointer) byte - (subseq sb!eval::*eval-stack* fp (current-stack-pointer)))))) + pc fp *eval-stack-top* byte + (subseq sb!eval::*eval-stack* fp *eval-stack-top*))))) (if (zerop (logand byte #x80)) ;; Some stack operation. No matter what, we need the operand, ;; so compute it. @@ -871,8 +869,8 @@ (if (zerop operand) (let ((operand (pop-eval-stack))) (declare (type index operand)) - (decf (current-stack-pointer) operand)) - (decf (current-stack-pointer) operand))))) + (decf *eval-stack-top* operand)) + (decf *eval-stack-top* operand))))) (byte-interpret component new-pc fp)) (if (zerop (logand byte #x40)) ;; Some kind of call. @@ -961,7 +959,7 @@ (type (integer 0 #.call-arguments-limit) num-args)) (invoke-local-entry-point component (component-ref-24 component (1+ pc)) component old-pc - (- (current-stack-pointer) num-args) + (- *eval-stack-top* num-args) old-fp)) (defun do-tail-local-call (component pc fp num-args) @@ -972,9 +970,9 @@ (old-sp (eval-stack-ref (- fp 2))) (old-pc (eval-stack-ref (- fp 3))) (old-component (eval-stack-ref (- fp 4))) - (start-of-args (- (current-stack-pointer) num-args))) - (stack-copy old-sp start-of-args num-args) - (setf (current-stack-pointer) (+ old-sp num-args)) + (start-of-args (- *eval-stack-top* num-args))) + (eval-stack-copy old-sp start-of-args num-args) + (setf *eval-stack-top* (+ old-sp num-args)) (invoke-local-entry-point component (component-ref-24 component (1+ pc)) old-component old-pc old-sp old-fp))) @@ -999,15 +997,15 @@ (values (component-ref-24 component (1+ target)) (+ target 4)) (values (* byte 2) (1+ target)))) (declare (type pc entry-pc)) - (let ((fp (current-stack-pointer))) + (let ((fp *eval-stack-top*)) (allocate-eval-stack stack-frame-size) (byte-interpret component entry-pc fp)))) ;;; Call a function with some arguments popped off of the interpreter -;;; stack, and restore the SP to the specifier value. +;;; stack, and restore the SP to the specified value. (defun byte-apply (function num-args restore-sp) (declare (type function function) (type index num-args)) - (let ((start (- (current-stack-pointer) num-args))) + (let ((start (- *eval-stack-top* num-args))) (declare (type stack-pointer start)) (macrolet ((frob () `(case num-args @@ -1021,7 +1019,7 @@ ((< i start)) (declare (fixnum i)) (push (eval-stack-ref i) args)) - (setf (current-stack-pointer) restore-sp) + (setf *eval-stack-top* restore-sp) (apply function args))))) (call-1 (n) (collect ((binds) @@ -1031,7 +1029,7 @@ (binds `(,dum (eval-stack-ref (+ start ,i)))) (args dum))) `(let ,(binds) - (setf (current-stack-pointer) restore-sp) + (setf *eval-stack-top* restore-sp) (funcall function ,@(args)))))) (frob)))) @@ -1042,7 +1040,7 @@ (type stack-pointer old-fp) (type (integer 0 #.call-arguments-limit) num-args) (type (member t nil) named)) - (let* ((old-sp (- (current-stack-pointer) num-args 1)) + (let* ((old-sp (- *eval-stack-top* num-args 1)) (fun-or-fdefn (eval-stack-ref old-sp)) (function (if named (or (fdefn-function fun-or-fdefn) @@ -1085,7 +1083,7 @@ (type stack-pointer fp) (type (integer 0 #.call-arguments-limit) num-args) (type (member t nil) named)) - (let* ((start-of-args (- (current-stack-pointer) num-args)) + (let* ((start-of-args (- *eval-stack-top* num-args)) (fun-or-fdefn (eval-stack-ref (1- start-of-args))) (function (if named (or (fdefn-function fun-or-fdefn) @@ -1103,12 +1101,12 @@ (type function function)) (typecase function (byte-function - (stack-copy old-sp start-of-args num-args) - (setf (current-stack-pointer) (+ old-sp num-args)) + (eval-stack-copy old-sp start-of-args num-args) + (setf *eval-stack-top* (+ old-sp num-args)) (invoke-xep old-component old-pc old-sp old-fp num-args function)) (byte-closure - (stack-copy old-sp start-of-args num-args) - (setf (current-stack-pointer) (+ old-sp num-args)) + (eval-stack-copy old-sp start-of-args num-args) + (setf *eval-stack-top* (+ old-sp num-args)) (invoke-xep old-component old-pc old-sp old-fp num-args (byte-closure-function function) (byte-closure-data function))) @@ -1154,7 +1152,7 @@ (*byte-trace* nil) (*print-level* sb!debug:*debug-print-level*) (*print-length* sb!debug:*debug-print-length*) - (sp (current-stack-pointer))) + (sp *eval-stack-top*)) (format *trace-output* "~&INVOKE-XEP: ocode= ~S[~D]~% ~ osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~ @@ -1184,7 +1182,7 @@ (error "too many arguments"))) (t (let* ((more-args-supplied (- num-args max)) - (sp (current-stack-pointer)) + (sp *eval-stack-top*) (more-args-start (- sp more-args-supplied)) (restp (hairy-byte-function-rest-arg-p xep)) (rest (and restp @@ -1199,7 +1197,7 @@ (cond ((not (hairy-byte-function-keywords-p xep)) (aver restp) - (setf (current-stack-pointer) (1+ more-args-start)) + (setf *eval-stack-top* (1+ more-args-start)) (setf (eval-stack-ref more-args-start) rest)) (t (unless (evenp more-args-supplied) @@ -1210,7 +1208,7 @@ ;; more args currently are. There might be more or ;; fewer. And also, we need to flatten the parsed ;; args with the defaults before we scan the - ;; keywords. So we copy all the more args to a + ;; keywords. So we copy all the &MORE args to a ;; temporary area at the end of the stack. (let* ((num-more-args (hairy-byte-function-num-more-args xep)) @@ -1221,7 +1219,7 @@ (declare (type index temp) (type stack-pointer new-sp temp-sp)) (allocate-eval-stack (- temp-sp sp)) - (stack-copy temp more-args-start more-args-supplied) + (eval-stack-copy temp more-args-start more-args-supplied) (when restp (setf (eval-stack-ref more-args-start) rest) (incf more-args-start)) @@ -1264,7 +1262,7 @@ (when (and bogus-key-p (not allow)) (with-debugger-info (old-component ret-pc old-fp) (error "unknown keyword: ~S" bogus-key)))) - (setf (current-stack-pointer) new-sp))))) + (setf *eval-stack-top* new-sp))))) (hairy-byte-function-more-args-entry-point xep)))))))) (declare (type pc entry-point)) (invoke-local-entry-point (byte-function-component xep) entry-point @@ -1283,17 +1281,17 @@ (let ((old-sp (eval-stack-ref (- fp 2)))) (case num-results (0 - (setf (current-stack-pointer) old-sp) + (setf *eval-stack-top* old-sp) (values)) (1 (let ((result (pop-eval-stack))) - (setf (current-stack-pointer) old-sp) + (setf *eval-stack-top* old-sp) result)) (t (let ((results nil)) (dotimes (i num-results) (push (pop-eval-stack) results)) - (setf (current-stack-pointer) old-sp) + (setf *eval-stack-top* old-sp) (values-list results)))))) (t ;; ### function end breakpoint? @@ -1309,16 +1307,17 @@ ;; wants single value (let ((result (if (zerop num-results) nil - (eval-stack-ref (- (current-stack-pointer) + (eval-stack-ref (- *eval-stack-top* num-results))))) - (setf (current-stack-pointer) old-sp) + (setf *eval-stack-top* old-sp) (push-eval-stack result) (byte-interpret old-component old-pc old-fp)) ;; wants multiple values (progn - (stack-copy old-sp (- (current-stack-pointer) num-results) - num-results) - (setf (current-stack-pointer) (+ old-sp num-results)) + (eval-stack-copy old-sp + (- *eval-stack-top* num-results) + num-results) + (setf *eval-stack-top* (+ old-sp num-results)) (push-eval-stack num-results) (byte-interpret old-component (- old-pc) old-fp))))) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 8949bd5..79e70df 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -156,13 +156,13 @@ and submit it as a patch." (declaim (type index *gc-run-time*)) ;;; a limit to help catch programs which allocate too much memory, -;;; since a hard heap overflow is so hard to recover from. +;;; since a hard heap overflow is so hard to recover from (declaim (type (or unsigned-byte null) *soft-heap-limit*)) (defvar *soft-heap-limit* nil) -;;; Internal trigger. When the dynamic usage increases beyond this -;;; amount, the system notes that a garbage collection needs to occur by -;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning +;;; When the dynamic usage increases beyond this amount, the system +;;; notes that a garbage collection needs to occur by setting +;;; *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning ;;; nobody has figured out what it should be yet. (defvar *gc-trigger* nil) @@ -253,7 +253,7 @@ has finished GC'ing.") ;;; is not greater than *GC-TRIGGER*. ;;; ;;; For GENCGC all generations < GEN will be GC'ed. -(defun sub-gc (&key force-p (gen 0)) +(defun sub-gc (&key force-p (gen 0)) (/show0 "entering SUB-GC") (unless *already-maybe-gcing* (let* ((*already-maybe-gcing* t) @@ -376,14 +376,13 @@ has finished GC'ing.") object) ;;; This is the user-advertised garbage collection function. - (defun gc (&key (gen 0) (full nil) &allow-other-keys) #!+(and sb-doc gencgc) "Initiate a garbage collection. GEN controls the number of generations to garbage collect." #!+(and sb-doc (not gencgc)) - "Initiate a garbage collection. GEN may be provided for compatibility, but - is ignored." + "Initiate a garbage collection. GEN may be provided for compatibility with + generational garbage collectors, but is ignored in this implementation." (sub-gc :force-p t :gen (if full 6 gen))) diff --git a/src/code/target-eval.lisp b/src/code/target-eval.lisp index b9409d1..775f6bb 100644 --- a/src/code/target-eval.lisp +++ b/src/code/target-eval.lisp @@ -51,16 +51,17 @@ ;;;; One of the steps in building a nice debuggable macro is changing ;;;; its MACRO-FUNCTION to print as e.g. ;;;; # -;;;; instead of some -;;;; weird internal representation showing the environment argument and stuff. -;;;; This function is called in order to try to make that happen. +;;;; instead of some weird internal representation showing the +;;;; environment argument and stuff. This function is called in order +;;;; to try to make that happen. ;;;; -;;;; When we're running in the target SBCL, we own the INTERPRETED-FUNCTION -;;;; definition, and we can do this; that's what the definition below does. -;;;; When we're a Python cross-compiler running in some arbitrary ANSI Common -;;;; Lisp, we can't do this (and we don't care that much about making nice -;;;; debuggable macros anyway). In that environment, a stub no-op version of -;;;; this function is used. +;;;; When we're running in the target SBCL, we own the +;;;; INTERPRETED-FUNCTION definition, and we can do this; that's what +;;;; the definition below does. When we're a Python cross-compiler +;;;; running in some arbitrary ANSI Common Lisp, we can't do this (and +;;;; we don't care that much about making nice debuggable macros +;;;; anyway). In that environment, a stub no-op version of this +;;;; function is used. (defun try-to-rename-interpreted-function-as-macro (f name lambda-list) (aver (sb!eval:interpreted-function-p f)) (setf (sb!eval:interpreted-function-name f) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 434fefe..3c954eb 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -198,7 +198,7 @@ (values)) ;;; Return a vector and an integer (or null) suitable for use as the -;;; BLOCKS and TLF-NUMBER in Fun's debug-function. This requires two +;;; BLOCKS and TLF-NUMBER in FUN's debug-function. This requires two ;;; passes to compute: ;;; -- Scan all blocks, dumping the header and successors followed ;;; by all the non-elsewhere locations. @@ -244,59 +244,58 @@ ;;; we need them or not. (defun debug-source-for-info (info) (declare (type source-info info)) - (aver (not (source-info-current-file info))) - (mapcar #'(lambda (x) - (let ((res (make-debug-source - :from :file - :created (file-info-write-date x) - :compiled (source-info-start-time info) - :source-root (file-info-source-root x) - :start-positions - (unless (eq *byte-compile* t) - (coerce-to-smallest-eltype - (file-info-positions x))))) - (name (file-info-name x))) - (etypecase name - ((member :lisp) - (setf (debug-source-from res) name) - (setf (debug-source-name res) - (coerce (file-info-forms x) 'simple-vector))) - (pathname - (let* ((untruename (file-info-untruename x)) - (dir (pathname-directory untruename))) - (setf (debug-source-name res) - (namestring - (if (and dir (eq (first dir) :absolute)) - untruename - name)))))) - res)) - (source-info-files info))) + (let* ((file-info (source-info-file-info info)) + (res (make-debug-source + :from :file + :created (file-info-write-date file-info) + :compiled (source-info-start-time info) + :source-root (file-info-source-root file-info) + :start-positions + (unless (eq *byte-compile* t) + (coerce-to-smallest-eltype + (file-info-positions file-info))))) + (name (file-info-name file-info))) + (etypecase name + ((member :lisp) + (setf (debug-source-from res) name) + (setf (debug-source-name res) + (coerce (file-info-forms file-info) 'simple-vector))) + (pathname + (let* ((untruename (file-info-untruename file-info)) + (dir (pathname-directory untruename))) + (setf (debug-source-name res) + (namestring + (if (and dir (eq (first dir) :absolute)) + untruename + name)))))) + (list res))) + ;;; Given an arbitrary sequence, coerce it to an unsigned vector if ;;; possible. Ordinarily we coerce it to the smallest specialized ;;; vector we can. However, we also have a special hack for ;;; cross-compiling at bootstrap time, when arbitrarily-specialized -;;; aren't fully supported: in that case, we coerce it only to a -;;; vector whose element size is an integer multiple of output byte +;;; vectors aren't fully supported: in that case, we coerce it only to +;;; a vector whose element size is an integer multiple of output byte ;;; size. (defun coerce-to-smallest-eltype (seq) (let ((maxoid #-sb-xc-host 0 - ;; An initial value value of 255 prevents us from + ;; An initial value of 255 prevents us from ;; specializing the array to anything smaller than ;; (UNSIGNED-BYTE 8), which keeps the cross-compiler's ;; portable specialized array output functions happy. #+sb-xc-host 255)) (flet ((frob (x) (if (typep x 'unsigned-byte) - (when (>= x maxoid) - (setf maxoid x)) - (return-from coerce-to-smallest-eltype - (coerce seq 'simple-vector))))) + (when (>= x maxoid) + (setf maxoid x)) + (return-from coerce-to-smallest-eltype + (coerce seq 'simple-vector))))) (if (listp seq) - (dolist (i seq) - (frob i)) - (dovector (i seq) - (frob i))) + (dolist (i seq) + (frob i)) + (dovector (i seq) + (frob i))) (coerce seq `(simple-array (integer 0 ,maxoid) (*)))))) ;;;; variables diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp index 4927d57..e2a9709 100644 --- a/src/compiler/eval.lisp +++ b/src/compiler/eval.lisp @@ -34,75 +34,81 @@ (declaim (type list *interpreted-function-cache*)) ;;; Setting this causes the stack operations to dump a trace. -;;; -;;; FIXME: perhaps should be #!+SB-SHOW +#+!sb-show (defvar *eval-stack-trace* nil) -;;; Push value on *eval-stack*, growing the stack if necessary. This returns -;;; value. We save *eval-stack-top* in a local and increment the global before -;;; storing value on the stack to prevent a GC timing problem. If we stored -;;; value on the stack using *eval-stack-top* as an index, and we GC'ed before -;;; incrementing *eval-stack-top*, then INTERPRETER-GC-HOOK would clear the +;;; Push value on *EVAL-STACK*, growing the stack if necessary. This +;;; returns value. We save *EVAL-STACK-TOP* in a local and increment +;;; the global before storing value on the stack to prevent a GC +;;; timing problem. If we stored value on the stack using +;;; *EVAL-STACK-TOP* as an index, and we GC'ed before incrementing +;;; *EVAL-STACK-TOP*, then INTERPRETER-GC-HOOK would clear the ;;; location. (defun eval-stack-push (value) (let ((len (length (the simple-vector *eval-stack*)))) (when (= len *eval-stack-top*) - (when *eval-stack-trace* (format t "[PUSH: growing stack.]~%")) + #+!sb-show (when *eval-stack-trace* + (format t "[PUSH: growing stack.]~%")) (let ((new-stack (make-array (ash len 1)))) (replace new-stack *eval-stack* :end1 len :end2 len) (setf *eval-stack* new-stack)))) (let ((top *eval-stack-top*)) - (when *eval-stack-trace* (format t "pushing ~D.~%" top)) + #+!sb-show (when *eval-stack-trace* (format t "pushing ~D.~%" top)) (incf *eval-stack-top*) (setf (svref *eval-stack* top) value))) -;;; This returns the last value pushed on *eval-stack* and decrements the top -;;; pointer. We forego setting elements off the end of the stack to nil for GC -;;; purposes because there is a *before-gc-hook* to take care of this for us. -;;; However, because of the GC hook, we must be careful to grab the value -;;; before decrementing *eval-stack-top* since we could GC between the -;;; decrement and the reference, and the hook would clear the stack slot. +;;; Return the last value pushed on *EVAL-STACK* and decrement the top +;;; pointer. We forego setting elements off the end of the stack to +;;; nil for GC purposes because there is a *BEFORE-GC-HOOK* to take +;;; care of this for us. However, because of the GC hook, we must be +;;; careful to grab the value before decrementing *EVAL-STACK-TOP* +;;; since we could GC between the decrement and the reference, and the +;;; hook would clear the stack slot. (defun eval-stack-pop () (when (zerop *eval-stack-top*) (error "attempt to pop empty eval stack")) (let* ((new-top (1- *eval-stack-top*)) (value (svref *eval-stack* new-top))) - (when *eval-stack-trace* (format t "popping ~D --> ~S.~%" new-top value)) + #+!sb-show (when *eval-stack-trace* + (format t "popping ~D --> ~S.~%" new-top value)) (setf *eval-stack-top* new-top) value)) -;;; This allocates n locations on the stack, bumping the top pointer and -;;; growing the stack if necessary. We set new slots to nil in case we GC -;;; before having set them; we don't want to hold on to potential garbage -;;; from old stack fluctuations. +;;; Allocate N locations on the stack, bumping the top pointer and +;;; growing the stack if necessary. We set new slots to nil in case we +;;; GC before having set them; we don't want to hold on to potential +;;; garbage from old stack fluctuations. (defun eval-stack-extend (n) (let ((len (length (the simple-vector *eval-stack*)))) (when (> (+ n *eval-stack-top*) len) - (when *eval-stack-trace* (format t "[EXTEND: growing stack.]~%")) + #+!sb-show (when *eval-stack-trace* + (format t "[EXTEND: growing stack.]~%")) (let ((new-stack (make-array (+ n (ash len 1))))) (replace new-stack *eval-stack* :end1 len :end2 len) (setf *eval-stack* new-stack)))) (let ((new-top (+ *eval-stack-top* n))) - (when *eval-stack-trace* (format t "extending to ~D.~%" new-top)) + #+!sb-show (when *eval-stack-trace* + (format t "extending to ~D.~%" new-top)) (do ((i *eval-stack-top* (1+ i))) ((= i new-top)) (setf (svref *eval-stack* i) nil)) (setf *eval-stack-top* new-top))) -;;; The anthesis of EVAL-STACK-EXTEND. +;;; the antithesis of EVAL-STACK-EXTEND (defun eval-stack-shrink (n) - (when *eval-stack-trace* - (format t "shrinking to ~D.~%" (- *eval-stack-top* n))) + #+!sb-show (when *eval-stack-trace* + (format t "shrinking to ~D.~%" (- *eval-stack-top* n))) (decf *eval-stack-top* n)) ;;; This is used to shrink the stack back to a previous frame pointer. -(defun eval-stack-set-top (ptr) - (when *eval-stack-trace* (format t "setting top to ~D.~%" ptr)) +(defun eval-stack-reset-top (ptr) + #+!sb-show (when *eval-stack-trace* + (format t "setting top to ~D.~%" ptr)) (setf *eval-stack-top* ptr)) -;;; This returns a local variable from the current stack frame. This is used -;;; for references the compiler represents as a lambda-var leaf. This is a -;;; macro for SETF purposes. +;;; Return a local variable from the current stack frame. This is used +;;; for references the compiler represents as a lambda-var leaf. It is +;;; a macro as a quick and dirty way of making it SETFable. ;;; ;;; FIXME: used only in this file, needn't be in runtime (defmacro eval-stack-local (fp offset) @@ -110,12 +116,12 @@ ;;;; interpreted functions -;;; The list of INTERPRETED-FUNCTIONS that have translated definitions. +;;; the list of INTERPRETED-FUNCTIONS that have translated definitions (defvar *interpreted-function-cache* nil) (declaim (type list *interpreted-function-cache*)) -;;; Return a function that will lazily convert Lambda when called, and will -;;; cache translations. +;;; Return a function that will lazily convert LAMBDA when called, and +;;; will cache translations. (defun make-interpreted-function (lambda) (let ((res (%make-interpreted-function :lambda lambda :arglist (second lambda)))) @@ -308,7 +314,7 @@ (compute-closure node ,lambda frame-ptr closure))) ;; No need to clean up stack slots for GC due to ;; SB!EXT:*BEFORE-GC-HOOK*. - (eval-stack-set-top frame-ptr) + (eval-stack-reset-top frame-ptr) (return-from internal-apply-loop (internal-apply ,lambda ,args ,calling-closure @@ -350,7 +356,8 @@ ;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP. We use it ;;; here, and INTERNAL-INVOKE uses it to print function call looking output ;;; to further describe sb!c::combination nodes. -(defvar *internal-apply-node-trace* nil) +#!+sb-show (defvar *internal-apply-node-trace* nil) +#!+sb-show (defun maybe-trace-funny-fun (node name &rest args) (when *internal-apply-node-trace* (format t "(~S ~{ ~S~}) c~S~%" @@ -378,7 +385,7 @@ (sb!c::%special-bind (let ((value (eval-stack-pop)) (global-var (eval-stack-pop))) - (maybe-trace-funny-fun node ,name global-var value) + #!+sb-show (maybe-trace-funny-fun node ,name global-var value) (sb!sys:%primitive sb!c:bind value (sb!c::global-var-name global-var)))) @@ -386,7 +393,7 @@ ;; Throw away arg telling me which special, and tell the dynamic ;; binding mechanism to unbind one variable. (eval-stack-pop) - (maybe-trace-funny-fun node ,name) + #!+sb-show (maybe-trace-funny-fun node ,name) (sb!sys:%primitive sb!c:unbind)) (sb!c::%catch (let* ((tag (eval-stack-pop)) @@ -399,7 +406,7 @@ (values (multiple-value-list (catch tag - (maybe-trace-funny-fun node ,name tag) + #!+sb-show (maybe-trace-funny-fun node ,name tag) (multiple-value-setq (block node cont last-cont) (internal-apply-loop (sb!c::continuation-next cont) frame-ptr lambda args closure)) @@ -414,7 +421,7 @@ (t ;; Fix up the interpreter's stack after having thrown here. ;; We won't need to do this in the final implementation. - (eval-stack-set-top stack-top) + (eval-stack-reset-top stack-top) ;; Take the values received in the list bound above, and ;; massage them into the form expected by the continuation ;; of the non-local-exit info. @@ -443,7 +450,7 @@ (stack-top *eval-stack-top*)) (unwind-protect (progn - (maybe-trace-funny-fun node ,name) + #!+sb-show (maybe-trace-funny-fun node ,name) (multiple-value-setq (block node cont last-cont) (internal-apply-loop (sb!c::continuation-next cont) frame-ptr lambda args closure)) @@ -459,7 +466,7 @@ ;; Fix up the interpreter's stack after having thrown ;; here. We won't need to do this in the final ;; implementation. - (eval-stack-set-top stack-top) + (eval-stack-reset-top stack-top) ;; Push some bogus values for exit context to keep the ;; MV-BIND in the UNWIND-PROTECT translation happy. (eval-stack-push '(nil nil 0)) @@ -476,11 +483,11 @@ ;; Return the current state of evaluation to the previous invocation ;; of INTERNAL-APPLY-LOOP which happens to be running in the ;; SB!C::%CATCH branch of this code. - (maybe-trace-funny-fun node ,name) + #!+sb-show (maybe-trace-funny-fun node ,name) (return-from internal-apply-loop (values block node cont last-cont))) (sb!c::%nlx-entry - (maybe-trace-funny-fun node ,name) + #!+sb-show (maybe-trace-funny-fun node ,name) ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and ;; non-local lexical exits (GO or RETURN-FROM). ;; Do nothing since sb!c::%catch does it all when it catches a THROW. @@ -495,7 +502,7 @@ ;; consistency checking. SB!C::%MORE-ARG-CONTEXT always runs ;; within an XEP, so the lambda has an extra arg. (more-args (nthcdr fixed-arg-count args))) - (maybe-trace-funny-fun node ,name fixed-arg-count) + #!+sb-show (maybe-trace-funny-fun node ,name fixed-arg-count) (aver (eq (sb!c::continuation-info cont) :multiple)) (eval-stack-push (list more-args (length more-args))))) (sb!c::%unknown-values @@ -506,8 +513,8 @@ ;; have non-locally lexically exited. Return the :fell-through flag ;; and the current state of evaluation to the previous invocation ;; of INTERNAL-APPLY-LOOP which happens to be running in the - ;; sb!c::entry branch of INTERNAL-APPLY-LOOP. - (maybe-trace-funny-fun node ,name) + ;; SB!C::ENTRY branch of INTERNAL-APPLY-LOOP. + #!+sb-show (maybe-trace-funny-fun node ,name) ;; Discard the NLX-INFO arg... (eval-stack-pop) (return-from internal-apply-loop @@ -565,10 +572,6 @@ (t (aver (typep ,kind 'sb!c::function-info)) (do-combination :full nil ,type)))))) - -(defun trace-eval (on) - (setf *eval-stack-trace* on) - (setf *internal-apply-node-trace* on)) ;;;; INTERNAL-EVAL @@ -594,32 +597,34 @@ ;;; FIXME: maybe used only in this file, if so, needn't be in runtime (defmacro value (node info value frame-ptr function) `(cond ((sb!c::node-tail-p ,node) - (eval-stack-set-top ,frame-ptr) + (eval-stack-reset-top ,frame-ptr) (return-from ,function ,value)) ((member ,info '(:multiple :return) :test #'eq) (eval-stack-push (list ,value))) (t (aver (eq ,info :single)) (eval-stack-push ,value)))) +#!+sb-show (defun maybe-trace-nodes (node) (when *internal-apply-node-trace* (format t "<~A-node> c~S~%" (type-of node) (sb!c::cont-num (sb!c::node-cont node))))) -;;; This interprets lambda, a compiler IR1 data structure representing a -;;; function, applying it to args. Closure is the environment in which to run -;;; lambda, the variables and such closed over to form lambda. The call occurs -;;; on the interpreter's stack, so save the current top and extend the stack -;;; for this lambda's call frame. Then store the args into locals on the -;;; stack. +;;; Interpret LAMBDA, a compiler IR1 data structure representing a +;;; function, applying it to ARGS. CLOSURE is the environment in which +;;; to run LAMBDA, the variables and such closed over to form LAMBDA. +;;; The call occurs on the interpreter's stack, so save the current +;;; top and extend the stack for this lambda's call frame. Then store +;;; the args into locals on the stack. ;;; -;;; Args is the list of arguments to apply to. If IGNORE-UNUSED is true, then -;;; values for un-read variables are present in the argument list, and must be -;;; discarded (always true except in a local call.) Args may run out of values -;;; before vars runs out of variables (in the case of an XEP with optionals); -;;; we just do CAR of nil and store nil. This is not the proper defaulting -;;; (which is done by explicit code in the XEP.) +;;; ARGS is the list of arguments to apply to. If IGNORE-UNUSED is +;;; true, then values for un-read variables are present in the +;;; argument list, and must be discarded (always true except in a +;;; local call.) ARGS may run out of values before VARS runs out of +;;; variables (in the case of an XEP with optionals); we just do CAR +;;; of NIL and store NIL. This is not the proper defaulting (which is +;;; done by explicit code in the XEP.) (defun internal-apply (lambda args closure &optional (ignore-unused t)) (let ((frame-ptr *eval-stack-top*)) (eval-stack-extend (sb!c:lambda-eval-info-frame-size (sb!c::lambda-info lambda))) @@ -674,41 +679,42 @@ (let ((cont (sb!c::node-cont node))) (etypecase node (sb!c::ref - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) (let ((info (sb!c::continuation-info cont))) (unless (eq info :unused) (value node info (leaf-value node frame-ptr closure) frame-ptr internal-apply-loop)))) (sb!c::combination - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) (combination-node :normal)) (sb!c::cif - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) ;; IF nodes always occur at the end of a block, so pick another. (set-block (if (eval-stack-pop) (sb!c::if-consequent node) (sb!c::if-alternative node)))) (sb!c::bind - (maybe-trace-nodes node) - ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for - ;; all of a lambda's locals, and the sb!c::combination branch - ;; handles LET binds (moving values off stack top into locals). + #!+sb-show (maybe-trace-nodes node) + ;; Ignore bind nodes since INTERNAL-APPLY extends the + ;; stack for all of a lambda's locals, and the + ;; SB!C::COMBINATION branch handles LET binds (moving + ;; values off stack top into locals). ) (sb!c::cset - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) (let ((info (sb!c::continuation-info cont)) (res (set-leaf-value node frame-ptr closure (eval-stack-pop)))) (unless (eq info :unused) (value node info res frame-ptr internal-apply-loop)))) (sb!c::entry - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) (let ((info (cdr (assoc node (sb!c:lambda-eval-info-entries (sb!c::lambda-info lambda)))))) ;; No info means no-op entry for CATCH or UNWIND-PROTECT. (when info - ;; Store stack top for restoration in local exit situation - ;; in sb!c::exit branch. + ;; Store stack top for restoration in local exit + ;; situation in SB!C::EXIT branch. (setf (eval-stack-local frame-ptr (sb!c:entry-node-info-st-top info)) *eval-stack-top*) @@ -750,7 +756,7 @@ (sb!c::block-start (car (sb!c::block-succ block)))))))))))) (sb!c::exit - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) (let* ((incoming-values (sb!c::exit-value node)) (values (if incoming-values (eval-stack-pop)))) (cond @@ -759,7 +765,7 @@ (sb!c::node-block (sb!c::exit-entry node)))) ;; Local exit. ;; Fixup stack top and massage values for destination. - (eval-stack-set-top + (eval-stack-reset-top (eval-stack-local frame-ptr (sb!c:entry-node-info-st-top (cdr (assoc (sb!c::exit-entry node) @@ -786,12 +792,12 @@ (values values (sb!c::nlx-info-target info) nil cont) (values :non-local-go (sb!c::nlx-info-target info))))))))) (sb!c::creturn - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) (let ((values (eval-stack-pop))) - (eval-stack-set-top frame-ptr) + (eval-stack-reset-top frame-ptr) (return-from internal-apply-loop (values-list values)))) (sb!c::mv-combination - (maybe-trace-nodes node) + #!+sb-show (maybe-trace-nodes node) (combination-node :mv-call))) ;; See function doc below. (reference-this-var-to-keep-it-alive node) @@ -1020,20 +1026,20 @@ (defun internal-invoke (arg-count &optional tailp) (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first. (fun (eval-stack-pop))) - (when tailp (eval-stack-set-top tailp)) - (when *internal-apply-node-trace* - (format t "(~S~{ ~S~})~%" fun args)) + (when tailp (eval-stack-reset-top tailp)) + #!+sb-show (when *internal-apply-node-trace* + (format t "(~S~{ ~S~})~%" fun args)) (apply fun args))) ;;; This is almost just like INTERNAL-INVOKE. We call ;;; MV-EVAL-STACK-ARGS, and our function is in a list on the stack ;;; instead of simply on the stack. (defun mv-internal-invoke (arg-count &optional tailp) - (let ((args (mv-eval-stack-args arg-count)) ;LET runs this init form first. + (let ((args (mv-eval-stack-args arg-count)) ; LET runs this init form first. (fun (car (eval-stack-pop)))) - (when tailp (eval-stack-set-top tailp)) - (when *internal-apply-node-trace* - (format t "(~S~{ ~S~})~%" fun args)) + (when tailp (eval-stack-reset-top tailp)) + #!+sb-show (when *internal-apply-node-trace* + (format t "(~S~{ ~S~})~%" fun args)) (apply fun args))) ;;; Return a list of the top arg-count elements on the interpreter's diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index cdf1a25..8c63c71 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -382,7 +382,7 @@ ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to -;;; find the paths in, and TLF-Num is the top-level form number of the +;;; find the paths in, and TLF-NUM is the top-level form number of the ;;; truly top-level form. ;;; ;;; This gets a bit interesting when the source code is circular. This diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 4b3aaf3..18220b1 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1457,13 +1457,13 @@ (incf n))) (let* ((tlf (source-path-tlf-number path)) - (file (find-file-info tlf *source-info*))) + (file-info (source-info-file-info *source-info*))) (make-compiler-error-context :enclosing-source (short) :source (full) :original-source (stringify-form form) :context src-context - :file-name (file-info-name file) + :file-name (file-info-name file-info) :file-position (multiple-value-bind (ignore pos) (find-source-root tlf *source-info*) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 6fe6325..8591b38 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -165,7 +165,18 @@ ) ; EVAL-WHEN -;;; Parse the specification and generate some accessor macros. +;;; Define a new class of boolean attributes, with the attributes +;;; having the specified Attribute-Names. Name is the name of the +;;; class, which is used to generate some macros to manipulate sets of +;;; the attributes: +;;; +;;; NAME-attributep attributes attribute-name* +;;; Return true if one of the named attributes is present, false +;;; otherwise. When set with SETF, updates the place Attributes +;;; setting or clearing the specified attributes. +;;; +;;; NAME-attributes attribute-name* +;;; Return a set of the named attributes. ;;; ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..) @@ -178,19 +189,6 @@ ;;; do it now, because the system isn't running yet, so it'd be too ;;; hard to check that my changes were correct -- WHN 19990806 (def!macro def-boolean-attribute (name &rest attribute-names) - #!+sb-doc - "Def-Boolean-Attribute Name Attribute-Name* - Define a new class of boolean attributes, with the attributes having the - specified Attribute-Names. Name is the name of the class, which is used to - generate some macros to manipulate sets of the attributes: - - NAME-attributep attributes attribute-name* - Return true if one of the named attributes is present, false otherwise. - When set with SETF, updates the place Attributes setting or clearing the - specified attributes. - - NAME-attributes attribute-name* - Return a set of the named attributes." (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*")) (test-name (symbolicate name "-ATTRIBUTEP"))) @@ -246,24 +244,25 @@ ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806 ;;; And now for some gratuitous pseudo-abstraction... +;;; +;;; ATTRIBUTES-UNION +;;; Return the union of all the sets of boolean attributes which are its +;;; arguments. +;;; ATTRIBUTES-INTERSECTION +;;; Return the intersection of all the sets of boolean attributes which +;;; are its arguments. +;;; ATTRIBUTES= +;;; True if the attributes present in Attr1 are identical to +;;; those in Attr2. (defmacro attributes-union (&rest attributes) - #!+sb-doc - "Returns the union of all the sets of boolean attributes which are its - arguments." `(the attributes (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) (defmacro attributes-intersection (&rest attributes) - #!+sb-doc - "Returns the intersection of all the sets of boolean attributes which are its - arguments." `(the attributes (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) (declaim (ftype (function (attributes attributes) boolean) attributes=)) #!-sb-fluid (declaim (inline attributes=)) (defun attributes= (attr1 attr2) - #!+sb-doc - "Returns true if the attributes present in Attr1 are identical to those in - Attr2." (eql attr1 attr2)) ;;;; lambda-list parsing utilities @@ -581,7 +580,6 @@ ;;; ;;; If supplied, RESULT-FORM is the value to return. (defmacro do-blocks ((block-var component &optional ends result) &body body) - #!+sb-doc (unless (member ends '(nil :head :tail :both)) (error "losing ENDS value: ~S" ends)) (let ((n-component (gensym)) @@ -596,10 +594,8 @@ (block-next ,block-var))) ((eq ,block-var ,n-tail) ,result) ,@body)))) +;;; like Do-Blocks, only iterating over the blocks in reverse order (defmacro do-blocks-backwards ((block-var component &optional ends result) &body body) - #!+sb-doc - "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}* - Like Do-Blocks, only iterate over the blocks in reverse order." (unless (member ends '(nil :head :tail :both)) (error "losing ENDS value: ~S" ends)) (let ((n-component (gensym)) @@ -615,12 +611,11 @@ ((eq ,block-var ,n-head) ,result) ,@body)))) -;;; Could change it not to replicate the code someday perhaps... +;;; Iterate over the uses of CONTINUATION, binding NODE to each one +;;; successively. +;;; +;;; XXX Could change it not to replicate the code someday perhaps... (defmacro do-uses ((node-var continuation &optional result) &body body) - #!+sb-doc - "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}* - Iterate over the uses of Continuation, binding Node to each one - successively." (once-only ((n-cont continuation)) `(ecase (continuation-kind ,n-cont) (:unused) @@ -634,6 +629,11 @@ ,result) ,@body))))) +;;; Iterate over the nodes in Block, binding Node-Var to the each node +;;; and Cont-Var to the node's Cont. The only keyword option is +;;; Restart-P, which causes iteration to be restarted when a node is +;;; deleted out from under us. (If not supplied, this is an error.) +;;; ;;; In the forward case, we terminate on Last-Cont so that we don't ;;; have to worry about our termination condition being changed when ;;; new code is added during the iteration. In the backward case, we @@ -643,18 +643,12 @@ ;;; When RESTART-P is supplied to DO-NODES, we start iterating over ;;; again at the beginning of the block when we run into a ;;; continuation whose block differs from the one we are trying to -;;; iterate over, either beacuse the block was split, or because a +;;; iterate over, either because the block was split, or because a ;;; node was deleted out from under us (hence its block is NIL.) If ;;; the block start is deleted, we just punt. With RESTART-P, we are ;;; also more careful about termination, re-indirecting the BLOCK-LAST ;;; each time. (defmacro do-nodes ((node-var cont-var block &key restart-p) &body body) - #!+sb-doc - "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}* - Iterate over the nodes in Block, binding Node-Var to the each node and - Cont-Var to the node's Cont. The only keyword option is Restart-P, which - causes iteration to be restarted when a node is deleted out from under us (if - not supplied, this is an error.)" (let ((n-block (gensym)) (n-last-cont (gensym))) `(let* ((,n-block ,block) @@ -680,10 +674,8 @@ `(eq ,node-var (block-last ,n-block)) `(eq ,cont-var ,n-last-cont)) (return nil)))))) +;;; like Do-Nodes, only iterating in reverse order (defmacro do-nodes-backwards ((node-var cont-var block) &body body) - #!+sb-doc - "Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}* - Like Do-Nodes, only iterates in reverse order." (let ((n-block (gensym)) (n-start (gensym)) (n-last (gensym)) @@ -699,12 +691,11 @@ (when (eq ,n-next ,n-start) (return nil)))))) +;;; Bind the IR1 context variables so that IR1 conversion can be done +;;; after the main conversion pass has finished. +;;; ;;; The lexical environment is presumably already null... (defmacro with-ir1-environment (node &rest forms) - #!+sb-doc - "With-IR1-Environment Node Form* - Bind the IR1 context variables so that IR1 conversion can be done after the - main conversion pass has finished." (let ((n-node (gensym))) `(let* ((,n-node ,node) (*current-component* (block-component (node-block ,n-node))) @@ -724,12 +715,11 @@ (warning #'compiler-warning-handler)) ,@forms))) +;;; Look up NAME in the lexical environment namespace designated by +;;; SLOT, returning the , or if no entry. The +;;; :TEST keyword may be used to determine the name equality +;;; predicate. (defmacro lexenv-find (name slot &key test) - #!+sb-doc - "LEXENV-FIND Name Slot {Key Value}* - Look up Name in the lexical environment namespace designated by Slot, - returning the , or if no entry. The :TEST keyword - may be used to determine the name equality predicate." (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*) :test ,(or test '#'eq)))) `(if ,n-res @@ -772,18 +762,17 @@ ) ; EVAL-WHEN +;;; Return the number of times that EVENT has happened. (declaim (ftype (function (symbol) fixnum) event-count)) (defun event-count (name) - #!+sb-doc - "Return the number of times that Event has happened." (event-info-count (event-info-or-lose name))) +;;; Return the function that is called when Event happens. If this is +;;; null, there is no action. The function is passed the node to which +;;; the event happened, or NIL if there is no relevant node. This may +;;; be set with SETF. (declaim (ftype (function (symbol) (or function null)) event-action)) (defun event-action (name) - #!+sb-doc - "Return the function that is called when Event happens. If this is null, - there is no action. The function is passed the node to which the event - happened, or NIL if there is no relevant node. This may be set with SETF." (event-info-action (event-info-or-lose name))) (declaim (ftype (function (symbol (or function null)) (or function null)) %set-event-action)) @@ -792,12 +781,12 @@ new-value)) (defsetf event-action %set-event-action) +;;; Return the non-negative integer which represents the level of +;;; significance of the event Name. This is used to determine whether +;;; to print a message when the event happens. This may be set with +;;; SETF. (declaim (ftype (function (symbol) unsigned-byte) event-level)) (defun event-level (name) - #!+sb-doc - "Return the non-negative integer which represents the level of significance - of the event Name. This is used to determine whether to print a message when - the event happens. This may be set with SETF." (event-info-level (event-info-or-lose name))) (declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level)) (defun %set-event-level (name new-value) @@ -805,15 +794,12 @@ new-value)) (defsetf event-level %set-event-level) -;;; Make an EVENT-INFO structure and stash it in a variable so we can -;;; get at it quickly. +;;; Define a new kind of event. Name is a symbol which names the event +;;; and Description is a string which describes the event. Level +;;; (default 0) is the level of significance associated with this +;;; event; it is used to determine whether to print a Note when the +;;; event happens. (defmacro defevent (name description &optional (level 0)) - #!+sb-doc - "Defevent Name Description - Define a new kind of event. Name is a symbol which names the event and - Description is a string which describes the event. Level (default 0) is the - level of significance associated with this event; it is used to determine - whether to print a Note when the event happens." (let ((var-name (symbolicate "*" name "-EVENT-INFO*"))) `(eval-when (:compile-toplevel :load-toplevel :execute) (defvar ,var-name @@ -824,27 +810,22 @@ (setf (gethash ',name *event-info*) ,var-name) ',name))) +;;; the lowest level of event that will print a note when it occurs (declaim (type unsigned-byte *event-note-threshold*)) -(defvar *event-note-threshold* 1 - #!+sb-doc - "This variable is a non-negative integer specifying the lowest level of - event that will print a note when it occurs.") +(defvar *event-note-threshold* 1) -;;; Increment the counter and do any action. Mumble about the event if -;;; policy indicates. +;;; Note that the event with the specified Name has happened. Node is +;;; evaluated to determine the node to which the event happened. (defmacro event (name &optional node) - #!+sb-doc - "Event Name Node - Note that the event with the specified Name has happened. Node is evaluated - to determine the node to which the event happened." + ;; Increment the counter and do any action. Mumble about the event if + ;; policy indicates. `(%event ,(event-info-var (event-info-or-lose name)) ,node)) +;;; Print a listing of events and their counts, sorted by the count. +;;; Events that happened fewer than Min-Count times will not be +;;; printed. Stream is the stream to write to. (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics)) (defun event-statistics (&optional (min-count 1) (stream *standard-output*)) - #!+sb-doc - "Print a listing of events and their counts, sorted by the count. Events - that happened fewer than Min-Count times will not be printed. Stream is the - stream to write to." (collect ((info)) (maphash #'(lambda (k v) (declare (ignore k)) @@ -870,6 +851,9 @@ #!-sb-fluid (declaim (inline find-in position-in map-in)) +;;; Find Element in a null-terminated List linked by the accessor +;;; function Next. Key, Test and Test-Not are the same as for generic +;;; sequence functions. (defun find-in (next element list @@ -877,10 +861,6 @@ (key #'identity) (test #'eql test-p) (test-not nil not-p)) - #!+sb-doc - "Find Element in a null-terminated List linked by the accessor function - Next. Key, Test and Test-Not are the same as for generic sequence - functions." (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -893,6 +873,9 @@ (when (funcall test (funcall key current) element) (return current))))) +;;; Return the position of Element (or NIL if absent) in a +;;; null-terminated List linked by the accessor function Next. Key, +;;; Test and Test-Not are the same as for generic sequence functions. (defun position-in (next element list @@ -900,10 +883,6 @@ (key #'identity) (test #'eql test-p) (test-not nil not-p)) - #!+sb-doc - "Return the position of Element (or NIL if absent) in a null-terminated List - linked by the accessor function Next. Key, Test and Test-Not are the same as - for generic sequence functions." (when (and test-p not-p) (error "It's silly to supply both :TEST and :TEST-NOT arguments.")) (if not-p @@ -918,10 +897,9 @@ (when (funcall test (funcall key current) element) (return i))))) +;;; Map FUNCTION over the elements in a null-terminated LIST linked by the +;;; accessor function NEXT, returning an ordinary list of the results. (defun map-in (next function list) - #!+sb-doc - "Map Function over the elements in a null-terminated List linked by the - accessor function Next, returning a list of the results." (collect ((res)) (do ((current list (funcall next current))) ((null current)) @@ -963,6 +941,9 @@ (values))))) ;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806 +;;; Push ITEM onto a list linked by the accessor function NEXT that is +;;; stored in PLACE. +;;; ;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a ;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..) ;;; #+SB-XC-HOST @@ -975,9 +956,6 @@ ;;; system isn't running yet, so it'd be too hard to check that my changes were ;;; correct -- WHN 19990806 (def!macro push-in (next item place &environment env) - #!+sb-doc - "Push Item onto a list linked by the accessor function Next that is stored in - Place." (multiple-value-bind (temps vals stores store access) (get-setf-expansion place env) (when (cdr stores) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index d5ce1d9..c1b15cb 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -715,48 +715,38 @@ (:copier nil)) ;; the UT that compilation started at (start-time (get-universal-time) :type unsigned-byte) - ;; a list of the FILE-INFO structures for this compilation - (files nil :type list) - ;; the tail of the FILES for the file we are currently reading - (current-file nil :type list) - ;; the stream that we are using to read the CURRENT-FILE, or NIL if + ;; the FILE-INFO structure for this compilation + (file-info nil :type (or file-info null)) + ;; the stream that we are using to read the FILE-INFO, or NIL if ;; no stream has been opened yet (stream nil :type (or stream null))) -;;; Given a list of pathnames, return a SOURCE-INFO structure. -(defun make-file-source-info (files) - (declare (list files)) - (let ((file-info - (mapcar (lambda (x) - (make-file-info :name (truename x) - :untruename x - :write-date (file-write-date x))) - files))) +;;; Given a pathname, return a SOURCE-INFO structure. +(defun make-file-source-info (file) + (let ((file-info (make-file-info :name (truename file) + :untruename file + :write-date (file-write-date file)))) - (make-source-info :files file-info - :current-file file-info))) + (make-source-info :file-info file-info))) ;;; Return a SOURCE-INFO to describe the incremental compilation of ;;; FORM. Also used by SB!EVAL:INTERNAL-EVAL. (defun make-lisp-source-info (form) - (make-source-info - :start-time (get-universal-time) - :files (list (make-file-info :name :lisp - :forms (vector form) - :positions '#(0))))) + (make-source-info :start-time (get-universal-time) + :file-info (make-file-info :name :lisp + :forms (vector form) + :positions '#(0)))) ;;; Return a SOURCE-INFO which will read from STREAM. (defun make-stream-source-info (stream) - (let ((files (list (make-file-info :name :stream)))) - (make-source-info - :files files - :current-file files - :stream stream))) - -;;; Read a form from STREAM; or for EOF, use the trick popularized by -;;; Kent Pitman of returning STREAM itself. If an error happens, then -;;; convert it to standard abort-the-compilation error condition -;;; (possibly recording some extra location information). + (let ((file-info (make-file-info :name :stream))) + (make-source-info :file-info file-info + :stream stream))) + +;;; Return a form read from STREAM; or for EOF, use the trick +;;; popularized by Kent Pitman of returning STREAM itself. If an error +;;; happens, then convert it to standard abort-the-compilation error +;;; condition (possibly recording some extra location information). (defun read-for-compile-file (stream position) (handler-case (read stream nil stream) (reader-error (condition) @@ -777,24 +767,24 @@ :position position)))) ;;; If STREAM is present, return it, otherwise open a stream to the -;;; current file. There must be a current file. When we open a new -;;; file, we also reset *PACKAGE* and policy. This gives the effect of -;;; rebinding around each file. +;;; current file. There must be a current file. ;;; -;;; FIXME: Since we now do the standard ANSI thing of only one file -;;; per compile (unlike the CMU CL extended COMPILE-FILE) this code is -;;; becoming stale, and the remaining bits of it (and the related code -;;; in ADVANCE-SOURCE-FILE) can go away. +;;; FIXME: This is probably an unnecessarily roundabout way to do +;;; things now that we process a single file in COMPILE-FILE (unlike +;;; the old CMU CL code, which accepted multiple files). Also, the old +;;; comment said +;;; When we open a new file, we also reset *PACKAGE* and policy. +;;; This gives the effect of rebinding around each file. +;;; which doesn't seem to be true now. Check to make sure that if +;;; such rebinding is necessary, it's still done somewhere. (defun get-source-stream (info) (declare (type source-info info)) - (cond ((source-info-stream info)) - (t - (let* ((finfo (first (source-info-current-file info))) - (name (file-info-name finfo))) - (setq sb!xc:*compile-file-truename* name) - (setq sb!xc:*compile-file-pathname* (file-info-untruename finfo)) - (setf (source-info-stream info) - (open name :direction :input)))))) + (or (source-info-stream info) + (let* ((file-info (source-info-file-info info)) + (name (file-info-name file-info))) + (setf sb!xc:*compile-file-truename* name + sb!xc:*compile-file-pathname* (file-info-untruename file-info) + (source-info-stream info) (open name :direction :input))))) ;;; Close the stream in INFO if it is open. (defun close-source-info (info) @@ -804,65 +794,33 @@ (setf (source-info-stream info) nil) (values)) -;;; Advance INFO to the next source file. If there is no next source -;;; file, return NIL, otherwise T. -(defun advance-source-file (info) - (declare (type source-info info)) - (close-source-info info) - (let ((prev (pop (source-info-current-file info)))) - (if (source-info-current-file info) - (let ((current (first (source-info-current-file info)))) - (setf (file-info-source-root current) - (+ (file-info-source-root prev) - (length (file-info-forms prev)))) - t) - nil))) - -;;; Read the sources from the source files and process them. -(defun process-sources (info) - (let* ((file (first (source-info-current-file info))) +;;; Read the source file. +(defun process-source (info) + (let* ((file-info (source-info-file-info info)) (stream (get-source-stream info))) (loop (let* ((pos (file-position stream)) (form (read-for-compile-file stream pos))) (if (eq form stream) ; i.e., if EOF (return) - (let* ((forms (file-info-forms file)) + (let* ((forms (file-info-forms file-info)) (current-idx (+ (fill-pointer forms) - (file-info-source-root file)))) + (file-info-source-root file-info)))) (vector-push-extend form forms) - (vector-push-extend pos (file-info-positions file)) + (vector-push-extend pos (file-info-positions file-info)) (clrhash *source-paths*) (find-source-paths form current-idx) (process-top-level-form form `(original-source-start 0 - ,current-idx)))))) - (when (advance-source-file info) - (process-sources info)))) - -;;; Return the FILE-INFO describing the INDEX'th form. -;;; -;;; FIXME: This is unnecessarily general cruft now that we only read -;;; a single file in COMPILE-FILE. -(defun find-file-info (index info) - (declare (type index index) (type source-info info)) - (dolist (file (source-info-files info)) - (when (> (+ (length (file-info-forms file)) - (file-info-source-root file)) - index) - (return file)))) + ,current-idx)))))))) ;;; Return the INDEX'th source form read from INFO and the position ;;; where it was read. -;;; -;;; FIXME: This is unnecessarily general cruft now that we only read -;;; a single file in COMPILE-FILE. (defun find-source-root (index info) - (declare (type source-info info) (type index index)) - (let* ((file (find-file-info index info)) - (idx (- index (file-info-source-root file)))) - (values (aref (file-info-forms file) idx) - (aref (file-info-positions file) idx)))) + (declare (type index index) (type source-info info)) + (let ((file-info (source-info-file-info info))) + (values (aref (file-info-forms file-info) index) + (aref (file-info-positions file-info) index)))) ;;;; top-level form processing @@ -1203,7 +1161,7 @@ ;;; Read all forms from INFO and compile them, with output to OBJECT. ;;; Return (VALUES NIL WARNINGS-P FAILURE-P). -(defun sub-compile-file (info &optional d-s-info) +(defun sub-compile-file (info) (declare (type source-info info)) (let* (;; These are bound in WITH-COMPILATION-UNIT now. -- WHN 20000308 #+nil (*compiler-error-count* 0) @@ -1239,14 +1197,14 @@ (sb!xc:with-compilation-unit () (clear-stuff) - (process-sources info) + (process-source info) (finish-block-compilation) (compile-top-level-lambdas () t) (let ((object *compile-object*)) (etypecase object (fasl-output (fasl-dump-source-info info object)) - (core-object (fix-core-source-info info object d-s-info)) + (core-object (fix-core-source-info info object)) (null))) nil)) ;; Some errors are sufficiently bewildering that we just fail @@ -1258,12 +1216,10 @@ condition) (values nil t t))))) -;;; Return a list of pathnames for the named files. All the files must -;;; exist. -(defun verify-source-files (stuff) - (let* ((stuff (if (listp stuff) stuff (list stuff))) - (default-host (make-pathname - :host (pathname-host (pathname (first stuff)))))) +;;; Return a pathname for the named file. The file must exist. +(defun verify-source-file (pathname-designator) + (let* ((pathname (pathname pathname-designator)) + (default-host (make-pathname :host (pathname-host pathname)))) (flet ((try-with-type (path type error-p) (let ((new (merge-pathnames path (make-pathname :type type @@ -1271,16 +1227,11 @@ (if (probe-file new) new (and error-p (truename new)))))) - (unless stuff - (error "can't compile with no source files")) - (mapcar #'(lambda (x) - (let ((x (pathname x))) - (cond ((typep x 'logical-pathname) - (try-with-type x "LISP" t)) - ((probe-file x) x) - ((try-with-type x "lisp" nil)) - ((try-with-type x "lisp" t))))) - stuff)))) + (cond ((typep pathname 'logical-pathname) + (try-with-type pathname "LISP" t)) + ((probe-file pathname) pathname) + ((try-with-type pathname "lisp" nil)) + ((try-with-type pathname "lisp" t)))))) (defun elapsed-time-to-string (tsec) (multiple-value-bind (tmin sec) (truncate tsec 60) @@ -1290,11 +1241,12 @@ ;;; Print some junk at the beginning and end of compilation. (defun start-error-output (source-info) (declare (type source-info source-info)) - (dolist (x (source-info-files source-info)) + (let ((file-info (source-info-file-info source-info))) (compiler-mumble "~&; compiling file ~S (written ~A):~%" - (namestring (file-info-name x)) + (namestring (file-info-name file-info)) (sb!int:format-universal-time nil - (file-info-write-date x) + (file-info-write-date + file-info) :style :government :print-weekday nil :print-timezone nil))) @@ -1366,15 +1318,8 @@ (compile-won nil) (warnings-p nil) (failure-p t) ; T in case error keeps this from being set later - ;; KLUDGE: The listifying and unlistifying in the stuff - ;; related to VERIFY-SOURCE-FILES below is to interface to - ;; old CMU CL code which accepted and returned lists of - ;; multiple source files. It would be cleaner to redo - ;; VERIFY-SOURCE-FILES as VERIFY-SOURCE-FILE, accepting a - ;; single source file, and do a similar transformation on - ;; MAKE-FILE-SOURCE-INFO too. -- WHN 20000201 - (input-pathname (first (verify-source-files (list input-file)))) - (source-info (make-file-source-info (list input-pathname))) + (input-pathname (verify-source-file input-file)) + (source-info (make-file-source-info input-pathname)) (*compiler-trace-output* nil)) ; might be modified below (unwind-protect diff --git a/version.lisp-expr b/version.lisp-expr index b17e534..6bfae87 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.6.12.44" +"0.6.12.45"