From: William Harold Newman Date: Mon, 27 Aug 2001 16:07:41 +0000 (+0000) Subject: 0.pre7.16: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a40c4adfd7837230109cdb1f054b44fe0b15371a;p=sbcl.git 0.pre7.16: Since this version builds nicely without :SB-INTERPRETER now, I can burn the bridges. Die, ill-begotten writhing mass of wacky special cases, crude hackery, and never-say-die ANSI-non-compliance! Begone back to the bit bucket that barfed you!.. ..deleted :SB-INTERPRETER stuff everywhere ..deleted src/code/eval.lisp, src/compiler/eval-comp.lisp, and src/compiler/eval.lisp ..renamed SB-EVAL package to SB-BYTECODE ..renamed target-eval.lisp to eval.lisp (possibly confusing CVS; dunno what happens with "cvs remove" followed by "cvs add" without an intervening commit, but will soon find out:-) FUNCTION-DEBUG-FUNCTION should use ECASE to signal an error when it's confused, instead of just dropping a NIL into the bowels of the debugger and waiting to see what breaks later. TRY-TO-RENAME-INTERPRETED-FUNCTION-AS-MACRO goes away. --- diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 33c7d1f..850e770 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -481,27 +481,10 @@ like *STACK-TOP-HINT*" "DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR")) #s(sb-cold:package-data - :name "SB!EVAL" - :doc "private: originally the implementation of the IR1 interpreter, -and now that the IR1 interpreter is gone, home to some stuff which is still -used by the bytecode interpreter" + :name "SB!BYTECODE" + :doc "private: stuff related to the bytecode interpreter" :use ("CL" "SB!KERNEL" "SB!INT") - :export #!-sb-interpreter - ("INTERNAL-EVAL") - #!+sb-interpreter - ("INTERNAL-EVAL" - #!+sb-show "*EVAL-STACK-TRACE*" - #!+sb-show "*INTERNAL-APPLY-NODE-TRACE*" - "FLUSH-INTERPRETED-FUNCTION-CACHE" - "INTERPRETED-FUNCTION" - "INTERPRETED-FUNCTION-ARGLIST" - "INTERPRETED-FUNCTION-CLOSURE" - "INTERPRETED-FUNCTION-LAMBDA-EXPRESSION" - "INTERPRETED-FUNCTION-NAME" - "INTERPRETED-FUNCTION-P" - "INTERPRETED-FUNCTION-TYPE" - "MAKE-INTERPRETED-FUNCTION" - "PRINT-INTERPRETED-FUNCTION-OBJECT")) + :export ("INTERNAL-EVAL")) #s(sb-cold:package-data :name "SB!EXT" @@ -1200,7 +1183,6 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "STRING-TO-SIMPLE-STRING" "SYSTEM-AREA-CLEAR" "SYSTEM-AREA-COPY" "TWO-ARG-*" - "TRY-TO-RENAME-INTERPRETED-FUNCTION-AS-MACRO" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/" "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-=" diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index e510d17..0895e5f 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -64,34 +64,34 @@ #!-sb-fluid (declaim (inline eval-stack-ref)) (defun eval-stack-ref (offset) (declare (type stack-pointer offset)) - (svref sb!eval::*eval-stack* offset)) + (svref sb!bytecode::*eval-stack* offset)) #!-sb-fluid (declaim (inline (setf eval-stack-ref))) (defun (setf eval-stack-ref) (new-value offset) (declare (type stack-pointer offset)) - (setf (svref sb!eval::*eval-stack* offset) new-value)) + (setf (svref sb!bytecode::*eval-stack* offset) new-value)) (defun push-eval-stack (value) - (let ((len (length (the simple-vector sb!eval::*eval-stack*))) + (let ((len (length (the simple-vector sb!bytecode::*eval-stack*))) (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))) + (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len) + (setf sb!bytecode::*eval-stack* new-stack))) (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*))) + (let* ((len (length (the simple-vector sb!bytecode::*eval-stack*))) (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))) + (replace new-stack sb!bytecode::*eval-stack* :end1 len :end2 len) + (setf sb!bytecode::*eval-stack* new-stack))) (setf *eval-stack-top* new-sp) - (let ((stack sb!eval::*eval-stack*)) + (let ((stack sb!bytecode::*eval-stack*)) (do ((i sp (1+ i))) ; FIXME: Use CL:FILL. ((= i new-sp)) (setf (svref stack i) '#:uninitialized-eval-stack-element)))) @@ -836,7 +836,7 @@ (format *trace-output* "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%" pc fp *eval-stack-top* byte - (subseq sb!eval::*eval-stack* fp *eval-stack-top*))))) + (subseq sb!bytecode::*eval-stack* fp *eval-stack-top*))))) (if (zerop (logand byte #x80)) ;; Some stack operation. No matter what, we need the operand, ;; so compute it. diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp index 6c3b8ce..c44584a 100644 --- a/src/code/cross-misc.lisp +++ b/src/code/cross-misc.lisp @@ -32,15 +32,6 @@ `(progn ,@forms)) ;;; When we're running as a cross-compiler in an arbitrary host ANSI -;;; Lisp, we don't have any hooks available to manipulate the -;;; debugging name and debugging argument list of an interpreted -;;; function object (and don't care much about getting debugging name -;;; and debugging argument list right anyway). -(defun try-to-rename-interpreted-function-as-macro (f name lambda-list) - (declare (ignore f name lambda-list)) - (values)) - -;;; When we're running as a cross-compiler in an arbitrary host ANSI ;;; Lisp, we shouldn't be doing anything which is sensitive to GC. ;;; KLUDGE: I (WHN 19990131) think the proper long-term solution would ;;; be to remove any operations from cross-compiler source files diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 2572bd3..338d1fa 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -302,7 +302,7 @@ (pointer up debug-function code-location number real-frame closure)) (:copier nil)) - ;; This points to the compiled-frame for SB!EVAL:INTERNAL-APPLY-LOOP. + ;; This points to the compiled-frame for SB!BYTECODE:INTERNAL-APPLY-LOOP. (real-frame nil :type compiled-frame) ;; This is the closed over data used by the interpreter. (closure nil :type simple-vector)) @@ -955,59 +955,73 @@ (#.sb!vm::lra-save-offset (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value)))))) -(defvar *debugging-interpreter* nil - #!+sb-doc - "When set, the debugger foregoes making interpreted-frames, so you can - debug the functions that manifest the interpreter.") - -;;; This takes a newly computed frame, FRAME, and the frame above it -;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when -;;; we hit the bottom of the control stack. When FRAME represents a -;;; call to SB!EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame -;;; to replace FRAME. The interpreted frame points to FRAME. +;;; This doesn't do anything in sbcl-0.7.0, since the functionality +;;; was lost in the switch from IR1 interpreter to bytecode interpreter. +;;; However, it might be revived someday. (See the FIXME for +;;; POSSIBLY-AN-INTERPRETED-FRAME.) +;;; +;;; (defvar *debugging-interpreter* nil +;;; #!+sb-doc +;;; "When set, the debugger foregoes making interpreted frames, so you can +;;; debug the functions that manifest the interpreter.") + +;;; FIXME: In CMU CL with the IR1 interpreter, this did +;;; This takes a newly computed frame, FRAME, and the frame above it +;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when +;;; we hit the bottom of the control stack. When FRAME represents a +;;; call to SB!BYTECODE::INTERNAL-APPLY-LOOP, we make an interpreted frame +;;; to replace FRAME. The interpreted frame points to FRAME. +;;; When SBCL switch to a byte interpreter, this functionality wasn't +;;; updated, so now when you try to "debug byte code", you actually +;;; end up debugging the byte interpreter instead. It might be good +;;; to update the old CMU CL functionality so that you can really +;;; debug byte code instead of seeing a bunch of confusing byte +;;; interpreter implementation stuff. (defun possibly-an-interpreted-frame (frame up-frame) - ;; trivial without SB-INTERPRETER - #!-sb-interpreter (declare (ignore up-frame)) - #!-sb-interpreter frame - - ;; nontrivial with SB-INTERPRETER - #!+sb-interpreter - (if (or (not frame) - (not (eq (debug-function-name (frame-debug-function - frame)) - 'sb!eval::internal-apply-loop)) - *debugging-interpreter* - (compiled-frame-escaped frame)) - frame - (flet ((get-var (name location) - (let ((vars (sb!di:ambiguous-debug-vars - (sb!di:frame-debug-function frame) name))) - (when (or (null vars) (> (length vars) 1)) - (error "zero or more than one ~A variable in ~ - SB!EVAL::INTERNAL-APPLY-LOOP" - (string-downcase name))) - (if (eq (debug-var-validity (car vars) location) - :valid) - (car vars))))) - (let* ((code-loc (frame-code-location frame)) - (ptr-var (get-var "FRAME-PTR" code-loc)) - (node-var (get-var "NODE" code-loc)) - (closure-var (get-var "CLOSURE" code-loc))) - (if (and ptr-var node-var closure-var) - (let* ((node (debug-var-value node-var frame)) - (d-fun (make-interpreted-debug-function - (sb!c::block-home-lambda (sb!c::node-block - node))))) - (make-interpreted-frame - (debug-var-value ptr-var frame) - up-frame - d-fun - (make-interpreted-code-location node d-fun) - (frame-number frame) - frame - (debug-var-value closure-var frame))) - frame))))) + ;; new SBCL code, not whizzy enough to do anything tricky like + ;; hiding the byte interpreter when debugging + (declare (ignore up-frame)) + frame + + ;; old CMU CL code to hide IR1 interpreter when debugging + ;; + ;;(if (or (not frame) + ;; (not (eq (debug-function-name (frame-debug-function + ;; frame)) + ;; 'sb!bytecode::internal-apply-loop)) + ;; *debugging-interpreter* + ;; (compiled-frame-escaped frame)) + ;; frame + ;; (flet ((get-var (name location) + ;; (let ((vars (sb!di:ambiguous-debug-vars + ;; (sb!di:frame-debug-function frame) name))) + ;; (when (or (null vars) (> (length vars) 1)) + ;; (error "zero or more than one ~A variable in ~ + ;; SB!BYTECODE::INTERNAL-APPLY-LOOP" + ;; (string-downcase name))) + ;; (if (eq (debug-var-validity (car vars) location) + ;; :valid) + ;; (car vars))))) + ;; (let* ((code-loc (frame-code-location frame)) + ;; (ptr-var (get-var "FRAME-PTR" code-loc)) + ;; (node-var (get-var "NODE" code-loc)) + ;; (closure-var (get-var "CLOSURE" code-loc))) + ;; (if (and ptr-var node-var closure-var) + ;; (let* ((node (debug-var-value node-var frame)) + ;; (d-fun (make-interpreted-debug-function + ;; (sb!c::block-home-lambda (sb!c::node-block + ;; node))))) + ;; (make-interpreted-frame + ;; (debug-var-value ptr-var frame) + ;; up-frame + ;; d-fun + ;; (make-interpreted-code-location node d-fun) + ;; (frame-number frame) + ;; frame + ;; (debug-var-value closure-var frame))) + ;; frame)))) + ) ;;; This returns a frame for the one existing in time immediately ;;; prior to the frame referenced by current-fp. This is current-fp's @@ -1444,25 +1458,19 @@ ;;; Return a debug-function that represents debug information for function. (defun function-debug-function (fun) - (case (get-type fun) + (ecase (get-type fun) (#.sb!vm:closure-header-type (function-debug-function (%closure-function fun))) (#.sb!vm:funcallable-instance-header-type - (cond #!+sb-interpreter - ((sb!eval:interpreted-function-p fun) - (make-interpreted-debug-function - (or (sb!eval::interpreted-function-definition fun) - (sb!eval::convert-interpreted-fun fun)))) - (t - (function-debug-function (funcallable-instance-function fun))))) + (function-debug-function (funcallable-instance-function fun))) ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type) (let* ((name (%function-name fun)) (component (function-code-header fun)) (res (find-if - #'(lambda (x) - (and (sb!c::compiled-debug-function-p x) - (eq (sb!c::compiled-debug-function-name x) name) - (eq (sb!c::compiled-debug-function-kind x) nil))) + (lambda (x) + (and (sb!c::compiled-debug-function-p x) + (eq (sb!c::compiled-debug-function-name x) name) + (eq (sb!c::compiled-debug-function-kind x) nil))) (get-debug-info-function-map (%code-debug-info component))))) (if res @@ -2459,10 +2467,9 @@ (error 'invalid-value :debug-var debug-var :frame frame)) (debug-var-value debug-var frame)) +;;; Returns the value stored for DEBUG-VAR in frame. The value may be +;;; invalid. This is SETFable. (defun debug-var-value (debug-var frame) - #!+sb-doc - "Returns the value stored for DEBUG-VAR in frame. The value may be - invalid. This is SETF'able." (etypecase debug-var (compiled-debug-var (aver (typep frame 'compiled-frame)) @@ -2470,14 +2477,13 @@ (if (indirect-value-cell-p res) (sb!c:value-cell-ref res) res))) - #!+sb-interpreter - (interpreted-debug-var - (aver (typep frame 'interpreted-frame)) - (sb!eval::leaf-value-lambda-var - (interpreted-code-location-ir1-node (frame-code-location frame)) - (interpreted-debug-var-ir1-var debug-var) - (frame-pointer frame) - (interpreted-frame-closure frame))))) + ;; (This function used to be more interesting, with more type + ;; cases here, before the IR1 interpreter went away. It might + ;; become more interesting again if we ever try to generalize the + ;; CMU CL POSSIBLY-AN-INTERPRETED-FRAME thing to elide + ;; internal-to-the-byte-interpreter debug frames the way that CMU + ;; CL elided internal-to-the-IR1-interpreter debug frames.) + )) ;;; This returns what is stored for the variable represented by ;;; DEBUG-VAR relative to the FRAME. This may be an indirect value @@ -2803,9 +2809,7 @@ ;;; This stores value as the value of DEBUG-VAR in FRAME. In the ;;; COMPILED-DEBUG-VAR case, access the current value to determine if ;;; it is an indirect value cell. This occurs when the variable is -;;; both closed over and set. For INTERPRETED-DEBUG-VARs just call -;;; SB!EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter -;;; objects. +;;; both closed over and set. (defun %set-debug-var-value (debug-var frame value) (etypecase debug-var (compiled-debug-var @@ -2814,15 +2818,13 @@ (if (indirect-value-cell-p current-value) (sb!c:value-cell-set current-value value) (set-compiled-debug-var-slot debug-var frame value)))) - #!+sb-interpreter - (interpreted-debug-var - (aver (typep frame 'interpreted-frame)) - (sb!eval::set-leaf-value-lambda-var - (interpreted-code-location-ir1-node (frame-code-location frame)) - (interpreted-debug-var-ir1-var debug-var) - (frame-pointer frame) - (interpreted-frame-closure frame) - value))) + ;; (This function used to be more interesting, with more type + ;; cases here, before the IR1 interpreter went away. It might + ;; become more interesting again if we ever try to generalize the + ;; CMU CL POSSIBLY-AN-INTERPRETED-FRAME thing to elide + ;; internal-to-the-byte-interpreter debug frames the way that CMU + ;; CL elided internal-to-the-IR1-interpreter debug frames.) + ) value) ;;; This stores value for the variable represented by debug-var diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index dd7305e..0f3af74 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -192,9 +192,6 @@ ;;; merge into that too? dunno..) (defun sb!c::%defun (name def doc source) (declare (ignore source)) - #-sb-xc-host (progn - #!+sb-interpreter - (setf (sb!eval:interpreted-function-name def) name)) (flet ((set-type-info-from-def () (setf (info :function :type name) #-sb-xc-host (extract-function-type def) diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index ea41418..74e2ea9 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -35,22 +35,22 @@ ;;; still useful in the target interpreter, and in the ;;; cross-compilation host. (defun sb!c::%defmacro (name definition lambda-list doc) - (try-to-rename-interpreted-function-as-macro definition name lambda-list) (sb!c::%%defmacro name definition doc)) ;;; (called by SB!C::%DEFMACRO) (eval-when (:compile-toplevel :load-toplevel :execute) (defun sb!c::%%defmacro (name definition doc) - ;; Old note (ca. 1985, maybe:-): "Eventually %%DEFMACRO should deal with - ;; clearing old compiler information for the functional value." + ;; old note (ca. 1985, maybe:-): "Eventually %%DEFMACRO should + ;; deal with clearing old compiler information for the functional + ;; value." (clear-info :function :where-from name) ;; FIXME: It would be nice to warn about DEFMACRO of an ;; already-defined macro, but that's slightly hard to do because ;; in common usage DEFMACRO is defined at compile time and then ;; redefined at load time. We'd need to make a distinction between ;; the defined-at-compile-time state and the defined-at-load-time - ;; state to make this work. (Trying to warn about duplicate DEFTYPEs - ;; runs into the same problem.) + ;; state to make this work. (Trying to warn about duplicate + ;; DEFTYPEs runs into the same problem.) #+nil (when (sb!xc:macro-function name) (style-warn "redefining ~S in DEFMACRO" name)) (setf (sb!xc:macro-function name) definition diff --git a/src/code/describe.lisp b/src/code/describe.lisp index fc7bb94..94afc2c 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -132,35 +132,6 @@ ~:[no~;~] expansion is available." inlinep (info :function :inline-expansion name)))))) -;;; Interpreted function describing; handles both closure and -;;; non-closure functions. Instead of printing the compiled-from info, -;;; we print the definition. -#+sb-interpreter -(defun %describe-function-interpreted (x s kind name) - (declare (type stream s)) - (multiple-value-bind (exp closure-p dname) - (sb-eval:interpreted-function-lambda-expression x) - (let ((args (sb-eval:interpreted-function-arglist x))) - (format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind) - (if args - (format s " ~<~S~:>" args) - (write-string " There are no arguments." s))) - (let ((name (or name dname))) - (%describe-doc name s 'function kind) - (unless (eq kind :macro) - (%describe-function-name - name - s - (type-specifier (sb-eval:interpreted-function-type x))))) - (when closure-p - (format s "~@:_Its closure environment is:~%") - (pprint-logical-block (s nil) - (pprint-indent :current 2) - (let ((closure (sb-eval:interpreted-function-closure x))) - (dotimes (i (length closure)) - (format s "~@:_~S: ~S" i (svref closure i)))))) - (format s "~@:_Its definition is:~@:_ ~S" exp))) - ;;; Print information from the debug-info about where CODE-OBJ was ;;; compiled from. (defun %describe-compiled-from (code-obj s) @@ -257,9 +228,6 @@ (let ((data (byte-closure-data x))) (dotimes (i (length data)) (format s "~@:_~S: ~S" i (svref data i)))))) - #+sb-interpreter - (sb-eval:interpreted-function - (%describe-function-interpreted x s kind name)) (standard-generic-function ;; There should be a special method for this case; we'll ;; delegate to that. diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 006459d..81e9b85 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -204,10 +204,6 @@ the usual naming convention (names like *FOO*) for special variables" ,body)))) `(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc))))) (defun sb!c::%define-compiler-macro (name definition lambda-list doc) - #!+sb-interpreter (setf (sb!eval:interpreted-function-name definition) - (format nil "DEFINE-COMPILER-MACRO ~S" name)) - #!+sb-interpreter (setf (sb!eval:interpreted-function-arglist definition) - lambda-list) (sb!c::%%define-compiler-macro name definition doc)) (defun sb!c::%%define-compiler-macro (name definition doc) (setf (sb!xc:compiler-macro-function name) definition) diff --git a/src/code/ntrace.lisp b/src/code/ntrace.lisp index b52c1de..764099c 100644 --- a/src/code/ntrace.lisp +++ b/src/code/ntrace.lisp @@ -125,20 +125,14 @@ (values (fdefinition x) t)))) (function x) (t (values (fdefinition x) t))) - (if (or #+sb-interpreter (sb-eval:interpreted-function-p res) - nil) - (values res - named-p - #+sb-interpreter (if (sb-eval:interpreted-function-closure res) - :interpreted-closure :interpreted)) - (case (sb-kernel:get-type res) - (#.sb-vm:closure-header-type - (values (sb-kernel:%closure-function res) - named-p - :compiled-closure)) - (#.sb-vm:funcallable-instance-header-type - (values res named-p :funcallable-instance)) - (t (values res named-p :compiled)))))) + (case (sb-kernel:get-type res) + (#.sb-vm:closure-header-type + (values (sb-kernel:%closure-function res) + named-p + :compiled-closure)) + (#.sb-vm:funcallable-instance-header-type + (values res named-p :funcallable-instance)) + (t (values res named-p :compiled))))) ;;; When a function name is redefined, and we were tracing that name, ;;; then untrace the old definition and trace the new one. diff --git a/src/code/print.lisp b/src/code/print.lisp index 8b4bc06..e2e67d8 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1556,11 +1556,6 @@ #(#.sb!vm:closure-header-type #.sb!vm:byte-code-closure-type)) "CLOSURE") - #!+sb-interpreter - ((sb!eval::interpreted-function-p object) - (or (sb!eval::interpreted-function-%name object) - (sb!eval:interpreted-function-lambda-expression - object))) ((find (function-subtype object) #(#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)) diff --git a/src/code/save.lisp b/src/code/save.lisp index 8b3f62a..061be32 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -64,9 +64,6 @@ saved core is loaded." #!+mp (sb!mp::shutdown-multi-processing) - #!+sb-interpreter - (when (fboundp 'sb!eval:flush-interpreted-function-cache) - (sb!eval:flush-interpreted-function-cache)) ;; FIXME: What is this for? Explain. (when (fboundp 'cancel-finalization) (cancel-finalization sb!sys:*tty*)) diff --git a/src/code/target-eval.lisp b/src/code/target-eval.lisp deleted file mode 100644 index 6003b6c..0000000 --- a/src/code/target-eval.lisp +++ /dev/null @@ -1,255 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!EVAL") - -;;; This is defined here so that the printer etc. can call -;;; INTERPRETED-FUNCTION-P before the full interpreter is loaded. - -;;; an interpreted function -(defstruct (interpreted-function - (:alternate-metaclass sb!kernel:funcallable-instance - sb!kernel:funcallable-structure-class - sb!kernel:make-funcallable-structure-class) - (:type sb!kernel:funcallable-structure) - (:constructor %make-interpreted-function) - (:copier nil) - ;; FIXME: Binding PRINT-OBJECT isn't going to help unless - ;; we fix the print-a-funcallable-instance code so that - ;; it calls PRINT-OBJECT in this case. - (:print-object - (lambda (x stream) - (print-unreadable-object (x stream :identity t) - (interpreted-function-%name x))))) - ;; The name of this interpreted function, or NIL if none specified. - (%name nil) - ;; This function's debug arglist. - (arglist nil) - ;; A lambda that can be converted to get the definition. - (lambda nil) - ;; If this function has been converted, then this is the XEP. If this is - ;; false, then the function is not in the cache (or is in the process of - ;; being removed.) - (definition nil :type (or sb!c::clambda null)) - ;; The number of consecutive GCs that this function has been unused. - ;; This is used to control cache replacement. - (gcs 0 :type sb!c::index) - ;; True if Lambda has been converted at least once, and thus warnings should - ;; be suppressed on additional conversions. - (converted-once nil) - ;; For a closure, the closure date vector. - (closure nil :type (or null simple-vector))) - -(in-package "SB!IMPL") - -;;;; 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. -;;;; -;;;; 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) - #!+sb-interpreter (setf (sb!eval:interpreted-function-name f) - (format nil "DEFMACRO ~S" name) - (sb!eval:interpreted-function-arglist f) - lambda-list) - (values)) - -;;;; EVAL and friends - -;;; This needs to be initialized in the cold load, since the top-level -;;; catcher will always restore the initial value. -(defvar *eval-stack-top* 0) - -;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. If -;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing -;;; a call so that the effect is confined to the lexical scope of the -;;; EVAL-WHEN. -(defun eval (original-exp) - #!+sb-doc - "Evaluate the argument in a null lexical environment, returning the - result or results." - (declare (optimize (safety 1))) - (let ((exp (macroexpand original-exp))) - (typecase exp - (symbol - (ecase (info :variable :kind exp) - (:constant - (values (info :variable :constant-value exp))) - ((:special :global) - (symbol-value exp)) - (:alien - (sb!eval:internal-eval original-exp)))) - (list - (let ((name (first exp)) - (args (1- (length exp)))) - (case name - (function - (unless (= args 1) - (error "wrong number of args to FUNCTION:~% ~S" exp)) - (let ((name (second exp))) - (if (or (atom name) - (and (consp name) - (eq (car name) 'setf))) - (fdefinition name) - #!+sb-interpreter - (sb!eval:make-interpreted-function name) - #!-sb-interpreter - (sb!eval:internal-eval original-exp)))) - (quote - (unless (= args 1) - (error "wrong number of args to QUOTE:~% ~S" exp)) - (second exp)) - (setq - (unless (evenp args) - (error "odd number of args to SETQ:~% ~S" exp)) - (unless (zerop args) - (do ((name (cdr exp) (cddr name))) - ((null name) - (do ((args (cdr exp) (cddr args))) - ((null (cddr args)) - ;; We duplicate the call to SET so that the - ;; correct value gets returned. - (set (first args) (eval (second args)))) - (set (first args) (eval (second args))))) - (let ((symbol (first name))) - (case (info :variable :kind symbol) - ;; FIXME: I took out the *TOP-LEVEL-AUTO-DECLARE* - ;; test here, and removed the *TOP-LEVEL-AUTO-DECLARE* - ;; variable; the code should now act as though that - ;; variable is NIL. This should be tested.. - (:special) - (t (return (sb!eval:internal-eval original-exp)))))))) - ((progn) - (when (> args 0) - (dolist (x (butlast (rest exp)) (eval (car (last exp)))) - (eval x)))) - ((eval-when) - (if (and (> args 0) - (or (member 'eval (second exp)) - (member :execute (second exp)))) - (when (> args 1) - (dolist (x (butlast (cddr exp)) (eval (car (last exp)))) - (eval x))) - (sb!eval:internal-eval original-exp))) - (t - (if (and (symbolp name) - (eq (info :function :kind name) :function)) - (collect ((args)) - (dolist (arg (rest exp)) - (args (eval arg))) - #!-sb-interpreter - (apply (symbol-function name) (args)) - #!+sb-interpreter - (if sb!eval::*already-evaled-this* - (let ((sb!eval::*already-evaled-this* nil)) - (apply (symbol-function name) (args))) - (apply (symbol-function name) (args)))) - (sb!eval:internal-eval original-exp)))))) - (t - exp)))) - -;;; general case of EVAL (except in that it can't handle toplevel -;;; EVAL-WHEN magic properly): Delegate to the byte compiler. -#!-sb-interpreter -(defun sb!eval:internal-eval (expr) - (funcall (compile (gensym "EVAL-TMPFUN-") - `(lambda () - ;; SPEED=0,DEBUG=1 => byte-compile - (declare (optimize (speed 0) (debug 1))) - (declare (optimize (space 1) (safety 1))) - (declare (optimize (compilation-speed 3))) - ,expr)))) - -;;; Given a function, return three values: -;;; 1] A lambda expression that could be used to define the function, -;;; or NIL if the definition isn't available. -;;; 2] NIL if the function was definitely defined in a null lexical -;;; environment, and T otherwise. -;;; 3] Some object that \"names\" the function. Although this is -;;; allowed to be any object, CMU CL always returns a valid -;;; function name or a string. -;;; -;;; If interpreted, use the interpreter interface. Otherwise, see -;;; whether it was compiled with COMPILE. If that fails, check for an -;;; inline expansion. -(defun function-lambda-expression (fun) - (declare (type function fun)) - (cond #!+sb-interpreter - ((sb!eval:interpreted-function-p fun) - (sb!eval:interpreted-function-lambda-expression fun)) - (t - (let* ((fun (%function-self fun)) - (name (%function-name fun)) - (code (sb!di::function-code-header fun)) - (info (sb!kernel:%code-debug-info code))) - (if info - (let ((source (first (sb!c::compiled-debug-info-source info)))) - (cond ((and (eq (sb!c::debug-source-from source) :lisp) - (eq (sb!c::debug-source-info source) fun)) - (values (second (svref (sb!c::debug-source-name source) 0)) - nil name)) - ((stringp name) - (values nil t name)) - (t - (let ((exp (info :function :inline-expansion name))) - (if exp - (values exp nil name) - (values nil t name)))))) - (values nil t name)))))) - -;;; Like FIND-IF, only we do it on a compiled closure's environment. -(defun find-if-in-closure (test fun) - (dotimes (index (1- (get-closure-length fun))) - (let ((elt (%closure-index-ref fun index))) - (when (funcall test elt) - (return elt))))) - -;;; function invocation - -(defun apply (function arg &rest args) - #!+sb-doc - "Applies FUNCTION to a list of arguments produced by evaluating ARGS in - the manner of LIST*. That is, a list is made of the values of all but the - last argument, appended to the value of the last argument, which must be a - list." - (cond ((atom args) - (apply function arg)) - ((atom (cdr args)) - (apply function (cons arg (car args)))) - (t (do* ((a1 args a2) - (a2 (cdr args) (cdr a2))) - ((atom (cdr a2)) - (rplacd a1 (car a2)) - (apply function (cons arg args))))))) - -(defun funcall (function &rest arguments) - #!+sb-doc - "Calls Function with the given Arguments." - (apply function arguments)) - -;;; multiple-value forms - -(defun values (&rest values) - #!+sb-doc - "Returns all arguments, in order, as values." - (values-list values)) - -(defun values-list (list) - #!+sb-doc - "Returns all of the elements of LIST, in order, as values." - (values-list list)) diff --git a/src/code/target-misc.lisp b/src/code/target-misc.lisp index 66d24e8..98e818a 100644 --- a/src/code/target-misc.lisp +++ b/src/code/target-misc.lisp @@ -28,12 +28,6 @@ (sb!c::byte-function-name x)) (byte-closure (sb!c::byte-function-name (byte-closure-function x))) - #!+sb-interpreter - (sb!eval:interpreted-function - (multiple-value-bind (exp closure-p dname) - (sb!eval:interpreted-function-lambda-expression x) - (declare (ignore exp closure-p)) - dname)) (t ;; funcallable-instance (%function-name (funcallable-instance-function x)))))))) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 91757e6..871cb84 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -128,15 +128,11 @@ ;;; Pull the type specifier out of a function object. (defun extract-function-type (fun) - (cond #!+sb-interpreter - ((sb!eval:interpreted-function-p fun) - (sb!eval:interpreted-function-type fun)) - (t - (typecase fun - (byte-function (byte-function-type fun)) - (byte-closure (byte-function-type (byte-closure-function fun))) - (t - (specifier-type (%function-type (%closure-function fun)))))))) + (typecase fun + (byte-function (byte-function-type fun)) + (byte-closure (byte-function-type (byte-closure-function fun))) + (t + (specifier-type (%function-type (%closure-function fun)))))) ;;;; miscellaneous interfaces diff --git a/src/code/time.lisp b/src/code/time.lisp index 4781333..9ae42fc 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -239,19 +239,13 @@ ;;; Try to compile the closure arg to %TIME if it is interpreted. (defun massage-time-function (fun) - (cond - #!+sb-interpreter - ((sb!eval:interpreted-function-p fun) - (multiple-value-bind (def env-p) (function-lambda-expression fun) - (declare (ignore def)) - (cond - (env-p - (warn "non-null environment for TIME form, forced to interpret.~@ - Compiling the entire form will produce more accurate times.") - fun) - (t - (compile nil fun))))) - (t fun))) + ;; This is just a placeholder as of the switch from IR1 interpreter + ;; to bytecode interpreter. Someday it might make sense to complain + ;; about bytecoded FUN and/or compile it to native code, so I've + ;; left the placeholder in place, but as of sbcl-0.7.0 it's not + ;; obvious how to do the right thing easily, so I haven't actually + ;; done it. -- WHN + fun) ;;; Return all the data that we want TIME to report. (defun time-get-sys-info () diff --git a/src/compiler/eval-comp.lisp b/src/compiler/eval-comp.lisp deleted file mode 100644 index 39238fb..0000000 --- a/src/compiler/eval-comp.lisp +++ /dev/null @@ -1,286 +0,0 @@ -;;;; This file represents the current state of on-going development on -;;;; compiler hooks for an interpreter that takes the compiler's IR1 of -;;;; a program. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!C") - -;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp? -(declaim (special *constants* *free-variables* *component-being-compiled* - *code-vector* *next-location* *result-fixups* - *free-functions* *source-paths* *failed-optimizations* - *seen-blocks* *seen-functions* *list-conflicts-table* - *continuation-number* *continuation-numbers* - *number-continuations* *tn-id* *tn-ids* *id-tns* - *label-ids* *label-id* *id-labels* - *compiler-error-count* *compiler-warning-count* - *compiler-style-warning-count* *compiler-note-count* - *compiler-error-bailout* - #!+sb-show *compiler-trace-output* - *last-source-context* *last-original-source* - *last-source-form* *last-format-string* *last-format-args* - *last-message-count* *check-consistency* - *all-components* *converting-for-interpreter* - *source-info* *block-compile* *current-path* - *current-component* *lexenv*)) - -;;; Translate form into the compiler's IR1 and perform environment -;;; analysis. This is sort of a combination of COMPILE-FILE, -;;; SUB-COMPILE-FILE, COMPILE-TOP-LEVEL, and COMPILE-COMPONENT. -(defun compile-for-eval (form) - (with-ir1-namespace - (let* ((*block-compile* nil) - (*lexenv* (make-null-lexenv)) - (*compiler-error-bailout* - #'(lambda () (error "fatal error, aborting evaluation"))) - (*current-path* nil) - (*last-source-context* nil) - (*last-original-source* nil) - (*last-source-form* nil) - (*last-format-string* nil) - (*last-format-args* nil) - (*last-message-count* 0) - ;; These are now bound by WITH-COMPILATION-UNIT. -- WHN 20000308 - #+nil (*compiler-error-count* 0) - #+nil (*compiler-warning-count* 0) - #+nil (*compiler-style-warning-count* 0) - #+nil (*compiler-note-count* 0) - (*source-info* (make-lisp-source-info form)) - (*converting-for-interpreter* t) - (*gensym-counter* 0) - (*warnings-p* nil) - (*failure-p* nil)) - - (clear-stuff nil) - (find-source-paths form 0) - ;; This LET comes from COMPILE-TOP-LEVEL. - ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes. - (sb!xc:with-compilation-unit () - (let ((lambdas (list (ir1-top-level form - '(original-source-start 0 0) - t)))) - (declare (list lambdas)) - (dolist (lambda lambdas) - (let* ((component - (block-component (node-block (lambda-bind lambda)))) - (*all-components* (list component))) - (local-call-analyze component))) - (multiple-value-bind (components top-components) - (find-initial-dfo lambdas) - (let ((*all-components* (append components top-components))) - (when *check-consistency* - (check-ir1-consistency *all-components*)) - ;; This DOLIST body comes from the beginning of - ;; COMPILE-COMPONENT. - (dolist (component *all-components*) - (ir1-finalize component) - (let ((*component-being-compiled* component)) - (environment-analyze component)) - (annotate-component-for-eval component)) - (when *check-consistency* - (check-ir1-consistency *all-components*)))) - (car lambdas)))))) - -;;;; annotating IR1 for interpretation - -(defstruct (lambda-eval-info (:constructor make-lambda-eval-info - (frame-size args-passed entries)) - (:copier nil)) - frame-size ; number of stack locations needed to hold locals - args-passed ; number of referenced arguments passed to lambda - entries ; a-list mapping entry nodes to stack locations - (function nil)) ; a function object corresponding to this lambda -(def!method print-object ((obj lambda-eval-info) str) - (print-unreadable-object (obj str :type t))) - -(defstruct (entry-node-info (:constructor make-entry-node-info - (st-top nlx-tag)) - (:copier nil)) - st-top ; stack top when we encounter the entry node - nlx-tag) ; tag to which to throw to get back entry node's context -(def!method print-object ((obj entry-node-info) str) - (print-unreadable-object (obj str :type t))) - -;;; Some compiler funny functions have definitions, so the interpreter -;;; can call them. These require special action to coordinate the -;;; interpreter, system call stack, and the environment. The -;;; annotation prepass marks the references to these as :UNUSED, so -;;; the interpreter doesn't try to fetch functions through these -;;; undefined symbols. -(defconstant undefined-funny-funs - '(%special-bind %special-unbind %more-arg-context %unknown-values %catch - %unwind-protect %catch-breakup %unwind-protect-breakup - %lexical-exit-breakup %continue-unwind %nlx-entry)) - -;;; Some kinds of functions are only passed as arguments to funny -;;; functions, and are never actually evaluated at run time. -(defconstant non-closed-function-kinds '(:cleanup :escape)) - -;;; This annotates continuations, lambda-vars, and lambdas. For each -;;; continuation, we cache how its destination uses its value. This -;;; only buys efficiency when the code executes more than once, but -;;; the overhead of this part of the prepass for code executed only -;;; once should be negligible. -;;; -;;; As a special case to aid interpreting local function calls, we -;;; sometimes note the continuation as :unused. This occurs when there -;;; is a local call, and there is no actual function object to call; -;;; we mark the continuation as :unused since there is nothing to push -;;; on the interpreter's stack. Normally we would see a reference to a -;;; function that we would push on the stack to later pop and apply to -;;; the arguments on the stack. To determine when we have a local call -;;; with no real function object, we look at the node to see whether -;;; it is a reference with a destination that is a :local combination -;;; whose function is the reference node's continuation. -;;; -;;; After checking for virtual local calls, we check for funny -;;; functions the compiler refers to for calling to note certain -;;; operations. These functions are undefined, and if the interpreter -;;; tried to reference the function cells of these symbols, it would -;;; get an error. We mark the continuations delivering the values of -;;; these references as :unused, so the reference never takes place. -;;; -;;; For each lambda-var, including a LAMBDA's vars and its LET's vars, -;;; we note the stack offset used to access and store that variable. -;;; Then we note the lambda with the total number of variables, so we -;;; know how big its stack frame is. Also in the lambda's info is the -;;; number of its arguments that it actually references; the -;;; interpreter never pushes or pops an unreferenced argument, so we -;;; can't just use LENGTH on LAMBDA-VARS to know how many args the -;;; caller passed. -;;; -;;; For each entry node in a lambda, we associate in the -;;; lambda-eval-info the entry node with a stack offset. Evaluation -;;; code stores the frame pointer in this slot upon processing the -;;; entry node to aid stack cleanup and correct frame manipulation -;;; when processing exit nodes. -(defun annotate-component-for-eval (component) - (do-blocks (b component) - (do-nodes (node cont b) - (let* ((dest (continuation-dest cont)) - (refp (typep node 'ref)) - (leaf (if refp (ref-leaf node)))) - (setf (continuation-info cont) - (cond ((and refp dest (typep dest 'basic-combination) - (eq (basic-combination-kind dest) :local) - (eq (basic-combination-fun dest) cont)) - :unused) - ((and leaf (typep leaf 'global-var) - (eq (global-var-kind leaf) :global-function) - (member (sb!c::global-var-name leaf) - undefined-funny-funs - :test #'eq)) - :unused) - ((and leaf (typep leaf 'clambda) - (member (functional-kind leaf) - non-closed-function-kinds)) - (aver (not (eq (functional-kind leaf) :escape))) - :unused) - (t - (typecase dest - ;; Change locations in eval.lisp that think - ;; :RETURN could occur. - ((or mv-combination creturn exit) :multiple) - (null :unused) - (t :single)))))))) - (dolist (lambda (component-lambdas component)) - (let ((locals-count 0) - (args-passed-count 0)) - (dolist (var (lambda-vars lambda)) - (setf (leaf-info var) locals-count) - (incf locals-count) - (when (leaf-refs var) (incf args-passed-count))) - (dolist (let (lambda-lets lambda)) - (dolist (var (lambda-vars let)) - (setf (leaf-info var) locals-count) - (incf locals-count))) - (let ((entries nil)) - (dolist (e (lambda-entries lambda)) - (ecase (process-entry-node-p e) - (:blow-it-off) - (:local-lexical-exit - (push (cons e (make-entry-node-info locals-count nil)) - entries) - (incf locals-count)) - (:non-local-lexical-exit - (push (cons e - (make-entry-node-info locals-count - (incf locals-count))) - entries) - (incf locals-count)))) - (setf (lambda-info lambda) - (make-lambda-eval-info locals-count - args-passed-count - entries)))))) - -(defun process-entry-node-p (entry) - (let ((entry-cleanup (entry-cleanup entry))) - (dolist (nlx (environment-nlx-info (node-environment entry)) - :local-lexical-exit) - (let ((cleanup (nlx-info-cleanup nlx))) - (when (eq entry-cleanup cleanup) - (ecase (cleanup-kind cleanup) - ((:block :tagbody) - (return :non-local-lexical-exit)) - ((:catch :unwind-protect) - (return :blow-it-off)))))))) - -;;; Sometime consider annotations to exclude processing of exit nodes -;;; when we want to do a tail-p thing. - -;;;; defining funny functions for interpreter - -#| -%listify-rest-args %more-arg %verify-argument-count %argument-count-error -%odd-key-arguments-error %unknown-key-argument-error -|# - -(defun %verify-argument-count (supplied-args defined-args) - (unless (= supplied-args defined-args) - (error "Wrong argument count, wanted ~D and got ~D." - defined-args supplied-args)) - (values)) - -;;; Use (SETF SYMBOL-FUNCTION) instead of DEFUN so that the compiler -;;; doesn't try to compile the hidden %THROW MV-CALL in the throw below as -;;; a local recursive call. -(setf (symbol-function '%throw) - #'(lambda (tag &rest args) - (throw tag (values-list args)))) - -(defun %more-arg (args index) - (nth index args)) - -(defun %listify-rest-args (ptr count) - (declare (ignore count)) - ptr) - -(defun %more-arg-values (args start count) - (values-list (subseq args start count))) - -(defun %argument-count-error (args-passed-count) - (error 'simple-program-error - :format-control "wrong number of arguments passed: ~S" - :format-arguments (list args-passed-count))) - -(defun %odd-key-arguments-error () - (error 'simple-program-error - :format-control "function called with odd number of &KEY arguments" - :format-arguments nil)) - -(defun %unknown-key-argument-error (key-arg-name) - (error 'simple-program-error - :format-control "unknown &KEY argument: ~S" - :format-arguments (list key-arg-name))) - -(defun %cleanup-point ()) - -(defun value-cell-ref (x) (value-cell-ref x)) diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp deleted file mode 100644 index 970f60a..0000000 --- a/src/compiler/eval.lisp +++ /dev/null @@ -1,1136 +0,0 @@ -;;;; This file contains the IR1 interpreter. We first convert to the -;;;; compiler's IR1, then interpret that. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB!EVAL") - -;;;; interpreter stack - -(defvar *interpreted-function-cache-minimum-size* 25 - #!+sb-doc - "If the interpreted function cache has more functions than this come GC time, - then attempt to prune it according to - *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.") - -(defvar *interpreted-function-cache-threshold* 3 - #!+sb-doc - "If an interpreted function goes uncalled for more than this many GCs, then - it is eligible for flushing from the cache.") - -(declaim (type (and fixnum unsigned-byte) - *interpreted-function-cache-minimum-size* - *interpreted-function-cache-threshold*)) - -;;; The list of INTERPRETED-FUNCTIONs that have translated definitions. -(defvar *interpreted-function-cache* nil) -(declaim (type list *interpreted-function-cache*)) - -;;;; eval stack stuff - -;;; Setting this causes the stack operations to dump a trace. -#!+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 -;;; location. -(defun eval-stack-push (value) - (let ((len (length (the simple-vector *eval-stack*)))) - (when (= len *eval-stack-top*) - #!+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*)) - #!+sb-show (when *eval-stack-trace* (format t "pushing ~D.~%" top)) - (incf *eval-stack-top*) - (setf (svref *eval-stack* top) value))) - -;;; 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))) - #!+sb-show (when *eval-stack-trace* - (format t "popping ~D --> ~S.~%" new-top value)) - (setf *eval-stack-top* new-top) - value)) - -;;; 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) - #!+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))) - #!+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 antithesis of EVAL-STACK-EXTEND -(defun eval-stack-shrink (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-reset-top (ptr) - #!+sb-show (when *eval-stack-trace* - (format t "setting top to ~D.~%" ptr)) - (setf *eval-stack-top* ptr)) - -;;; 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) - `(svref *eval-stack* (+ ,fp ,offset))) - -;;;; interpreted functions - -;;; 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. -(defun make-interpreted-function (lambda) - (let ((res (%make-interpreted-function :lambda lambda - :arglist (second lambda)))) - (setf (funcallable-instance-function res) - #'(instance-lambda (&rest args) - (let ((fun (interpreted-function-definition res)) - (args (cons (length args) args))) - (setf (interpreted-function-gcs res) 0) - (internal-apply (or fun (convert-interpreted-fun res)) - args '#())))) - res)) - -;;; Eval a FUNCTION form, grab the definition and stick it in. -(defun convert-interpreted-fun (fun) - (declare (type interpreted-function fun)) - (let* ((new (interpreted-function-definition - (internal-eval `#',(interpreted-function-lambda fun))))) - (setf (interpreted-function-definition fun) new) - (setf (interpreted-function-converted-once fun) t) - (let ((name (interpreted-function-%name fun))) - (setf (sb!c::leaf-name new) name) - (setf (sb!c::leaf-name (sb!c::main-entry - (sb!c::functional-entry-function new))) - name)) - (push fun *interpreted-function-cache*) - new)) - -;;; Get the CLAMBDA for the XEP, then look at the inline expansion info in -;;; the real function. -(defun interpreted-function-lambda-expression (x) - (let ((lambda (interpreted-function-lambda x))) - (if lambda - (values lambda nil (interpreted-function-%name x)) - (let ((fun (sb!c::functional-entry-function - (interpreted-function-definition x)))) - (values (sb!c::functional-inline-expansion fun) - (if (let ((env (sb!c::functional-lexenv fun))) - (or (sb!c::lexenv-functions env) - (sb!c::lexenv-variables env) - (sb!c::lexenv-blocks env) - (sb!c::lexenv-tags env))) - t nil) - (or (interpreted-function-%name x) - (sb!c::component-name - (sb!c::block-component - (sb!c::node-block - (sb!c::lambda-bind (sb!c::main-entry fun))))))))))) - -;;; Return a FUNCTION-TYPE describing an eval function. We just grab the -;;; LEAF-TYPE of the definition, converting the definition if not currently -;;; cached. -(defvar *already-looking-for-type-of* nil) -(defun interpreted-function-type (fun) - (if (member fun *already-looking-for-type-of*) - (specifier-type 'function) - (let* ((*already-looking-for-type-of* - (cons fun *already-looking-for-type-of*)) - (def (or (interpreted-function-definition fun) - (sb!sys:without-gcing - (convert-interpreted-fun fun) - (interpreted-function-definition fun))))) - (sb!c::leaf-type (sb!c::functional-entry-function def))))) - -(defun interpreted-function-name (x) - (multiple-value-bind (ig1 ig2 res) (interpreted-function-lambda-expression x) - (declare (ignore ig1 ig2)) - res)) -(defun (setf interpreted-function-name) (val x) - (let ((def (interpreted-function-definition x))) - (when def - (setf (sb!c::leaf-name def) val) - (setf (sb!c::leaf-name (sb!c::main-entry (sb!c::functional-entry-function - def))) - val)) - (setf (interpreted-function-%name x) val))) - -(defun interpreter-gc-hook () - ;; Clear the unused portion of the eval stack. - (let ((len (length (the simple-vector *eval-stack*)))) - (do ((i *eval-stack-top* (1+ i))) - ((= i len)) - (setf (svref *eval-stack* i) nil))) - - ;; KLUDGE: I'd like to get rid of this, since it adds complexity and causes - ;; confusion. (It's not just academic that it causes confusion. When working - ;; on the original cross-compiler, I ran across what looked - ;; as though it might be a subtle writing-to-the-host-SBCL-compiler-data bug - ;; in my cross-compiler code, which turned out to be just a case of compiler - ;; warnings coming from recompilation of a flushed-from-the-cache interpreted - ;; function. Since it took me a long while to realize how many things the - ;; problem depended on (since it was tied up with magic numbers of GC cycles, - ;; egads!) I blew over a day trying to isolate the problem in a small test - ;; case. - ;; - ;; The cache-flushing seems to be motivated by efficiency concerns, which - ;; seem misplaced when the user chooses to use the interpreter. However, it - ;; also interacts with SAVE, and I veered off from deleting it wholesale when - ;; I noticed that. After the whole system is working, though, I'd like to - ;; revisit this decision. -- WHN 19990713 - (let ((num (- (length *interpreted-function-cache*) - *interpreted-function-cache-minimum-size*))) - (when (plusp num) - (setq *interpreted-function-cache* - (delete-if #'(lambda (x) - (when (>= (interpreted-function-gcs x) - *interpreted-function-cache-threshold*) - (setf (interpreted-function-definition x) nil) - t)) - *interpreted-function-cache* - :count num)))) - (dolist (fun *interpreted-function-cache*) - (incf (interpreted-function-gcs fun)))) -(pushnew 'interpreter-gc-hook sb!ext:*before-gc-hooks*) - -;;; Clear all entries in the eval function cache. This allows the internal -;;; representation of the functions to be reclaimed, and also lazily forces -;;; macroexpansions to be recomputed. -(defun flush-interpreted-function-cache () - (dolist (fun *interpreted-function-cache*) - (setf (interpreted-function-definition fun) nil)) - (setq *interpreted-function-cache* ())) - -;;;; INTERNAL-APPLY-LOOP macros - -;;;; These macros are intimately related to INTERNAL-APPLY-LOOP. They assume -;;;; variables established by this function, and they assume they can return -;;;; from a block by that name. This is sleazy, but we justify it as follows: -;;;; They are so specialized in use, and their invocation became lengthy, that -;;;; we allowed them to slime some access to things in their expanding -;;;; environment. These macros don't really extend our Lisp syntax, but they do -;;;; provide some template expansion service; it is these cleaner circumstance -;;;; that require a more rigid programming style. -;;;; -;;;; Since these are macros expanded almost solely for COMBINATION nodes, -;;;; they cascade from the end of this logical page to the beginning here. -;;;; Therefore, it is best you start looking at them from the end of this -;;;; section, backwards from normal scanning mode for Lisp code. - -;;; This runs a function on some arguments from the stack. If the combination -;;; occurs in a tail recursive position, then we do the call such that we -;;; return from tail-p-function with whatever values the call produces. With a -;;; :local call, we have to restore the stack to its previous frame before -;;; doing the call. The :full call mechanism does this for us. If it is NOT a -;;; tail recursive call, and we're in a multiple value context, then then push -;;; a list of the returned values. Do the same thing if we're in a :return -;;; context. Push a single value, without listifying it, for a :single value -;;; context. Otherwise, just call for side effect. -;;; -;;; Node is the combination node, and cont is its continuation. Frame-ptr -;;; is the current frame pointer, and closure is the current environment for -;;; closure variables. Call-type is either :full or :local, and when it is -;;; local, lambda is the IR1 lambda to apply. -;;; -;;; This assumes the following variables are present: node, cont, frame-ptr, -;;; and closure. It also assumes a block named internal-apply-loop. -;;; -;;; FIXME: used only in this file, needn't be in runtime -;;; FIXME: down with DO-FOO names for non-iteration constructs! -(defmacro do-combination (call-type lambda mv-or-normal) - (let* ((args (gensym)) - (calling-closure (gensym)) - (invoke-fun (ecase mv-or-normal - (:mv-call 'mv-internal-invoke) - (:normal 'internal-invoke))) - (args-form (ecase mv-or-normal - (:mv-call - `(mv-eval-stack-args - (length (sb!c::mv-combination-args node)))) - (:normal - `(eval-stack-args (sb!c:lambda-eval-info-args-passed - (sb!c::lambda-info ,lambda)))))) - (call-form (ecase call-type - (:full `(,invoke-fun - (length (sb!c::basic-combination-args node)))) - (:local `(internal-apply - ,lambda ,args-form - (compute-closure node ,lambda frame-ptr - closure) - nil)))) - (tailp-call-form - (ecase call-type - (:full `(return-from - internal-apply-loop - ;; INVOKE-FUN takes care of the stack itself. - (,invoke-fun (length (sb!c::basic-combination-args node)) - frame-ptr))) - (:local `(let ((,args ,args-form) - (,calling-closure - (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-reset-top frame-ptr) - (return-from - internal-apply-loop - (internal-apply ,lambda ,args ,calling-closure - nil))))))) - `(cond ((sb!c::node-tail-p node) - ,tailp-call-form) - (t - (ecase (sb!c::continuation-info cont) - ((:multiple :return) - (eval-stack-push (multiple-value-list ,call-form))) - (:single - (eval-stack-push ,call-form)) - (:unused ,call-form)))))) - -;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this -;;; by setting set-block-p for later loop iteration maintenance. -;;; -;;; FIXME: used only in this file, needn't be in runtime -(defmacro set-block (exp) - `(progn - (setf block ,exp) - (setf set-block-p t))) - -;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate -;;; over a new block's nodes. Block-exp is optional because sometimes we have -;;; already set block, and we only need to bring the others into agreement. -;;; If we already set block, then clear the variable that announces this, -;;; set-block-p. -;;; -;;; FIXME: used only in this file, needn't be in runtime -(defmacro change-blocks (&optional block-exp) - `(progn - ,(if block-exp - `(setf block ,block-exp) - `(setf set-block-p nil)) - (setf node (sb!c::continuation-next (sb!c::block-start block))) - (setf last-cont (sb!c::node-cont (sb!c::block-last block))))) - -;;; 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. -#!+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~%" - name args (sb!c::cont-num (sb!c::node-cont node))))) - -;;; This implements the intention of the virtual function name. This is a -;;; macro because some of these actions must occur without a function call. -;;; For example, calling a dispatch function to implement special binding would -;;; be a no-op because returning from that function would cause the system to -;;; undo any special bindings it established. -;;; -;;; NOTE: update SB!C:ANNOTATE-COMPONENT-FOR-EVAL and/or -;;; sb!c::undefined-funny-funs if you add or remove branches in this routine. -;;; -;;; This assumes the following variables are present: node, cont, frame-ptr, -;;; args, closure, block, and last-cont. It also assumes a block named -;;; internal-apply-loop. -;;; -;;; FIXME: used only in this file, needn't be in runtime -;;; FIXME: down with DO-FOO names for non-iteration constructs! -(defmacro do-funny-function (funny-fun-name) - (let ((name (gensym))) - `(let ((,name ,funny-fun-name)) - (ecase ,name - (sb!c::%special-bind - (let ((value (eval-stack-pop)) - (global-var (eval-stack-pop))) - #!+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)))) - (sb!c::%special-unbind - ;; Throw away arg telling me which special, and tell the dynamic - ;; binding mechanism to unbind one variable. - (eval-stack-pop) - #!+sb-show (maybe-trace-funny-fun node ,name) - (sb!sys:%primitive sb!c:unbind)) - (sb!c::%catch - (let* ((tag (eval-stack-pop)) - (nlx-info (eval-stack-pop)) - (fell-through-p nil) - ;; Ultimately THROW and CATCH will fix the interpreter's stack - ;; since this is necessary for compiled CATCH's and those in - ;; the initial top level function. - (stack-top *eval-stack-top*) - (values - (multiple-value-list - (catch 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)) - (setf fell-through-p t))))) - (cond (fell-through-p - ;; We got here because we just saw the SB!C::%CATCH-BREAKUP - ;; funny function inside the above recursive call to - ;; INTERNAL-APPLY-LOOP. Therefore, we just received and - ;; stored the current state of evaluation for falling - ;; through. - ) - (t - ;; Fix up the interpreter's stack after having thrown here. - ;; We won't need to do this in the final implementation. - (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. - (ecase (sb!c::continuation-info - (sb!c::nlx-info-continuation nlx-info)) - (:single - (eval-stack-push (car values))) - ((:multiple :return) - (eval-stack-push values)) - (:unused)) - ;; We want to continue with the code after the CATCH body. - ;; The non-local-exit info tells us where this is, but we - ;; know that block only contains a call to the funny - ;; function SB!C::%NLX-ENTRY, which simply is a place holder - ;; for the compiler IR1. We want to skip the target block - ;; entirely, so we say it is the block we're in now and say - ;; the current cont is the last-cont. This makes the COND - ;; at the end of INTERNAL-APPLY-LOOP do the right thing. - (setf block (sb!c::nlx-info-target nlx-info)) - (setf cont last-cont))))) - (sb!c::%unwind-protect - ;; Cleanup function not pushed due to special-case :UNUSED - ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL. - (let* ((nlx-info (eval-stack-pop)) - (fell-through-p nil) - (stack-top *eval-stack-top*)) - (unwind-protect - (progn - #!+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)) - (setf fell-through-p t)) - (cond (fell-through-p - ;; We got here because we just saw the - ;; SB!C::%UNWIND-PROTECT-BREAKUP funny function inside the - ;; above recursive call to INTERNAL-APPLY-LOOP. - ;; Therefore, we just received and stored the current - ;; state of evaluation for falling through. - ) - (t - ;; Fix up the interpreter's stack after having thrown - ;; here. We won't need to do this in the final - ;; implementation. - (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)) - (let ((node (sb!c::continuation-next - (sb!c::block-start - (car (sb!c::block-succ - (sb!c::nlx-info-target nlx-info))))))) - (internal-apply-loop node frame-ptr lambda args - closure))))))) - ((sb!c::%catch-breakup - sb!c::%unwind-protect-breakup - sb!c::%continue-unwind) - ;; This shows up when we locally exit a CATCH body -- fell through. - ;; 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. - #!+sb-show (maybe-trace-funny-fun node ,name) - (return-from internal-apply-loop - (values block node cont last-cont))) - (sb!c::%nlx-entry - #!+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. - ;; Do nothing since sb!c::%unwind-protect does it all when - ;; it catches a THROW. - ) - (sb!c::%more-arg-context - (let* ((fixed-arg-count (1+ (eval-stack-pop))) - ;; Add 1 to actual fixed count for extra arg expected by - ;; external entry points (XEP) which some IR1 lambdas have. - ;; The extra arg is the number of arguments for arg count - ;; 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))) - #!+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 - (error "SB!C::%UNKNOWN-VALUES should never be in interpreter's IR1.")) - (sb!c::%lexical-exit-breakup - ;; We see this whenever we locally exit the extent of a lexical - ;; target. That is, we are truly locally exiting an extent we could - ;; 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. - #!+sb-show (maybe-trace-funny-fun node ,name) - ;; Discard the NLX-INFO arg... - (eval-stack-pop) - (return-from internal-apply-loop - (values :fell-through block node cont last-cont))))))) - -;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP -;;; sees. Type is either :mv-call or :normal. Node is the combination node, -;;; and cont is its continuation. Frame-ptr is the current frame pointer, and -;;; closure is the current environment for closure variables. -;;; -;;; Most of the real work is done by DO-COMBINATION. This first determines if -;;; the combination node describes a :full call which DO-COMBINATION directly -;;; handles. If the call is :local, then we either invoke an IR1 lambda, or we -;;; just bind some LET variables. If the call is :local, and type is :mv-call, -;;; then we can only be binding multiple values. Otherwise, the combination -;;; node describes a function known to the compiler, but this may be a funny -;;; function that actually isn't ever defined. We either take some action for -;;; the funny function or do a :full call on the known true function, but the -;;; interpreter doesn't do optimizing stuff for functions known to the -;;; compiler. -;;; -;;; This assumes the following variables are present: node, cont, frame-ptr, -;;; and closure. It also assumes a block named internal-apply-loop. -;;; -;;; FIXME: used only in this file, needn't be in runtime -(defmacro combination-node (type) - (let* ((kind (gensym)) - (fun (gensym)) - (lambda (gensym)) - (letp (gensym)) - (letp-bind (ecase type - (:mv-call nil) - (:normal - `((,letp (eq (sb!c::functional-kind ,lambda) :let)))))) - (local-branch - (ecase type - (:mv-call - `(store-mv-let-vars ,lambda frame-ptr - (length (sb!c::mv-combination-args node)))) - (:normal - `(if ,letp - (store-let-vars ,lambda frame-ptr) - (do-combination :local ,lambda ,type)))))) - `(let ((,kind (sb!c::basic-combination-kind node)) - (,fun (sb!c::basic-combination-fun node))) - (cond ((member ,kind '(:full :error)) - (do-combination :full nil ,type)) - ((eq ,kind :local) - (let* ((,lambda (sb!c::ref-leaf (sb!c::continuation-use ,fun))) - ,@letp-bind) - ,local-branch)) - ((eq (sb!c::continuation-info ,fun) :unused) - (aver (typep ,kind 'sb!c::function-info)) - (do-funny-function (sb!c::continuation-function-name ,fun))) - (t - (aver (typep ,kind 'sb!c::function-info)) - (do-combination :full nil ,type)))))) - -;;;; INTERNAL-EVAL - -;;; Evaluate an arbitary form. We convert the form, then call internal -;;; APPLY on it. If *ALREADY-EVALED-THIS* is true, then we bind it to -;;; NIL around the apply to limit the inhibition to the lexical scope -;;; of the EVAL-WHEN. -#!+sb-interpreter -(defun sb!eval:internal-eval (form) - (let ((res (sb!c:compile-for-eval form))) - (if *already-evaled-this* - (let ((*already-evaled-this* nil)) - (internal-apply res nil '#())) - (internal-apply res nil '#())))) - -;;; This passes on a node's value appropriately, possibly returning from -;;; function to do so. When we are tail-p, don't push the value, return it on -;;; the system's actual call stack; when we blow out of function this way, we -;;; must return the interpreter's stack to the its state before this call to -;;; function. When we're in a multiple value context or heading for a return -;;; node, we push a list of the value for easier handling later. Otherwise, -;;; just push the value on the interpreter's stack. -;;; -;;; 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-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))))) - -;;; 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.) -(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))) - (do ((vars (sb!c::lambda-vars lambda) (cdr vars)) - (args args)) - ((null vars)) - (let ((var (car vars))) - (cond ((sb!c::leaf-refs var) - (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var)) - (if (sb!c::lambda-var-indirect var) - (sb!c::make-value-cell (pop args)) - (pop args)))) - (ignore-unused (pop args))))) - (internal-apply-loop (sb!c::lambda-bind lambda) frame-ptr lambda args - closure))) - -;;; This does the work of INTERNAL-APPLY. This also calls itself -;;; recursively for certain language features, such as CATCH. First is -;;; the node at which to start interpreting. FRAME-PTR is the current -;;; frame pointer for accessing local variables. LAMBDA is the IR1 -;;; lambda from which comes the nodes a given call to this function -;;; processes, and CLOSURE is the environment for interpreting LAMBDA. -;;; ARGS is the argument list for the lambda given to INTERNAL-APPLY, -;;; and we have to carry it around with us in case of &more-arg or -;;; &rest-arg processing which is represented explicitly in the -;;; compiler's IR1. -;;; -;;; KLUDGE: Due to having a truly tail recursive interpreter, some of -;;; the branches handling a given node need to RETURN-FROM this -;;; routine. Also, some calls this makes to do work for it must occur -;;; in tail recursive positions. Because of this required access to -;;; this function lexical environment and calling positions, we often -;;; are unable to break off logical chunks of code into functions. We -;;; have written macros intended solely for use in this routine, and -;;; due to all the local stuff they need to access and length complex -;;; calls, we have written them to sleazily access locals from this -;;; routine. In addition to assuming a block named internal-apply-loop -;;; exists, they set and reference the following variables: NODE, -;;; CONT, FRAME-PTR, CLOSURE, BLOCK, LAST-CONT, and SET-BLOCK-P. -;;; FIXME: Perhaps this kludge could go away if we convert to a -;;; compiler-only implementation? -(defun internal-apply-loop (first frame-ptr lambda args closure) - ;; FIXME: This will cause source code location information to be compiled - ;; into the executable, which will probably cause problems for users running - ;; without the sources and/or without the build-the-system readtable. - (declare (optimize (debug 2))) - (let* ((block (sb!c::node-block first)) - (last-cont (sb!c::node-cont (sb!c::block-last block))) - (node first) - (set-block-p nil)) - (loop - (let ((cont (sb!c::node-cont node))) - (etypecase node - (sb!c::ref - #!+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 - #!+sb-show (maybe-trace-nodes node) - (combination-node :normal)) - (sb!c::cif - #!+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 - #!+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 - #!+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 - #!+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. - (setf (eval-stack-local frame-ptr - (sb!c:entry-node-info-st-top info)) - *eval-stack-top*) - (let ((tag (sb!c:entry-node-info-nlx-tag info))) - (when tag - ;; Non-local lexical exit (someone closed over a - ;; GO tag or BLOCK name). - (let ((unique-tag (cons nil nil)) - values) - (setf (eval-stack-local frame-ptr tag) unique-tag) - (if (eq cont last-cont) - (change-blocks (car (sb!c::block-succ block))) - (setf node (sb!c::continuation-next cont))) - (loop - (multiple-value-setq (values block node cont last-cont) - (catch unique-tag - (internal-apply-loop node frame-ptr - lambda args closure))) - - (when (eq values :fell-through) - ;; We hit a %LEXICAL-EXIT-BREAKUP. - ;; Interpreting state is set with MV-SETQ above. - ;; Just get out of this branch and go on. - (return)) - - (unless (eq values :non-local-go) - ;; We know we're non-locally exiting from a - ;; BLOCK with values (saw a RETURN-FROM). - (ecase (sb!c::continuation-info cont) - (:single - (eval-stack-push (car values))) - ((:multiple :return) - (eval-stack-push values)) - (:unused))) - ;; Start interpreting again at the target, skipping - ;; the %NLX-ENTRY block. - (setf node - (sb!c::continuation-next - (sb!c::block-start - (car (sb!c::block-succ block)))))))))))) - (sb!c::exit - #!+sb-show (maybe-trace-nodes node) - (let* ((incoming-values (sb!c::exit-value node)) - (values (if incoming-values (eval-stack-pop)))) - (cond - ((eq (sb!c::lambda-environment lambda) - (sb!c::block-environment - (sb!c::node-block (sb!c::exit-entry node)))) - ;; Local exit. - ;; Fixup stack top and massage values for destination. - (eval-stack-reset-top - (eval-stack-local frame-ptr - (sb!c:entry-node-info-st-top - (cdr (assoc (sb!c::exit-entry node) - (sb!c:lambda-eval-info-entries - (sb!c::lambda-info lambda))))))) - (ecase (sb!c::continuation-info cont) - (:single - (aver incoming-values) - (eval-stack-push (car values))) - ((:multiple :return) - (aver incoming-values) - (eval-stack-push values)) - (:unused))) - (t - (let ((info (sb!c::find-nlx-info (sb!c::exit-entry node) - cont))) - (throw - (svref closure - (position info - (sb!c::environment-closure - (sb!c::node-environment node)) - :test #'eq)) - (if incoming-values - (values values (sb!c::nlx-info-target info) nil cont) - (values :non-local-go (sb!c::nlx-info-target info))))))))) - (sb!c::creturn - #!+sb-show (maybe-trace-nodes node) - (let ((values (eval-stack-pop))) - (eval-stack-reset-top frame-ptr) - (return-from internal-apply-loop (values-list values)))) - (sb!c::mv-combination - #!+sb-show (maybe-trace-nodes node) - (combination-node :mv-call))) - ;; See function doc below. - (reference-this-var-to-keep-it-alive node) - (reference-this-var-to-keep-it-alive frame-ptr) - (reference-this-var-to-keep-it-alive closure) - (cond ((not (eq cont last-cont)) - (setf node (sb!c::continuation-next cont))) - ;; Currently only the last node in a block causes this loop to - ;; change blocks, so we never just go to the next node when - ;; the current node's branch tried to change blocks. - (set-block-p - (change-blocks)) - (t - ;; CIF nodes set the block for us, but other last - ;; nodes do not. - (change-blocks (car (sb!c::block-succ block))))))))) - -;;; This function allows a reference to a variable that the compiler cannot -;;; easily eliminate as unnecessary. We use this at the end of the node -;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a -;;; valid value. Each node branch tends to reference it at the beginning, -;;; and then there is no reference but a set at the end; the compiler then -;;; kills the variable between the reference in the dispatch branch and when -;;; we set it at the end. The problem is that most error will occur in the -;;; interpreter within one of these node dispatch branches. -(defun reference-this-var-to-keep-it-alive (node) - node) - -;;; This sets a SB!C::CSET node's var to value, returning value. When -;;; var is local, we have to compare its home environment to the -;;; current one, node's environment. If they're the same, we check to -;;; see whether the var is indirect, and store the value on the stack -;;; or in the value cell as appropriate. Otherwise, var is a closure -;;; variable, and since we're setting it, we know its location -;;; contains an indirect value object. -(defun set-leaf-value (node frame-ptr closure value) - (let ((var (sb!c::set-var node))) - (etypecase var - (sb!c::lambda-var - (set-leaf-value-lambda-var node var frame-ptr closure value)) - (sb!c::global-var - (setf (symbol-value (sb!c::global-var-name var)) value))))) - -;;; This does SET-LEAF-VALUE for a LAMBDA-VAR leaf. The debugger tools' -;;; internals use this also to set interpreted local variables. -(defun set-leaf-value-lambda-var (node var frame-ptr closure value) - ;; Note: We avoid trying to set a lexical variable with no refs - ;; because the compiler deletes such variables. - (when (sb!c::leaf-refs var) - (let ((env (sb!c::node-environment node))) - (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var)) - env)) - (sb!c::value-cell-set - (svref closure - (position var (sb!c::environment-closure env) - :test #'eq)) - value)) - ((sb!c::lambda-var-indirect var) - (sb!c::value-cell-set - (eval-stack-local frame-ptr (sb!c::lambda-var-info var)) - value)) - (t - (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var)) - value)))))) - -;;; This figures out how to return a value for a ref node. LEAF is the -;;; ref's structure that tells us about the value, and it is one of -;;; the following types: -;;; constant -- It knows its own value. -;;; global-var -- It's either a value or function reference. Get it right. -;;; local-var -- This may on the stack or in the current closure, the -;;; environment for the lambda INTERNAL-APPLY is currently -;;; executing. If the leaf's home environment is the same -;;; as the node's home environment, then the value is on the -;;; stack, else it's in the closure since it came from another -;;; environment. Whether the var comes from the stack or the -;;; closure, it could have come from a closure, and it could -;;; have been closed over for setting. When this happens, the -;;; actual value is stored in an indirection object, so -;;; indirect. See COMPUTE-CLOSURE for the description of -;;; the structure of the closure argument to this function. -;;; functional -- This is a reference to an interpreted function that may -;;; be passed or called anywhere. We return a real function -;;; that calls INTERNAL-APPLY, closing over the leaf. We also -;;; have to compute a closure, running environment, for the -;;; lambda in case it references stuff in the current -;;; environment. If the closure is empty and there is no -;;; functional environment, then we use -;;; MAKE-INTERPRETED-FUNCTION to make a cached translation. -;;; Since it is too late to lazily convert, we set up the -;;; INTERPRETED-FUNCTION to be already converted. -(defun leaf-value (node frame-ptr closure) - (let ((leaf (sb!c::ref-leaf node))) - (etypecase leaf - (sb!c::constant - (sb!c::constant-value leaf)) - (sb!c::global-var - (locally (declare (optimize (safety 1))) - (if (eq (sb!c::global-var-kind leaf) :global-function) - (let ((name (sb!c::global-var-name leaf))) - (if (symbolp name) - (symbol-function name) - (fdefinition name))) - (symbol-value (sb!c::global-var-name leaf))))) - (sb!c::lambda-var - (leaf-value-lambda-var node leaf frame-ptr closure)) - (sb!c::functional - (let* ((calling-closure (compute-closure node leaf frame-ptr closure)) - (real-fun (sb!c::functional-entry-function leaf)) - (arg-doc (sb!c::functional-arg-documentation real-fun))) - (cond ((sb!c:lambda-eval-info-function (sb!c::leaf-info leaf))) - ((and (zerop (length calling-closure)) - (null (sb!c::lexenv-functions - (sb!c::functional-lexenv real-fun)))) - (let ((res (make-interpreted-function - (sb!c::functional-inline-expansion real-fun)))) - (push res *interpreted-function-cache*) - (setf (interpreted-function-definition res) leaf) - (setf (interpreted-function-converted-once res) t) - (setf (interpreted-function-arglist res) arg-doc) - (setf (interpreted-function-%name res) - (sb!c::leaf-name real-fun)) - (setf (sb!c:lambda-eval-info-function - (sb!c::leaf-info leaf)) res) - res)) - (t - (let ((res (%make-interpreted-function - :definition leaf - :%name (sb!c::leaf-name real-fun) - :arglist arg-doc - :closure calling-closure))) - (setf (funcallable-instance-function res) - #'(instance-lambda (&rest args) - (declare (list args)) - (internal-apply - (interpreted-function-definition res) - (cons (length args) args) - (interpreted-function-closure res)))) - res)))))))) - -;;; This does LEAF-VALUE for a lambda-var leaf. The debugger tools' internals -;;; uses this also to reference interpreted local variables. -(defun leaf-value-lambda-var (node leaf frame-ptr closure) - (let* ((env (sb!c::node-environment node)) - (temp - (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home leaf)) - env) - (eval-stack-local frame-ptr (sb!c::lambda-var-info leaf)) - (svref closure - (position leaf (sb!c::environment-closure env) - :test #'eq))))) - (if (sb!c::lambda-var-indirect leaf) - (sb!c::value-cell-ref temp) - temp))) - -;;; Compute a closure for a local call and for returned call'able -;;; closure objects. Sometimes the closure is a SIMPLE-VECTOR of no -;;; elements. NODE is either a reference node or a combination node. -;;; LEAF is either the leaf of the reference node or the lambda to -;;; internally apply for the combination node. FRAME-PTR is the -;;; current frame pointer for fetching current values to store in the -;;; closure. CLOSURE is the current closure, the closed-over -;;; environment of the currently interpreting LAMBDA. -;;; -;;; A computed closure is a vector corresponding to the list of -;;; closure variables described in an environment. The position of a -;;; lambda-var in this closure list is the index into the closure -;;; vector of values. -(defun compute-closure (node leaf frame-ptr closure) - (let* ((current-env (sb!c::node-environment node)) - (current-closure-vars (sb!c::environment-closure current-env)) - ;; FUNCTIONAL-ENV is the environment description for leaf, - ;; the lambda for which we're computing a closure. This - ;; environment describes which of lambda's vars we find in - ;; lambda's closure when it's running, versus finding them on - ;; the stack. - (functional-env (sb!c::lambda-environment leaf)) - (functional-closure-vars (sb!c::environment-closure functional-env)) - (functional-closure (make-array (length functional-closure-vars)))) - ;; For each lambda-var VAR in the functional environment's closure - ;; list, if the VAR's home environment is the current environment, - ;; then get a value off the stack and store it in the closure - ;; we're computing. Otherwise VAR's value comes from somewhere - ;; else, but we have it in our current closure, the environment - ;; we're running in as we compute this new closure. Find this - ;; value the same way we do in LEAF-VALUE, by finding VAR's - ;; position in the current environment's description of the - ;; current closure. - (do ((vars functional-closure-vars (cdr vars)) - (i 0 (1+ i))) - ((null vars)) - (let ((ele (car vars))) - (setf (svref functional-closure i) - (etypecase ele - (sb!c::lambda-var - (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home ele)) - current-env) - (eval-stack-local frame-ptr (sb!c::lambda-var-info ele)) - (svref closure - (position ele current-closure-vars - :test #'eq)))) - (sb!c::nlx-info - (if (eq (sb!c::block-environment (sb!c::nlx-info-target ele)) - current-env) - (eval-stack-local - frame-ptr - (sb!c:entry-node-info-nlx-tag - (cdr (assoc ;; entry node for non-local extent - (sb!c::cleanup-mess-up - (sb!c::nlx-info-cleanup ele)) - (sb!c::lambda-eval-info-entries - (sb!c::lambda-info - ;; the lambda INTERNAL-APPLY-LOOP tosses around - (sb!c::environment-function - (sb!c::node-environment node)))))))) - (svref closure - (position ele current-closure-vars - :test #'eq)))))))) - functional-closure)) - -;;; INTERNAL-APPLY uses this to invoke a function from the -;;; interpreter's stack on some arguments also taken from the stack. -;;; When tail-p is non-nil, control does not return to INTERNAL-APPLY -;;; to further interpret the current IR1 lambda, so INTERNAL-INVOKE -;;; must clean up the current interpreter's stack frame. -(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-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. - (fun (car (eval-stack-pop)))) - (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 -;;; stack. This removes them from the stack. -(defun eval-stack-args (arg-count) - (let ((args nil)) - (dotimes (i arg-count args) - (push (eval-stack-pop) args)))) - -;;; This assumes the top count elements on interpreter's stack are -;;; lists. This returns a single list with all the elements from these -;;; lists. -(defun mv-eval-stack-args (count) - (if (= count 1) - (eval-stack-pop) - (let ((last (eval-stack-pop))) - (dotimes (i (1- count)) - (let ((next (eval-stack-pop))) - (setf last - (if next (nconc next last) last)))) - last))) - -;;; This stores lambda's vars, stack locals, from values popped off the stack. -;;; When a var has no references, the compiler computes IR1 such that the -;;; continuation delivering the value for the unreference var appears unused. -;;; Because of this, the interpreter drops the value on the floor instead of -;;; saving it on the stack for binding, so we only pop a value when the var has -;;; some reference. INTERNAL-APPLY uses this for sb!c::combination nodes -;;; representing LET's. -;;; -;;; When storing the local, if it is indirect, then someone closes over it for -;;; setting instead of just for referencing. We then store an indirection cell -;;; with the value, and the referencing code for locals knows how to get the -;;; actual value. -(defun store-let-vars (lambda frame-ptr) - (let* ((vars (sb!c::lambda-vars lambda)) - (args (eval-stack-args (count-if #'sb!c::leaf-refs vars)))) - (declare (list vars args)) - (dolist (v vars) - (when (sb!c::leaf-refs v) - (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v)) - (if (sb!c::lambda-var-indirect v) - (sb!c::make-value-cell (pop args)) - (pop args))))))) - -;;; This is similar to STORE-LET-VARS, but the values for the locals -;;; appear on the stack in a list due to forms that delivered multiple -;;; values to this lambda/let. Unlike STORE-LET-VARS, there is no -;;; control over the delivery of a value for an unreferenced var, so -;;; we drop the corresponding value on the floor when no one -;;; references it. INTERNAL-APPLY uses this for sb!c::mv-combination -;;; nodes representing LET's. -(defun store-mv-let-vars (lambda frame-ptr count) - (aver (= count 1)) - (let ((args (eval-stack-pop))) - (dolist (v (sb!c::lambda-vars lambda)) - (if (sb!c::leaf-refs v) - (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v)) - (if (sb!c::lambda-var-indirect v) - (sb!c::make-value-cell (pop args)) - (pop args))) - (pop args))))) - -#| -;;; This stores lambda's vars, stack locals, from multiple values stored on the -;;; top of the stack in a list. Since these values arrived multiply, there is -;;; no control over the delivery of each value for an unreferenced var, so -;;; unlike STORE-LET-VARS, we have values for variables never used. We drop -;;; the value corresponding to an unreferenced var on the floor. -;;; INTERNAL-APPLY uses this for sb!c::mv-combination nodes representing LET's. -;;; -;;; IR1 represents variables bound from multiple values in a list in the -;;; opposite order of the values list. We use STORE-MV-LET-VARS-AUX to recurse -;;; down the vars list until we bottom out, storing values on the way back up -;;; the recursion. You must do this instead of NREVERSE'ing the args list, so -;;; when we run out of values, we store nil's in the correct lambda-vars. -(defun store-mv-let-vars (lambda frame-ptr count) - (aver (= count 1)) - (print (sb!c::lambda-vars lambda)) - (store-mv-let-vars-aux frame-ptr (sb!c::lambda-vars lambda) (eval-stack-pop))) -(defun store-mv-let-vars-aux (frame-ptr vars args) - (if vars - (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args)) - (v (car vars))) - (when (sb!c::leaf-refs v) - (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v)) - (if (sb!c::lambda-var-indirect v) - (sb!c::make-value-cell (car remaining-args)) - (car remaining-args)))) - (cdr remaining-args)) - args)) -|# diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index dc21410..6b094da 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -715,8 +715,7 @@ (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. +;;; Return a SOURCE-INFO to describe the incremental compilation of FORM. (defun make-lisp-source-info (form) (make-source-info :start-time (get-universal-time) :file-info (make-file-info :name :lisp diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index e41e75c..697de7e 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1522,9 +1522,6 @@ (and (listp thing) (eq (car thing) 'setf))) (compiled-function-or-lose (fdefinition thing) thing)) - #!+sb-interpreter - ((sb!eval:interpreted-function-p thing) - (compile-function-lambda-expr thing)) ((functionp thing) thing) ((and (listp thing) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index e825431..f075823 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -156,10 +156,6 @@ ;;; In all cases, SET-FUNCTION-NAME must return the new (or same) ;;; function. (Unlike other functions to set stuff, it does not return ;;; the new value.) -;;; -;;; FIXME: A similar operation is done in -;;; TRY-TO-RENAME-INTERPRETED-FUNCTION-AS-MACRO. The code should be -;;; shared. (defun set-function-name (fcn new-name) #+sb-doc "Set the name of a compiled function object. Return the function." @@ -176,10 +172,7 @@ (set-function-name (sb-kernel:byte-closure-function fcn) new-name)) (sb-kernel:byte-function - (setf (sb-kernel:byte-function-name fcn) new-name)) - #+sb-interpreter - (sb-eval:interpreted-function - (setf (sb-eval:interpreted-function-name fcn) new-name)))) + (setf (sb-kernel:byte-function-name fcn) new-name)))) fcn) (t ;; pw-- This seems wrong and causes trouble. Tests show diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 8e2f125..2bf3a28 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -246,10 +246,7 @@ ("src/code/module" :not-host) ; maybe should be :BYTE-COMPILE T - #!+sb-interpreter - ("src/code/eval") - - ("src/code/target-eval" :not-host) ; FIXME: uses INFO, wants compiler macro + ("src/code/eval" :not-host) ; FIXME: uses INFO, wants compiler macro ("src/code/interr" :not-host) @@ -594,10 +591,6 @@ ("src/compiler/target-disassem" :not-host) ("src/compiler/target/target-insts" :not-host) - ;; the IR1 interpreter (as opposed to the byte code interpreter) - #!+sb-interpreter ("src/compiler/eval-comp" :not-host) - #!+sb-interpreter ("src/compiler/eval" :not-host) - ("src/code/debug" :not-host) ; maybe should be :BYTE-COMPILE T ;; These can't be compiled until CONDITION and DEFINE-CONDITION diff --git a/version.lisp-expr b/version.lisp-expr index ed4a17c..3395e40 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -14,6 +14,7 @@ ;;; Conventionally a string like "0.6.6", with three numeric fields, ;;; is used for released versions, and a string like "0.6.5.12", with ;;; four numeric fields, is used for versions which aren't released -;;; but correspond only to CVS tags or snapshots. - -"0.pre7.15" +;;; but correspond only to CVS tags or snapshots. (And occasionally for +;;; internal versions I end up with more complicated stuff, like +;;; "0.pre7.14.flaky4.13".) +"0.pre7.16"