(defvar *converting-for-interpreter* nil)
;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
-;;; *COMPILE-TIME-DEFINE-MACROS* is true when we want DEFMACRO
-;;; definitions to be installed in the compilation environment as
-;;; interpreted functions. We set this to false when compiling some
-;;; parts of the system.
-(defvar *compile-time-define-macros* t)
-;;; FIXME: I think this can go away with the new system.
-
;;; FIXME: This nastiness was one of my original motivations to start
;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should
;;; be made not the default, and perhaps should be controlled by
;;; Parse an inline/notinline declaration. If it's a local function we're
;;; defining, set its INLINEP. If a global function, add a new FENV entry.
(defun process-inline-declaration (spec res fvars)
- (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq)))
+ (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq)))
(new-fenv ()))
(dolist (name (rest spec))
(let ((fvar (find name fvars :key #'leaf-name :test #'equal)))
(string= (symbol-name what) "CLASS"))) ; pcl hack
(or (info :type :kind what)
(and (consp what) (info :type :translator (car what)))))
-;;; MNA - abbreviated declaration bug
-;; (unless (policy nil (= brevity 3))
- ;; FIXME: Is it ANSI to warn about this? I think not.
-;; (compiler-note "abbreviated type declaration: ~S." spec))
(process-type-declaration spec res vars))
((info :declaration :recognized what)
res)
(values))
;;; Create a lambda node out of some code, returning the result. The
-;;; bindings are specified by the list of var structures Vars. We deal
-;;; with adding the names to the Lexenv-Variables for the conversion.
-;;; The result is added to the New-Functions in the
-;;; *Current-Component* and linked to the component head and tail.
+;;; bindings are specified by the list of VAR structures VARS. We deal
+;;; with adding the names to the LEXENV-VARIABLES for the conversion.
+;;; The result is added to the NEW-FUNCTIONS in the
+;;; *CURRENT-COMPONENT* and linked to the component head and tail.
;;;
-;;; We detect special bindings here, replacing the original Var in the
+;;; We detect special bindings here, replacing the original VAR in the
;;; lambda list with a temporary variable. We then pass a list of the
-;;; special vars to IR1-Convert-Special-Bindings, which actually emits
+;;; special vars to IR1-CONVERT-SPECIAL-BINDINGS, which actually emits
;;; the special binding code.
;;;
-;;; We ignore any Arg-Info in the Vars, trusting that someone else is
+;;; We ignore any ARG-INFO in the VARS, trusting that someone else is
;;; dealing with &nonsense.
;;;
-;;; Aux-Vars is a list of Var structures for variables that are to be
-;;; sequentially bound. Each Aux-Val is a form that is to be evaluated
-;;; to get the initial value for the corresponding Aux-Var. Interface
-;;; is a flag as T when there are real aux values (see let* and
-;;; ir1-convert-aux-bindings.)
+;;; AUX-VARS is a list of VAR structures for variables that are to be
+;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
+;;; to get the initial value for the corresponding AUX-VAR. Interface
+;;; is a flag as T when there are real aux values (see LET* and
+;;; IR1-CONVERT-AUX-BINDINGS.)
(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals
interface result)
(declare (list body vars aux-vars aux-vals)
(let ((n-supplied (gensym "N-SUPPLIED-")))
(temps n-supplied)
(arg-vals n-value n-supplied)
- ;; MNA: non-self-eval-keyword patch
(tests `((eq ,n-key ',keyword)
(setq ,n-supplied t)
(setq ,n-value ,n-value-temp)))))
(t
(arg-vals n-value)
- ;; MNA: non-self-eval-keyword patch
(tests `((eq ,n-key ',keyword)
(setq ,n-value ,n-value-temp)))))))
(prev-link entry start)
(use-continuation entry dummy)
- ;; MNA - Re: two obscure bugs in CMU CL
(let* ((env-entry (list entry cont))
- (*lexenv*
- (make-lexenv :blocks (list (cons name env-entry))
- :cleanup cleanup)))
+ (*lexenv* (make-lexenv :blocks (list (cons name env-entry))
+ :cleanup cleanup)))
(push env-entry (continuation-lexenv-uses cont))
(ir1-convert-progn-body dummy cont forms))))
(conts))
(starts dummy)
(dolist (segment (rest segments))
- ;; MNA - Re: two obscure bugs
(let* ((tag-cont (make-continuation))
(tag (list (car segment) entry tag-cont)))
(conts tag-cont)
(starts tag-cont)
(continuation-starts-block tag-cont)
(tags tag)
- (push (cdr tag) (continuation-lexenv-uses tag-cont))
- ))
+ (push (cdr tag) (continuation-lexenv-uses tag-cont))))
(conts cont)
(let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1
;;; conversion done by EVAL, or by conversion of the body for
;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do
-;;; not* eval since some enclosing eval-when already did.
+;;; not* EVAL since some enclosing EVAL-WHEN already did.
;;;
;;; We know we are EVAL'ing for LOAD since we wouldn't get called
;;; otherwise. If LOAD is a situation we call FUN on body. If we
(not sb!eval::*already-evaled-this*)))
(sb!eval::*already-evaled-this* t))
(when do-eval
- (eval `(progn ,@body)))
+
+ ;; This is the natural way to do it.
+ #-(and sb-xc-host (or sbcl cmu))
+ (eval `(progn ,@body))
+
+ ;; This is a disgusting hack to work around bug IR1-3 when using
+ ;; SBCL (or CMU CL, for that matter) as a cross-compilation
+ ;; host. When we go from the cross-compiler (where we bound
+ ;; SB!EVAL::*ALREADY-EVALED-THIS*) to the host compiler (which
+ ;; has a separate SB-EVAL::*ALREADY-EVALED-THIS* variable), EVAL
+ ;; would go and executes nested EVAL-WHENs even when they're not
+ ;; toplevel forms. Using EVAL-WHEN instead of bare EVAL causes
+ ;; the cross-compilation host to bind its own
+ ;; *ALREADY-EVALED-THIS* variable, so that the problem is
+ ;; suppressed.
+ ;;
+ ;; FIXME: Once bug IR1-3 is fixed, this hack can go away. (Or if
+ ;; CMU CL doesn't fix the bug, then this hack can be made
+ ;; conditional on #+CMU.)
+ #+(and sb-xc-host (or sbcl cmu))
+ (let (#+sbcl (sb-eval::*already-evaled-this* t)
+ #+cmu (stub:probably similar but has not been tested))
+ (eval `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@body))))
+
(if (or (intersection '(:load-toplevel load) situations)
(and *converting-for-interpreter*
(intersection '(:execute eval) situations)))
"EVAL-WHEN (Situation*) Form*
Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL.
This is conceptually a compile-only implementation, so EVAL is a no-op."
- (do-eval-when-stuff situations body
- #'(lambda (forms)
- (ir1-convert-progn-body start cont forms))))
-;;; Like DO-EVAL-WHEN-STUFF, only do a macrolet. Fun is not passed any
+ ;; It's difficult to handle EVAL-WHENs completely correctly in the
+ ;; cross-compiler. (Common Lisp is not a cross-compiler-friendly
+ ;; language..) Since we, the system implementors, control not only
+ ;; the cross-compiler but also the code that it processes, we can
+ ;; handle this either by making the cross-compiler smarter about
+ ;; handling EVAL-WHENs (hard) or by avoiding the use of difficult
+ ;; EVAL-WHEN constructs (relatively easy). However, since EVAL-WHENs
+ ;; can be generated by many macro expansions, it's not always easy
+ ;; to detect problems by skimming the source code, so we'll try to
+ ;; add some code here to help out.
+ ;;
+ ;; Nested EVAL-WHENs are tricky.
+ #+sb-xc-host
+ (labels ((contains-toplevel-eval-when-p (body-part)
+ (and (consp body-part)
+ (or (eq (first body-part) 'eval-when)
+ (and (member (first body-part)
+ '(locally macrolet progn symbol-macrolet))
+ (some #'contains-toplevel-eval-when-p
+ (rest body-part)))))))
+ (/show "testing for nested EVAL-WHENs" body)
+ (when (some #'contains-toplevel-eval-when-p body)
+ (compiler-style-warning "nested EVAL-WHENs in cross-compilation")))
+
+ (do-eval-when-stuff situations
+ body
+ (lambda (forms)
+ (ir1-convert-progn-body start cont forms))))
+
+;;; Like DO-EVAL-WHEN-STUFF, only do a MACROLET. FUN is not passed any
;;; arguments.
(defun do-macrolet-stuff (definitions fun)
(declare (list definitions) (type function fun))
the Forms are also processed as top-level forms."
(multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
(let ((*lexenv* (process-decls decls nil nil cont)))
- ;;; MNA: locally patch - #'ir1-convert-progn-body gets called anyway!
- (ir1-convert-progn-body start cont forms))))
+ (ir1-convert-aux-bindings start cont forms nil nil nil))))
\f
;;;; FLET and LABELS
`(multiple-value-call #'%throw ,tag ,result)))
;;; This is a special special form used to instantiate a cleanup as
-;;; the current cleanup within the body. Kind is a the kind of cleanup
-;;; to make, and Mess-Up is a form that does the mess-up action. We
-;;; make the MESS-UP be the USE of the Mess-Up form's continuation,
+;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; to make, and MESS-UP is a form that does the mess-up action. We
+;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
;;; and introduce the cleanup into the lexical environment. We
-;;; back-patch the Entry-Cleanup for the current cleanup to be the new
+;;; back-patch the ENTRY-CLEANUP for the current cleanup to be the new
;;; cleanup, since this inner cleanup is the interesting one.
(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
(let ((dummy (make-continuation))
;;; This is a special special form that makes an "escape function"
;;; which returns unknown values from named block. We convert the
-;;; function, set its kind to :Escape, and then reference it. The
+;;; function, set its kind to :ESCAPE, and then reference it. The
;;; :Escape kind indicates that this function's purpose is to
;;; represent a non-local control transfer, and that it might not
;;; actually have to be compiled.
;;;
;;; Note that environment analysis replaces references to escape
-;;; functions with references to the corresponding NLX-Info structure.
+;;; functions with references to the corresponding NLX-INFO structure.
(def-ir1-translator %escape-function ((tag) start cont)
(let ((fun (ir1-convert-lambda
`(lambda ()
(reference-leaf start cont fun)))
;;; Yet another special special form. This one looks up a local
-;;; function and smashes it to a :Cleanup function, as well as
+;;; function and smashes it to a :CLEANUP function, as well as
;;; referencing it.
(def-ir1-translator %cleanup-function ((name) start cont)
(let ((fun (lexenv-find name functions)))
;;; We represent the possibility of the control transfer by making an
;;; "escape function" that does a lexical exit, and instantiate the
-;;; cleanup using %within-cleanup.
+;;; cleanup using %WITHIN-CLEANUP.
(def-ir1-translator catch ((tag &body body) start cont)
#!+sb-doc
"Catch Tag Form*
;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
;;; cleanup forms into a local function so that they can be referenced
;;; both in the case where we are unwound and in any local exits. We
-;;; use %Cleanup-Function on this to indicate that reference by
-;;; %Unwind-Protect isn't "real", and thus doesn't cause creation of
+;;; use %CLEANUP-FUNCTION on this to indicate that reference by
+;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
;;; an XEP.
(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
#!+sb-doc
;;;; multiple-value stuff
;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
-;;; MV-Combination.
+;;; MV-COMBINATION.
;;;
;;; If there are no arguments, then we convert to a normal
-;;; combination, ensuring that a MV-Combination always has at least
+;;; combination, ensuring that a MV-COMBINATION always has at least
;;; one argument. This can be regarded as an optimization, but it is
-;;; more important for simplifying compilation of MV-Combinations.
+;;; more important for simplifying compilation of MV-COMBINATIONS.
(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
#!+sb-doc
"MULTIPLE-VALUE-CALL Function Values-Form*
(use-continuation node cont)
(setf (basic-combination-args node) (arg-conts))))))
-;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a
+;;; MULTIPLE-VALUE-PROG1 is represented implicitly in IR1 by having a
;;; the result code use result continuation (CONT), but transfer
;;; control to the evaluation of the body. In other words, the result
-;;; continuation isn't Immediately-Used-P by the nodes that compute
+;;; continuation isn't IMMEDIATELY-USED-P by the nodes that compute
;;; the result.
;;;
;;; In order to get the control flow right, we convert the result with
;;; a dummy result continuation, then convert all the uses of the
-;;; dummy to be uses of CONT. If a use is an Exit, then we also
-;;; substitute CONT for the dummy in the corresponding Entry node so
+;;; dummy to be uses of CONT. If a use is an EXIT, then we also
+;;; substitute CONT for the dummy in the corresponding ENTRY node so
;;; that they are consistent. Note that this doesn't amount to
;;; changing the exit target, since the control destination of an exit
;;; is determined by the block successor; we are just indicating the
;;; Note that we both exploit and maintain the invariant that the CONT
;;; to an IR1 convert method either has no block or starts the block
;;; that control should transfer to after completion for the form.
-;;; Nested MV-Prog1's work because during conversion of the result
+;;; Nested MV-PROG1's work because during conversion of the result
;;; form, we use dummy continuation whose block is the true control
;;; destination.
(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
\f
;;;; interface to defining macros
-;;;; DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx
-;;;; functions so that we get a chance to see what is going on. We
-;;;; define IR1 translators for these functions which look at the
-;;;; definition and then generate a call to the %%DEFxxx function.
+;;;; FIXME:
+;;;; classic CMU CL comment:
+;;;; DEFMACRO and DEFUN expand into calls to %DEFxxx functions
+;;;; so that we get a chance to see what is going on. We define
+;;;; IR1 translators for these functions which look at the
+;;;; definition and then generate a call to the %%DEFxxx function.
+;;;; Alas, this implementation doesn't do the right thing for
+;;;; non-toplevel uses of these forms, so this should probably
+;;;; be changed to use EVAL-WHEN instead.
;;; Return a new source path with any stuff intervening between the
-;;; current path and the first form beginning with Name stripped off.
+;;; current path and the first form beginning with NAME stripped off.
;;; This is used to hide the guts of DEFmumble macros to prevent
;;; annoying error messages.
(defun revert-source-path (name)
(compiler-error "The special form ~S can't be redefined as a macro."
name)))
- (setf (info :function :kind name) :macro)
- (setf (info :function :where-from name) :defined)
-
- (when *compile-time-define-macros*
- (setf (info :function :macro-function name)
- (coerce def 'function)))
+ (setf (info :function :kind name) :macro
+ (info :function :where-from name) :defined
+ (info :function :macro-function name) (coerce def 'function))
(let* ((*current-path* (revert-source-path 'defmacro))
(fun (ir1-convert-lambda def name)))
(ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
(when sb!xc:*compile-print*
- ;; MNA compiler message patch
+ ;; FIXME: It would be nice to convert this, and the other places
+ ;; which create compiler diagnostic output prefixed by
+ ;; semicolons, to use some common utility which automatically
+ ;; prefixes all its output with semicolons. (The addition of
+ ;; semicolon prefixes was introduced ca. sbcl-0.6.8.10 as the
+ ;; "MNA compiler message patch", and implemented by modifying a
+ ;; bunch of output statements on a case-by-case basis, which
+ ;; seems unnecessarily error-prone and unclear, scattering
+ ;; implicit information about output style throughout the
+ ;; system.) Starting by rewriting COMPILER-MUMBLE to add
+ ;; semicolon prefixes would be a good start, and perhaps also:
+ ;; * Add semicolon prefixes for "FOO assembled" messages emitted
+ ;; when e.g. src/assembly/x86/assem-rtns.lisp is processed.
+ ;; * At least some debugger output messages deserve semicolon
+ ;; prefixes too:
+ ;; ** restarts table
+ ;; ** "Within the debugger, you can type HELP for help."
(compiler-mumble "~&; converted ~S~%" name))))
(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
start cont
:kind :function)
(let ((name (eval name))
- (def (second def))) ; Don't want to make a function just yet...
+ (def (second def))) ; We don't want to make a function just yet...
(when (eq (info :function :kind name) :special-form)
(compiler-error "attempt to define a compiler-macro for special form ~S"
name))
- (when *compile-time-define-macros*
- (setf (info :function :compiler-macro-function name)
- (coerce def 'function)))
+ (setf (info :function :compiler-macro-function name)
+ (coerce def 'function))
(let* ((*current-path* (revert-source-path 'define-compiler-macro))
(fun (ir1-convert-lambda def name)))
(ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
(when sb!xc:*compile-print*
- ;; MNA compiler message patch
(compiler-mumble "~&; converted ~S~%" name))))
-
-;;; Update the global environment to correspond to the new definition.
-(def-ir1-translator %defconstant ((name value doc) start cont
- :kind :function)
- (let ((name (eval name))
- (newval (eval value)))
- (unless (symbolp name)
- (compiler-error "constant name not a symbol: ~S" name))
- (when (eq name t)
- (compiler-error "The value of T can't be changed."))
- (when (eq name nil)
- (compiler-error "Nihil ex nihil. (can't change NIL)"))
- (when (keywordp name)
- (compiler-error "Keyword values can't be changed."))
-
- (let ((kind (info :variable :kind name)))
- (case kind
- (:constant
- ;; Note: This behavior (disparaging any non-EQL modification)
- ;; is unpopular, but it is specified by ANSI (i.e. ANSI says
- ;; a non-EQL change has undefined consequences). I think it's
- ;; a bad idea to encourage nonconforming programming style
- ;; even if it's convenient. If people really want things
- ;; which are constant in some sense other than EQL, I suggest
- ;; either just using DEFVAR (which is what I generally do),
- ;; or defining something like this (untested) code:
- ;; (DEFMACRO DEFCONSTANT-EQX (SYMBOL EXPR EQX &OPTIONAL DOC)
- ;; "This macro is to be used instead of DEFCONSTANT for values
- ;; which are appropriately compared using the function given by
- ;; the EQX argument instead of EQL."
- ;; (LET ((EXPR-TMP (GENSYM "EXPR-TMP-")))
- ;; `(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- ;; (LET ((,EXPR-TMP ,EXPR))
- ;; (UNLESS (AND (BOUNDP ,SYMBOL)
- ;; (CONSTANTP ,SYMBOL)
- ;; (FUNCALL ,EQX
- ;; (SYMBOL-VALUE ,SYMBOL)
- ;; ,EXPR-TMP))
- ;; (DEFCONSTANT ,SYMBOL ,EXPR ,@(WHEN DOC `(,DOC))))))))
- ;; I prefer using DEFVAR, though, first because it's trivial,
- ;; and second because using DEFCONSTANT lets the compiler
- ;; optimize code by removing indirection, copying the current
- ;; value of the constant directly into the code, and for
- ;; consed data structures, this optimization can become a
- ;; pessimization. (And consed data structures are exactly
- ;; where you'd be tempted to use DEFCONSTANT-EQX.) Why is
- ;; this a pessimization? It does remove a layer of
- ;; indirection, but it makes it hard for the system's
- ;; load/dump logic to see that all references to the consed
- ;; data structure refer to the same (EQ) object. If you use
- ;; something like DEFCONSTANT-EQX, you'll tend to get one
- ;; copy of the data structure bound to the symbol, and one
- ;; more copy for each file where code refers to the constant.
- ;; If you're moderately clever with MAKE-LOAD-FORM, you might
- ;; be able to make the copy bound to the symbol at load time
- ;; be EQ to the references in code in the same file, but it
- ;; seems to be rather tricky to force code in different files
- ;; to refer the same copy without doing the DEFVAR thing of
- ;; indirection through a symbol. -- WHN 2000-11-02
- (unless (eql newval
- (info :variable :constant-value name))
- (compiler-warning "redefining constant ~S as:~% ~S" name newval)))
- (:global)
- (t
- (compiler-warning "redefining ~(~A~) ~S to be a constant"
- kind
- name))))
-
- (setf (info :variable :kind name) :constant)
- (setf (info :variable :where-from name) :defined)
- (setf (info :variable :constant-value name) newval)
- (remhash name *free-variables*))
-
- (ir1-convert start cont `(%%defconstant ,name ,value ,doc)))
\f
;;;; defining global functions
(global-var
(when (defined-function-p what)
(push `(,(car (rassoc (defined-function-inlinep what)
- inlinep-translations))
+ *inlinep-translations*))
,name)
decls)))
(t (return t))))))
(*current-path* (revert-source-path 'defun))
(expansion (unless (eq (info :function :inlinep name) :notinline)
(inline-syntactic-closure-lambda lambda))))
- ;; If not in a simple environment or NOTINLINE, then discard any forward
- ;; references to this function.
+ ;; If not in a simple environment or NOTINLINE, then discard any
+ ;; forward references to this function.
(unless expansion (remhash name *free-functions*))
(let* ((var (get-defined-function name))
expansion)))
(setf (defined-function-inline-expansion var) expansion)
(setf (info :function :inline-expansion name) save-expansion)
- ;; If there is a type from a previous definition, blast it, since it is
- ;; obsolete.
+ ;; If there is a type from a previous definition, blast it,
+ ;; since it is obsolete.
(when (eq (leaf-where-from var) :defined)
(setf (leaf-type var) (specifier-type 'function)))
,@(when save-expansion `(',save-expansion)))))
(when sb!xc:*compile-print*
- ;; MNA compiler message patch
(compiler-mumble "~&; converted ~S~%" name))))))
projects / sbcl.git / blobdiff