X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=690fc9ecc52eae95fe6f652589f332febca38770;hb=012fbee7176df4472ef4add1a7df558d762bc4f6;hp=420f8035b1ae23724f8185bf48d0ca955a61093a;hpb=5eb97830eca716fef626c6e12429c99c9b97e3c8;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 420f803..690fc9e 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -18,12 +18,12 @@ ;;; taken through the source to reach the form. This provides a way to ;;; keep track of the location of original source forms, even when ;;; macroexpansions and other arbitary permutations of the code -;;; happen. This table is initialized by calling Find-Source-Paths on +;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on ;;; the original source. (declaim (hash-table *source-paths*)) (defvar *source-paths*) -;;; *CURRENT-COMPONENT* is the Component structure which we link +;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph ;;; canonicalization figure out what is really going on. We need to @@ -40,34 +40,14 @@ ;;; *CURRENT-PATH* is the source path of the form we are currently ;;; translating. See NODE-SOURCE-PATH in the NODE structure. (declaim (list *current-path*)) -(defvar *current-path* nil) - -;;; *CONVERTING-FOR-INTERPRETER* is true when we are creating IR1 to -;;; be interpreted rather than compiled. This inhibits source -;;; tranformations and stuff. -(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 -;;; DECLAIM instead of a variable like this. And whether or not this -;;; kind of checking is on, declarations should be assertions to the -;;; extent practical, and code which can't be compiled efficiently -;;; while adhering to that principle should give warnings. -(defvar *derive-function-types* t - #!+sb-doc - "(Caution: Soon, this might change its semantics somewhat, or even go away.) - If true, argument and result type information derived from compilation of - DEFUNs is used when compiling calls to that function. If false, only - information from FTYPE proclamations will be used.") +(defvar *current-path*) + +(defvar *derive-function-types* nil + "Should the compiler assume that function types will never change, + so that it can use type information inferred from current definitions + to optimize code which uses those definitions? Setting this true + gives non-ANSI, early-CMU-CL behavior. It can be useful for improving + the efficiency of stable code.") ;;;; namespace management utilities @@ -79,7 +59,13 @@ (setf (info :function :where-from name) :assumed)) (let ((where (info :function :where-from name))) - (when (eq where :assumed) + (when (and (eq where :assumed) + ;; In the ordinary target Lisp, it's silly to report + ;; undefinedness when the function is defined in the + ;; running Lisp. But at cross-compile time, the current + ;; definedness of a function is irrelevant to the + ;; definedness at runtime, which is what matters. + #-sb-xc-host (not (fboundp name))) (note-undefined-reference name :function)) (make-global-var :kind :global-function :name name @@ -96,11 +82,13 @@ (let* ((info (layout-info (or (info :type :compiler-layout (sb!xc:class-name class)) (class-layout class)))) - (accessor (if (listp name) (cadr name) name)) - (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor)) + (accessor-name (if (listp name) (cadr name) name)) + (slot (find accessor-name (dd-slots info) + :key #'sb!kernel:dsd-accessor-name)) (type (dd-name info)) (slot-type (dsd-type slot))) - (assert slot () "Can't find slot ~S." type) + (unless slot + (error "can't find slot ~S" type)) (make-slot-accessor :name name :type (specifier-type @@ -129,31 +117,19 @@ name context)) ((:function nil) - (check-function-name name) + (check-fun-name name) (note-if-setf-function-and-macro name) - (let ((expansion (info :function :inline-expansion name)) + (let ((expansion (fun-name-inline-expansion name)) (inlinep (info :function :inlinep name))) (setf (gethash name *free-functions*) (if (or expansion inlinep) - (make-defined-function + (make-defined-fun :name name :inline-expansion expansion :inlinep inlinep :where-from (info :function :where-from name) :type (info :function :type name)) - (let ((info (info :function :accessor-for name))) - (etypecase info - (null - (find-free-really-function name)) - (sb!xc:structure-class - (find-structure-slot-accessor info name)) - (sb!xc:class - (if (typep (layout-info (info :type :compiler-layout - (sb!xc:class-name - info))) - 'defstruct-description) - (find-structure-slot-accessor info name) - (find-free-really-function name)))))))))))) + (find-free-really-function name)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. @@ -162,7 +138,7 @@ (let ((var (lexenv-find name functions :test #'equal))) (cond (var (unless (leaf-p var) - (assert (and (consp var) (eq (car var) 'macro))) + (aver (and (consp var) (eq (car var) 'macro))) (compiler-error "found macro name ~S ~A" name context)) var) (t @@ -184,27 +160,30 @@ (where-from (info :variable :where-from name))) (when (and (eq where-from :assumed) (eq kind :global)) (note-undefined-reference name :variable)) - (setf (gethash name *free-variables*) - (if (eq kind :alien) - (info :variable :alien-info name) - (multiple-value-bind (val valp) - (info :variable :constant-value name) - (if (and (eq kind :constant) valp) - (make-constant :value val - :name name - :type (ctype-of val) - :where-from where-from) - (make-global-var :kind kind - :name name - :type type - :where-from where-from)))))))) + (case kind + (:alien + (info :variable :alien-info name)) + (:constant + (let ((value (info :variable :constant-value name))) + (make-constant :value value + :name name + :type (ctype-of value) + :where-from where-from))) + (t + (make-global-var :kind kind + :name name + :type type + :where-from where-from))))))) ;;; Grovel over CONSTANT checking for any sub-parts that need to be ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(defconstant list-to-hash-table-threshold 32) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) + ;; below. -- AL 20010227 + (defconstant list-to-hash-table-threshold 32)) (defun maybe-emit-make-load-forms (constant) (let ((things-processed nil) (count 0)) @@ -280,7 +259,7 @@ #!-sb-fluid (declaim (inline prev-link)) (defun prev-link (node cont) (declare (type node node) (type continuation cont)) - (assert (not (continuation-next cont))) + (aver (not (continuation-next cont))) (setf (continuation-next cont) node) (setf (node-prev node) cont)) @@ -311,15 +290,15 @@ (declare (type node node) (type continuation cont) (inline member)) (let ((block (continuation-block cont)) (node-block (continuation-block (node-prev node)))) - (assert (eq (continuation-kind cont) :block-start)) - (assert (not (block-last node-block)) () "~S has already ended." - node-block) + (aver (eq (continuation-kind cont) :block-start)) + (when (block-last node-block) + (error "~S has already ended." node-block)) (setf (block-last node-block) node) - (assert (null (block-succ node-block)) () "~S already has successors." - node-block) + (when (block-succ node-block) + (error "~S already has successors." node-block)) (setf (block-succ node-block) (list block)) - (assert (not (member node-block (block-pred block) :test #'eq)) () - "~S is already a predecessor of ~S." node-block block) + (when (memq node-block (block-pred block)) + (error "~S is already a predecessor of ~S." node-block block)) (push node-block (block-pred block)) (add-continuation-use node cont) (unless (eq (continuation-asserted-type cont) *wild-type*) @@ -334,11 +313,11 @@ ;;; This function takes a form and the top-level form number for that ;;; form, and returns a lambda representing the translation of that -;;; form in the current global environment. The lambda is top-level -;;; lambda that can be called to cause evaluation of the forms. This -;;; lambda is in the initial component. If FOR-VALUE is T, then the -;;; value of the form is returned from the function, otherwise NIL is -;;; returned. +;;; form in the current global environment. The returned lambda is a +;;; top-level lambda that can be called to cause evaluation of the +;;; forms. This lambda is in the initial component. If FOR-VALUE is T, +;;; then the value of the form is returned from the function, +;;; otherwise NIL is returned. ;;; ;;; This function may have arbitrary effects on the global environment ;;; due to processing of PROCLAIMs and EVAL-WHENs. All syntax error @@ -373,13 +352,14 @@ ;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the ;;; form number to associate with a source path. This should be bound -;;; to 0 around the processing of each truly top-level form. +;;; to an initial value of 0 before the processing of each truly +;;; top-level form. (declaim (type index *current-form-number*)) (defvar *current-form-number*) ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to -;;; find the paths in, and TLF-Num is the top-level form number of the +;;; find the paths in, and TLF-NUM is the top-level form number of the ;;; truly top-level form. ;;; ;;; This gets a bit interesting when the source code is circular. This @@ -427,8 +407,8 @@ `(block ,skip (catch 'ir1-error-abort (let ((*compiler-error-bailout* - #'(lambda () - (throw 'ir1-error-abort nil)))) + (lambda () + (throw 'ir1-error-abort nil)))) ,@body (return-from ,skip nil))) (ir1-convert ,start ,cont ,proxy))))) @@ -469,8 +449,8 @@ (global-var (ir1-convert-srctran start cont lexical-def form)) (t - (assert (and (consp lexical-def) - (eq (car lexical-def) 'macro))) + (aver (and (consp lexical-def) + (eq (car lexical-def) 'macro))) (ir1-convert start cont (careful-expand-macro (cdr lexical-def) form)))))) @@ -484,7 +464,7 @@ (values)) ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. If we are producing a fasl-file, make sure that + ;; if necessary. If we are producing a fasl file, make sure that ;; MAKE-LOAD-FORM gets used on any parts of the constant that it ;; needs to be. (defun reference-constant (start cont value) @@ -509,16 +489,16 @@ (pushnew fun (component-reanalyze-functions *current-component*))) fun) -;;; Generate a Ref node for LEAF, frobbing the LEAF structure as +;;; Generate a REF node for LEAF, frobbing the LEAF structure as ;;; needed. If LEAF represents a defined function which has already ;;; been converted, and is not :NOTINLINE, then reference the ;;; functional instead. (defun reference-leaf (start cont leaf) (declare (type continuation start cont) (type leaf leaf)) - (let* ((leaf (or (and (defined-function-p leaf) - (not (eq (defined-function-inlinep leaf) + (let* ((leaf (or (and (defined-fun-p leaf) + (not (eq (defined-fun-inlinep leaf) :notinline)) - (let ((fun (defined-function-functional leaf))) + (let ((fun (defined-fun-functional leaf))) (when (and fun (not (functional-kind fun))) (maybe-reanalyze-function fun)))) leaf)) @@ -545,7 +525,7 @@ (compiler-style-warning "reading an ignored variable: ~S" name)) (reference-leaf start cont var)) (cons - (assert (eq (car var) 'MACRO)) + (aver (eq (car var) 'MACRO)) (ir1-convert start cont (cdr var))) (heap-alien-info (ir1-convert start cont `(%heap-alien ',var))))) @@ -559,8 +539,9 @@ (translator (info :function :ir1-convert fun)) (cmacro (info :function :compiler-macro-function fun))) (cond (translator (funcall translator start cont form)) - ((and cmacro (not *converting-for-interpreter*) - (not (eq (info :function :inlinep fun) :notinline))) + ((and cmacro + (not (eq (info :function :inlinep fun) + :notinline))) (let ((res (careful-expand-macro cmacro form))) (if (eq res form) (ir1-convert-global-functoid-no-cmacro start cont form fun) @@ -583,13 +564,18 @@ (careful-expand-macro (info :function :macro-function fun) form))) ((nil :function) - (ir1-convert-srctran start cont (find-free-function fun "Eh?") form)))) + (ir1-convert-srctran start + cont + (find-free-function fun + "shouldn't happen! (no-cmacro)") + form)))) (defun muffle-warning-or-die () (muffle-warning) (error "internal error -- no MUFFLE-WARNING restart")) -;;; Trap errors during the macroexpansion. +;;; Expand FORM using the macro whose MACRO-FUNCTION is FUN, trapping +;;; errors which occur during the macroexpansion. (defun careful-expand-macro (fun form) (handler-bind (;; When cross-compiling, we can get style warnings ;; about e.g. undefined functions. An unhandled @@ -705,32 +691,26 @@ ;;; Convert a call to a global function. If not :NOTINLINE, then we do ;;; source transforms and try out any inline expansion. If there is no -;;; expansion, but is :INLINE, then give an efficiency note (unless a known -;;; function which will quite possibly be open-coded.) Next, we go to -;;; ok-combination conversion. +;;; expansion, but is :INLINE, then give an efficiency note (unless a +;;; known function which will quite possibly be open-coded.) Next, we +;;; go to ok-combination conversion. (defun ir1-convert-srctran (start cont var form) (declare (type continuation start cont) (type global-var var)) - (let ((inlinep (when (defined-function-p var) - (defined-function-inlinep var)))) - (cond - ((eq inlinep :notinline) - (ir1-convert-combination start cont form var)) - (*converting-for-interpreter* - (ir1-convert-combination-checking-type start cont form var)) - (t - (let ((transform (info :function :source-transform (leaf-name var)))) - (cond - (transform - (multiple-value-bind (result pass) (funcall transform form) - (if pass - (ir1-convert-maybe-predicate start cont form var) - (ir1-convert start cont result)))) - (t - (ir1-convert-maybe-predicate start cont form var)))))))) - -;;; If the function has the Predicate attribute, and the CONT's DEST isn't -;;; an IF, then we convert (IF