X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Flexenv.lisp;h=7e3e34e38fa9e024169997dc7814efb13157b61d;hb=3d544b84f2b7ecd617d220145a775079df6c7919;hp=7bbaaf5c094b7bb5c20cd8f631a1bd012ad13b98;hpb=2d195da5e29feadce7190ea1a68a2efa83a5e1c0;p=sbcl.git diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp index 7bbaaf5..7e3e34e 100644 --- a/src/compiler/lexenv.lisp +++ b/src/compiler/lexenv.lisp @@ -11,24 +11,23 @@ (in-package "SB!C") -#!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place - ;;; The LEXENV represents the lexical environment used for IR1 conversion. ;;; (This is also what shows up as an ENVIRONMENT value in macroexpansion.) #!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place (def!struct (lexenv - ;; FIXME: should probably be called MAKE-EMPTY-LEXENV or - ;; MAKE-NULL-LEXENV - (:constructor make-null-lexenv ()) - (:constructor internal-make-lexenv - (functions variables blocks tags type-restrictions - lambda cleanup cookie - interface-cookie options))) - ;; Alist (name . what), where What is either a Functional (a local function), - ;; a DEFINED-FUNCTION, representing an INLINE/NOTINLINE declaration, or - ;; a list (MACRO . ) (a local macro, with the specifier - ;; expander.) Note that Name may be a (SETF ) function. - (functions nil :type list) + (:print-function print-lexenv) + (:constructor make-null-lexenv ()) + (:constructor internal-make-lexenv + (funs vars blocks tags + type-restrictions + lambda cleanup handled-conditions + disabled-package-locks %policy user-data))) + ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a + ;; local function), a DEFINED-FUN, representing an + ;; INLINE/NOTINLINE declaration, or a list (MACRO . ) (a + ;; local macro, with the specifier expander). Note that NAME may be + ;; a (SETF ) list, not necessarily a single symbol. + (funs nil :type list) ;; an alist translating variable names to LEAF structures. A special ;; binding is indicated by a :SPECIAL GLOBAL-VAR leaf. Each special ;; binding within the code gets a distinct leaf structure, as does @@ -38,35 +37,133 @@ ;; ;; If the CDR is (MACRO . ), then is the expansion of a ;; symbol macro. - (variables nil :type list) + (vars nil :type list) ;; BLOCKS and TAGS are alists from block and go-tag names to 2-lists ;; of the form ( ), where is the - ;; continuation to exit to, and is the corresponding ENTRY node. + ;; continuation to exit to, and is the corresponding ENTRY + ;; node. (blocks nil :type list) (tags nil :type list) ;; an alist (THING . CTYPE) which is used to keep track of ;; "pervasive" type declarations. When THING is a leaf, this is for ;; type declarations that pertain to the type in a syntactic extent - ;; which does not correspond to a binding of the affected name. When - ;; Thing is a continuation, this is used to track the innermost THE - ;; type declaration. + ;; which does not correspond to a binding of the affected name. (type-restrictions nil :type list) ;; the lexically enclosing lambda, if any - ;; + ;; ;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard ;; to get CLAMBDA defined in time for the cross-compiler. - (lambda nil) - ;; the lexically enclosing cleanup, or NIL if none enclosing within Lambda - ;; - ;; FIXME: This should be :TYPE (OR CLEANUP NULL), but it was too hard - ;; to get CLEANUP defined in time for the cross-compiler. + (lambda nil) + ;; the lexically enclosing cleanup, or NIL if none enclosing within LAMBDA (cleanup nil) - ;; The representation of the current OPTIMIZE policy. - (cookie *default-cookie* :type cookie) - ;; the policy that takes effect in XEPs and related syntax parsing - ;; functions. Slots in this cookie may be null to indicate that the - ;; normal value in effect. - (interface-cookie *default-interface-cookie* :type cookie) - ;; an alist of miscellaneous options that are associated with the - ;; lexical environment - (options nil :type list)) + ;; condition types we handle with a handler around the compiler + (handled-conditions *handled-conditions*) + ;; lexically disabled package locks (list of symbols) + (disabled-package-locks *disabled-package-locks*) + ;; the current OPTIMIZE policy. this is null in the null environment, + ;; and the global policy is stored in *POLICY*. (Because we want to + ;; be able to affect it from :WITH-COMPILATION-UNIT.) NIL here also + ;; works as a convenient null-lexenv identifier. + (%policy nil :type policy) + ;; A list associating extra user info to symbols. The entries + ;; are of the form (:declare name . value), + ;; (:variable name key . value), or (:function name key . value) + (user-data nil :type list)) + +(defun lexenv-policy (lexenv) + (or (lexenv-%policy lexenv) *policy*)) + +(defun null-lexenv-p (lexenv) + (not (lexenv-%policy lexenv))) + +;;; support for the idiom (in MACROEXPAND and elsewhere) that NIL is +;;; to be taken as a null lexical environment +(defun coerce-to-lexenv (x) + (etypecase x + (null (make-null-lexenv)) + (lexenv x))) + +(defun print-lexenv (lexenv stream level) + (if (null-lexenv-p lexenv) + (print-unreadable-object (lexenv stream) + (write-string "NULL-LEXENV" stream)) + (default-structure-print lexenv stream level))) + +(defun maybe-inline-syntactic-closure (lambda lexenv) + (declare (type list lambda) (type lexenv lexenv)) + (aver (eql (first lambda) 'lambda)) + ;; We used to have a trivial implementation, verifying that lexenv + ;; was effectively null. However, this fails to take account of the + ;; idiom + ;; + ;; (declaim (inline foo)) + ;; (macrolet ((def (x) `(defun ,x () ...))) + ;; (def foo)) + ;; + ;; which, while too complicated for the cross-compiler to handle in + ;; unfriendly foreign lisp environments, would be good to support in + ;; the target compiler. -- CSR, 2002-05-13 and 2002-11-02 + (let ((vars (lexenv-vars lexenv)) + (funs (lexenv-funs lexenv))) + (collect ((decls) (macros) (symbol-macros)) + (cond + ((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil) + ((and (null vars) (null funs)) `(lambda-with-lexenv + nil nil nil + ,@(cdr lambda))) + ((dolist (x vars nil) + #+sb-xc-host + ;; KLUDGE: too complicated for cross-compilation + (return t) + #-sb-xc-host + (let ((name (car x)) + (what (cdr x))) + ;; only worry about the innermost binding + (when (eq x (assoc name vars :test #'eq)) + (typecase what + (cons + (aver (eq (car what) 'macro)) + (symbol-macros x)) + (global-var + ;; A global should not appear in the lexical + ;; environment? Is this true? FIXME! + (aver (eq (global-var-kind what) :special)) + (decls `(special ,name))) + (t + ;; we can't inline in the presence of this object + (return t)))))) + nil) + ((dolist (x funs nil) + #+sb-xc-host + ;; KLUDGE: too complicated for cross-compilation (and + ;; failure of OAOO in comments, *sigh*) + (return t) + #-sb-xc-host + (let ((name (car x)) + (what (cdr x))) + ;; again, only worry about the innermost binding, but + ;; functions can have name (SETF FOO) so we need to use + ;; EQUAL for the test. + (when (eq x (assoc name funs :test #'equal)) + (typecase what + (cons + (macros (cons name (function-lambda-expression (cdr what))))) + ;; FIXME: Is there a good reason for this not to be + ;; DEFINED-FUN (which :INCLUDEs GLOBAL-VAR, in case + ;; you're wondering how this ever worked :-)? Maybe + ;; in conjunction with an AVERrance that it's not an + ;; (AND GLOBAL-VAR (NOT GLOBAL-FUN))? -- CSR, + ;; 2002-07-08 + (global-var + (when (defined-fun-p what) + (decls `(,(car (rassoc (defined-fun-inlinep what) + *inlinep-translations*)) + ,name)))) + (t (return t)))))) + nil) + (t + ;; if we get this far, we've successfully dealt with + ;; everything in FUNS and VARS, so: + `(lambda-with-lexenv ,(decls) ,(macros) ,(symbol-macros) + ,@(cdr lambda))))))) +