common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Export SB-KERNEL:INTERPRETED-FUNCTION

Browse source 
This presents a slightly more unified interface to the interpreters, and also
causes COMPILED-FUNCTION-P not to call INTERPRETED-FUNCTION-P but instead
directly reference the layout of the instance type, whichever it is.

Unrelated: fix two tests that tried to set *evaluator-mode* to :INTERPRET
when neither interpreter was built in, which causes a type-error.
This commit is contained in:
Douglas Katzman 2019-02-27 14:37:12 -05:00
parent 90a392468a
commit 269feb160f
29 changed files with 77 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
build-order.lisp-expr
View file

@ -194,7 +194,6 @@
("src/code/weak" :not-host)
;; 'target-alieneval' needs FILL-POINTER which is defined in 'array'
("src/code/array" :not-host) ; needs WEAK-POINTER-VALUE
("src/code/pred" :not-host)
("src/code/debug-var-io")
("src/code/target-alieneval" :not-host)
@ -209,6 +208,7 @@
;; Define at most one INTERPRETED-FUNCTION type based on target features
#+sb-eval ("src/code/early-full-eval" :not-host)
#+sb-fasteval ("src/interpreter/function" :not-host)
("src/code/pred" :not-host)
("src/compiler/generic/pinned-objects" :not-host)
("src/code/target-sxhash" :not-host) ; needs most-fooative-foo-float constants

9
contrib/sb-introspect/introspect.lisp
View file

@ -438,13 +438,12 @@ If an unsupported TYPE is requested, the function will return NIL.
(sb-mop:method-specializers object))
(sb-mop:method-specializers object)))))
source))
#+sb-eval
(sb-eval:interpreted-function
(interpreted-function
#+sb-eval
(let ((source (translate-source-location
(sb-eval:interpreted-function-source-location object))))
source))
#+sb-fasteval
(sb-interpreter:interpreted-function
source)
#+sb-fasteval
(translate-source-location (sb-interpreter:fun-source-location object)))
(function
(find-function-definition-source object))

2
contrib/sb-introspect/test-driver.lisp
View file

@ -24,7 +24,7 @@
;; definitive answer, and sb-eval always answers with just FUNCTION.
(defun expect-wild-return-type-p (f)
(declare (ignorable f))
(or #+sb-fasteval (typep f 'sb-interpreter:interpreted-function)))
(or #+sb-fasteval (typep f 'sb-kernel:interpreted-function)))
(deftest function-lambda-list.1
(function-lambda-list 'cl-user::one)

11
package-data-list.lisp-expr
View file

@ -1830,6 +1830,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
#+win32 "HANDLE-WIN32-EXCEPTION"
"INTERNAL-TIME" "INTERNAL-SECONDS"
"INTERNAL-SECONDS-LIMIT" "SAFE-INTERNAL-SECONDS-LIMIT"
"INTERPRETED-FUNCTION"
"INTERSECTION-TYPE" "INTERSECTION-TYPE-P"
"INTERSECTION-TYPE-TYPES" "INVALID-ARG-COUNT-ERROR"
"LOCAL-INVALID-ARG-COUNT-ERROR"
@ -3389,9 +3390,7 @@ structure representations"
:doc "internal: the evaluator implementation used to execute code without compiling it."
:use ("CL" "SB-KERNEL" "SB-EXT" "SB-INT")
:reexport ("*EVAL-CALLS*")
:export ("INTERPRETED-FUNCTION"
"INTERPRETED-FUNCTION-P"
"INTERPRETED-FUNCTION-NAME"
:export ("INTERPRETED-FUNCTION-NAME"
"INTERPRETED-FUNCTION-DEBUG-NAME"
"INTERPRETED-FUNCTION-LAMBDA-LIST"
"INTERPRETED-FUNCTION-DEBUG-LAMBDA-LIST"
@ -3402,7 +3401,6 @@ structure representations"
"EVAL-IN-ENVIRONMENT"
"MAKE-NULL-ENVIRONMENT"
"EVAL-IN-NATIVE-ENVIRONMENT"
"PREPARE-FOR-COMPILE"
"*EVAL-LEVEL*"))
#+sb-fasteval
@ -3413,8 +3411,6 @@ structure representations"
:export ("BASIC-ENV"
"ENV-POLICY"
"EVAL-IN-ENVIRONMENT"
"INTERPRETED-FUNCTION"
"INTERPRETED-FUNCTION-P"
"FIND-LEXICAL-FUN"
"FIND-LEXICAL-VAR"
"FUN-LAMBDA-EXPRESSION"
@ -3424,7 +3420,6 @@ structure representations"
"%FUN-TYPE" ; to avoid conflict with SB-KERNEL:FUN-TYPE
"LEXENV-FROM-ENV"
"LIST-LOCALS"
"PREPARE-FOR-COMPILE"
"PROTO-FN-DOCSTRING"
"PROTO-FN-NAME"
"PROTO-FN-PRETTY-ARGLIST"
@ -3594,7 +3589,6 @@ SBCL itself"
sb-interpreter:lexenv-from-env
sb-interpreter::lexically-unlocked-symbol-p
sb-interpreter:list-locals
sb-interpreter:prepare-for-compile
sb-interpreter::reconstruct-syntactic-closure-env)
;; Other
(sb-debug::find-interrupted-name-and-frame
@ -3623,4 +3617,5 @@ SBCL itself"
sb-c::compiled-debug-info-tlf-number
sb-c::fopcompilable-p
sb-c::pack-xref-data
sb-c::prepare-for-compile
sb-sys:reinit-internal-real-time))

14
src/code/condition.lisp
View file

@ -1377,14 +1377,12 @@ handled by any other handler, it will be muffled.")
;;;; Deciding which redefinitions are "interesting".
(defun function-file-namestring (function)
#+sb-eval
(when (typep function 'sb-eval:interpreted-function)
(when (typep function 'interpreted-function)
(return-from function-file-namestring
#+sb-eval
(sb-c:definition-source-location-namestring
(sb-eval:interpreted-function-source-location function))))
#+sb-fasteval
(when (typep function 'sb-interpreter:interpreted-function)
(return-from function-file-namestring
(sb-eval:interpreted-function-source-location function))
#+sb-fasteval
(awhen (sb-interpreter:fun-source-location function)
(sb-c:definition-source-location-namestring it))))
(let* ((fun (%fun-fun function))
@ -1404,9 +1402,7 @@ handled by any other handler, it will be muffled.")
(typep new '(not compiled-function)))
;; fin->regular is interesting except for interpreted->compiled.
(and (typep new '(not funcallable-instance))
(typep old '(and funcallable-instance
#+sb-fasteval (not sb-interpreter:interpreted-function)
#+sb-eval (not sb-eval:interpreted-function))))
(typep old '(and funcallable-instance (not interpreted-function))))
;; different file or unknown location is interesting.
(let* ((old-namestring (function-file-namestring old))
(new-namestring (function-file-namestring new)))

3
src/code/cross-type.lisp
View file

@ -288,8 +288,7 @@
condition restart
sb-assem::label
;; in addition to the above, these occur in make-host-2
#+sb-fasteval sb-interpreter:interpreted-function
#+sb-eval sb-eval:interpreted-function
interpreted-function
synonym-stream
)))
(values nil t))

2
src/code/debug-int.lisp
View file

@ -1420,7 +1420,7 @@ register."
;; Find a variable named FUN.
(awhen (car (debug-fun-symbol-vars debug-fun 'sb-interpreter::fun))
(let ((val (debug-var-value it frame))) ; Ensure it's a function
(when (typep val 'sb-interpreter:interpreted-function)
(when (typep val 'interpreted-function)
(%fun-name val))))))) ; Get its name
((sb-c::compiled-debug-fun-closure-save compiler-debug-fun)
(%fun-name

2
src/code/defstruct.lisp
View file

@ -1878,7 +1878,7 @@ or they must be declared locally notinline at each call site.~@:>"
;;;; functionality of !DEFINE-PRIMITIVE-OBJECT..)
;;; The complete list of alternate-metaclass DEFSTRUCTs:
;;; CONDITION SB-EVAL:INTERPRETED-FUNCTION
;;; CONDITION SB-KERNEL:INTERPRETED-FUNCTION
;;; SB-PCL::STANDARD-INSTANCE SB-PCL::STANDARD-FUNCALLABLE-INSTANCE
;;; SB-PCL::CTOR SB-PCL::%METHOD-FUNCTION
;;;

7
src/code/deftypes-for-target.lisp
View file

@ -120,9 +120,10 @@
`(simple-array bit (,size)))
(sb-xc:deftype compiled-function ()
'(and function
#+sb-fasteval (not sb-interpreter:interpreted-function)
#+sb-eval (not sb-eval:interpreted-function)))
'(and function #+(or sb-eval sb-fasteval) (not interpreted-function)))
;;; Stub type in case there are no interpreted functions
#-(or sb-eval sb-fasteval) (sb-xc:deftype interpreted-function () nil)
(sb-xc:deftype simple-fun () '(satisfies simple-fun-p))

21
src/code/describe.lisp
View file

@ -36,8 +36,8 @@
NAME is some name (for debugging only) or NIL if there is no name."
(declare (type function fun))
(etypecase fun
#+sb-eval
(sb-eval:interpreted-function
(interpreted-function
#+sb-eval
(let ((name (sb-eval:interpreted-function-name fun))
(lambda-list (sb-eval:interpreted-function-lambda-list fun))
(declarations (sb-eval:interpreted-function-declarations fun))
@ -45,9 +45,8 @@
(values `(lambda ,lambda-list
,@(when declarations `((declare ,@declarations)))
,@body)
t name)))
#+sb-fasteval
(sb-interpreter:interpreted-function
t name))
#+sb-fasteval
(sb-interpreter:fun-lambda-expression fun))
(function
(let ((name (%fun-name fun))
@ -181,8 +180,7 @@
(typecase object
(simple-fun "compiled function")
(closure "compiled closure")
((or #+sb-fasteval sb-interpreter:interpreted-function
#+sb-eval sb-eval:interpreted-function) "interpreted function")
(interpreted-function "interpreted function")
(generic-function "generic-function")
(t "funcallable-instance")))
@ -555,12 +553,9 @@
(t
(let ((source
(typecase function
#+sb-eval
(sb-eval:interpreted-function
(sb-eval:interpreted-function-source-location function))
#+sb-fasteval
(sb-interpreter:interpreted-function
(sb-interpreter:fun-source-location function)))))
(interpreted-function
#+sb-eval (sb-eval:interpreted-function-source-location function)
#+sb-fasteval (sb-interpreter:fun-source-location function)))))
(when source
(let ((namestring (sb-c:definition-source-location-namestring source)))
(when namestring

3
src/code/early-full-eval.lisp
View file

@ -53,9 +53,6 @@
(interpreted-apply function args)))
function))
(defun interpreted-function-p (function)
(typep function 'interpreted-function))
(defmethod print-object ((obj interpreted-function) stream)
(print-unreadable-object (obj stream
:identity (not (interpreted-function-name obj)))

2
src/code/full-eval.lisp
View file

@ -1119,7 +1119,7 @@
;;; Try to compile an interpreted function. If the environment
;;; contains local functions or lexical variables we'll punt on
;;; compiling it.
(defun prepare-for-compile (function)
(defun sb-c::prepare-for-compile (function)
(let ((env (interpreted-function-env function)))
(when (or (env-tags env)
(env-blocks env)

3
src/code/inspect.lisp
View file

@ -222,8 +222,7 @@ evaluated expressions.
(cons "Closed over values" (%closure-values object)))))))
#+(or sb-eval sb-fasteval)
(defmethod inspected-parts ((object #+sb-fasteval sb-interpreter:interpreted-function
#+sb-eval sb-eval:interpreted-function))
(defmethod inspected-parts ((object interpreted-function))
(multiple-value-bind (defn closurep name) (function-lambda-expression object)
(declare (ignore closurep))
(values (format nil "The object is an interpreted function named ~S.~%" name)

2
src/code/ntrace.lisp
View file

@ -48,7 +48,7 @@
(values (%closure-fun res) named-p :compiled-closure))
(funcallable-instance
(values res named-p :funcallable-instance))
;; FIXME: What about SB-EVAL:INTERPRETED-FUNCTION -- it gets picked off
;; FIXME: What about SB-KERNEL:INTERPRETED-FUNCTION -- it gets picked off
;; by the FIN above, is that right?
(t
(values res named-p :compiled))))))

40
src/code/simple-fun.lisp
View file

@ -194,12 +194,10 @@
(generic-function
(return-from %fun-name
(sb-mop:generic-function-name function)))
#+sb-eval
(sb-eval:interpreted-function
(return-from %fun-name (sb-eval:interpreted-function-debug-name function)))
#+sb-fasteval
(sb-interpreter:interpreted-function
(interpreted-function
(return-from %fun-name
#+sb-eval (sb-eval:interpreted-function-debug-name function)
#+sb-fasteval
(let ((name (sb-interpreter:proto-fn-name (sb-interpreter:fun-proto-fn function))))
(unless (eql name 0)
name)))))))
@ -215,35 +213,31 @@
(typecase (truly-the funcallable-instance function)
(generic-function
(setf (sb-mop:generic-function-name function) new-value))
#+sb-eval
(sb-eval:interpreted-function
(setf (sb-eval:interpreted-function-debug-name function) new-value))
#+sb-fasteval
(sb-interpreter:interpreted-function
(interpreted-function
#+sb-eval
(setf (sb-eval:interpreted-function-debug-name function) new-value)
#+sb-fasteval
(setf (sb-interpreter:proto-fn-name (sb-interpreter:fun-proto-fn function))
new-value)))))
new-value)
(defun %fun-lambda-list (function)
(typecase function
#+sb-fasteval
(sb-interpreter:interpreted-function
(sb-interpreter:proto-fn-pretty-arglist
(sb-interpreter:fun-proto-fn function)))
#+sb-eval
(sb-eval:interpreted-function
(interpreted-function
#+sb-fasteval
(sb-interpreter:proto-fn-pretty-arglist (sb-interpreter:fun-proto-fn function))
#+sb-eval
(sb-eval:interpreted-function-debug-lambda-list function))
(t
(%simple-fun-arglist (%fun-fun function)))))
(defun (setf %fun-lambda-list) (new-value function)
(typecase function
#+sb-fasteval
(sb-interpreter:interpreted-function
(setf (sb-interpreter:proto-fn-pretty-arglist
(sb-interpreter:fun-proto-fn function)) new-value))
#+sb-eval
(sb-eval:interpreted-function
(interpreted-function
#+sb-fasteval
(setf (sb-interpreter:proto-fn-pretty-arglist (sb-interpreter:fun-proto-fn function))
new-value)
#+sb-eval
(setf (sb-eval:interpreted-function-debug-lambda-list function) new-value))
;; FIXME: Eliding general funcallable-instances for now.
((or simple-fun closure)
@ -263,7 +257,7 @@
#+sb-fasteval
;; Obtain a list of the right shape, usually with T for each
;; arg type, but respecting local declarations if any.
(sb-interpreter:interpreted-function (sb-interpreter:%fun-type function))
(interpreted-function (sb-interpreter:%fun-type function))
(t (%simple-fun-type (%fun-fun function)))))
;;; A FUN-SRC structure appears in %SIMPLE-FUN-INFO of any function for

2
src/compiler/fndb.lisp
View file

@ -1629,7 +1629,7 @@
;;;; from the "Miscellaneous" Chapter:
(defknown compile ((or symbol cons) &optional (or list function null))
(defknown compile ((or symbol cons) &optional (or list function))
(values (or function symbol cons) boolean boolean))
(defknown compile-file

2
src/compiler/generic/vm-fndb.lisp
View file

@ -527,7 +527,7 @@
(defknown %set-funcallable-instance-info (function index t) t ())
#+sb-fasteval
(defknown sb-interpreter:fun-proto-fn (sb-interpreter:interpreted-function)
(defknown sb-interpreter:fun-proto-fn (interpreted-function)
sb-interpreter::interpreted-fun-prototype (flushable))

4
src/compiler/generic/vm-tran.lisp
View file

@ -21,8 +21,8 @@
(define-source-transform compiled-function-p (x)
(once-only ((x x))
`(and (functionp ,x)
#+sb-fasteval (not (sb-interpreter:interpreted-function-p ,x))
#+sb-eval (not (sb-eval:interpreted-function-p ,x)))))
#+(or sb-fasteval sb-eval)
(not (typep ,x 'interpreted-function)))))
(define-source-transform char-int (x)
`(char-code ,x))

8
src/compiler/target-disassem.lisp
View file

@ -1619,6 +1619,8 @@
(defun valid-extended-function-designators-for-disassemble-p (thing)
(typecase thing
((or (cons (eql lambda)) interpreted-function)
(compile nil thing))
((satisfies legal-fun-name-p)
(compiled-funs-or-lose (or (and (symbolp thing) (macro-function thing))
(fdefinition thing))
@ -1626,12 +1628,8 @@
(sb-pcl::%method-function
;; in a %METHOD-FUNCTION, the user code is in the fast function, so
;; we to disassemble both.
;; FIXME: interpreted methods need to be compiled as above.
;; FIXME: interpreted methods need to get compiled.
(list thing (sb-pcl::%method-function-fast-function thing)))
((or (cons (eql lambda))
#+sb-fasteval sb-interpreter:interpreted-function
#+sb-eval sb-eval:interpreted-function)
(compile nil thing))
(function thing)
(t nil)))

18
src/compiler/target-main.lisp
View file

@ -135,19 +135,11 @@ not STYLE-WARNINGs occur during compilation, and NIL otherwise.
(if (compiled-function-p definition)
(values definition nil nil)
(multiple-value-bind (sexpr lexenv)
(typecase definition
#+sb-fasteval
(sb-interpreter:interpreted-function
(sb-interpreter:prepare-for-compile definition))
#+sb-eval
(sb-eval:interpreted-function
(sb-eval:prepare-for-compile definition))
(t
(values definition (make-null-lexenv))))
(multiple-value-bind (compiled-definition warnings-p failure-p)
(compile-in-lexenv (the cons sexpr) lexenv name nil nil nil nil)
(aver (typep compiled-definition 'compiled-function))
(values compiled-definition warnings-p failure-p))))
(if (not (typep definition 'interpreted-function))
(values (the cons definition) (make-null-lexenv))
#+(or sb-eval sb-fasteval)
(prepare-for-compile definition))
(compile-in-lexenv sexpr lexenv name nil nil nil nil)))
(values (cond (name
(if (and (symbolp name) (macro-function name))
(setf (macro-function name) compiled-definition)

4
src/interpreter/env.lisp
View file

@ -979,7 +979,7 @@
(map 'vector
(lambda (cell)
(let ((expander (cddr cell)))
(if (interpreted-function-p expander)
(if (typep expander 'interpreted-function)
expander
(make-function
(%make-proto-fn `(macrolet ,(car cell)) '(form env)
@ -1044,7 +1044,7 @@
;;; In practice it's likely that an interpreted closure would be "too complex"
;;; for other reasons, usually due to surrounding BLOCK. It would be somewhat
;;; nifty to walk the code and find that the block is never used.
(defun prepare-for-compile (function &aux nullify-lexenv)
(defun sb-c::prepare-for-compile (function &aux nullify-lexenv)
(if (named-let too-complex-p ((env (interpreted-function-env function)))
(when (null env)
(return-from too-complex-p nil))

3
src/interpreter/function.lisp
View file

@ -60,9 +60,6 @@
(defun fun-proto-fn (f)
(truly-the interpreted-fun-prototype (interpreted-function-%proto-fn f)))
(defun interpreted-function-p (function) ; necessary stub
(typep function 'interpreted-function))
(defun fun-lambda-expression (fun)
(let* ((proto-fn (fun-proto-fn fun))
(name (proto-fn-name proto-fn))

2
src/interpreter/sexpr.lisp
View file

@ -1158,7 +1158,7 @@ Test case.
;; And this doesn't fix the problem with SETF.
(when (fboundp fname)
(let ((f (symbol-function fname)))
(when (and (interpreted-function-p f)
(when (and (typep f 'interpreted-function)
(structure-instance-accessor-p fname))
;: Compile the accessor using an explicit call to COMPILE with a
;; lambda expression. Don't simply call (COMPILE FNAME) because

20
src/pcl/documentation.lisp
View file

@ -10,12 +10,9 @@
(defun fun-doc (function)
(typecase function
#+sb-fasteval
(sb-interpreter:interpreted-function
(sb-interpreter:proto-fn-docstring (sb-interpreter:fun-proto-fn function)))
#+sb-eval
(sb-eval:interpreted-function
(sb-eval:interpreted-function-documentation function))
(interpreted-function
#+sb-fasteval (sb-interpreter:proto-fn-docstring (sb-interpreter:fun-proto-fn function))
#+sb-eval (sb-eval:interpreted-function-documentation function))
(generic-function
(slot-value function '%documentation))
(t
@ -29,12 +26,11 @@
(defun (setf fun-doc) (new-value function)
(declare (type (or null string) new-value))
(typecase function
#+sb-fasteval
(sb-interpreter:interpreted-function
(setf (sb-interpreter:proto-fn-docstring
(sb-interpreter:fun-proto-fn function)) new-value))
#+sb-eval
(sb-eval:interpreted-function
(interpreted-function
#+sb-fasteval
(setf (sb-interpreter:proto-fn-docstring (sb-interpreter:fun-proto-fn function))
new-value)
#+sb-eval
(setf (sb-eval:interpreted-function-documentation function) new-value))
(generic-function
(setf (slot-value function '%documentation) new-value))

2
tests/compiler.pure.lisp
View file

@ -5689,7 +5689,7 @@
;; symbol each time. But if the compiler processes the guts as it
;; should, you get back a compiled lambda which returns a constant
;; symbol.
(let ((f (let ((sb-ext:*evaluator-mode* :interpret))
(let ((f (let (#+(or sb-eval sb-fasteval) (sb-ext:*evaluator-mode* :interpret))
(checked-compile
`(lambda ()
(load-time-value

2
tests/eval.impure.lisp
View file

@ -303,7 +303,7 @@
(with-test (:name (:bug-573747 eval :interpret))
(let ((*out* (make-string-output-stream))
(sb-ext:*evaluator-mode* :interpret))
#+(or sb-eval sb-fasteval) (sb-ext:*evaluator-mode* :interpret))
(declare (special *out*))
(assert-error (eval '(declare (print "foo" *out*))))
(assert (string= (get-output-stream-string *out*) ""))))

2
tests/fast-eval.impure.lisp
View file

@ -20,7 +20,7 @@
(test-util:with-test (:name :write-bogus-function-instance)
(write-to-string
(sb-pcl::class-prototype (find-class 'sb-interpreter:interpreted-function))))
(sb-pcl::class-prototype (find-class 'sb-kernel:interpreted-function))))
(test-util:with-test (:name :type-checker-for-function)
;; The test for (FUNCTION (HAIR) (MORE-HAIR)) is just FUNCTIONP.

7
tests/interface.impure.lisp
View file

@ -24,12 +24,7 @@
(let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x)))
(silently (disassemble 'disassemble-closure)))
#+sb-eval
(eval-when (:compile-toplevel :load-toplevel :execute)
(import 'sb-eval:interpreted-function-p))
#+sb-fasteval
(eval-when (:compile-toplevel :load-toplevel :execute)
(import 'sb-interpreter:interpreted-function-p))
(defun interpreted-function-p (x) (typep x 'sb-kernel:interpreted-function))
#+(or sb-eval sb-fasteval)
(with-test (:name (disassemble :interpreted))

7
tests/type.impure.lisp
View file

@ -583,13 +583,8 @@
'(or fixnum vector end-of-file parse-error fixnum simple-string))))
(with-test (:name (subtypep function compiled-function :interpreted-function))
#+sb-eval
(assert-tri-eq t t (subtypep '(and function (not compiled-function)
(not sb-eval:interpreted-function))
nil))
#+sb-fasteval
(assert-tri-eq t t (subtypep '(and function (not compiled-function)
(not sb-interpreter:interpreted-function))
(not sb-kernel:interpreted-function))
nil)))
;;; weakening of union type checks