: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"
"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"
;;; 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))
(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))
(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)
(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)
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)))
(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)))
(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))
(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)
(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)))))
(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)
(byte-interpret component new-pc fp)))
\f
-;;;; the byte-interpreter
+;;;; the actual byte-interpreter
;;; The various operations are encoded as follows.
;;;
(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.
(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.
(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)
(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)))
(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
((< 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)
(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))))
(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)
(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)
(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)))
(*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:~% ~
(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
(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)
;; 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))
(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))
(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
(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?
;; 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)))))
(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)
;;; 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)
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)))
\f
;;;; One of the steps in building a nice debuggable macro is changing
;;;; its MACRO-FUNCTION to print as e.g.
;;;; #<Interpreted Function "DEFMACRO BAR" {9166351}>
-;;;; 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)
(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.
;;; 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) (*))))))
\f
;;;; variables
(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)
\f
;;;; 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))))
(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
;;; 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~%"
(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))))
;; 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))
(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))
(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.
(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))
;; 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))
;; 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.
;; 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
;; 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
(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))
\f
;;;; INTERNAL-EVAL
;;; 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)))
(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*)
(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
(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)
(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)
(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
;;; 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
(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*)
) ; 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 ..)
;;; 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")))
;;; #+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))
\f
;;;; lambda-list parsing utilities
;;;
;;; 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))
(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))
((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)
,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
;;; 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)
`(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))
(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)))
(warning #'compiler-warning-handler))
,@forms)))
+;;; Look up NAME in the lexical environment namespace designated by
+;;; SLOT, returning the <value, T>, or <NIL, NIL> 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 <value, T>, or <NIL, NIL> 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
) ; 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))
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)
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
(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))
#!-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
(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
(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
(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
(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))
(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
;;; 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)
(: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)
: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)
(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))))
\f
;;;; top-level form processing
;;; 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)
(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
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
(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)
;;; 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)))
(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
;;; 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"
projects / sbcl.git / commitdiff