X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=e9910b56d9fc82197e4cd1148624e5560895b17f;hb=1a6def3955b715472eb2c75b15660912b9f90173;hp=82b129f530c69bcf6f869cbc6b5bd3c7669ce3a7;hpb=4f7211e1d005696dcd29d8322fa531992ea8fed4;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 82b129f..e9910b5 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -195,8 +195,8 @@ ;;;; translators for compiler-magic special forms -;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in -;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM, +;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in top +;;; level forms are picked off and handled by PROCESS-TOPLEVEL-FORM, ;;; so that they're never seen at this level.) ;;; ;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing @@ -240,7 +240,7 @@ ;;; call FUN (with no arguments). ;;; ;;; This is split off from the IR1 convert method so that it can be -;;; shared by the special-case top-level MACROLET processing code. +;;; shared by the special-case top level MACROLET processing code. (defun funcall-in-macrolet-lexenv (definitions fun) (%funcall-in-foomacrolet-lexenv (lambda (definition) @@ -323,13 +323,12 @@ (compiler-error "Lisp error during evaluation of info args:~%~A" condition)))) -;;; If there is a primitive translator, then we expand the call. -;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first -;;; argument is the template, the second is a list of the results of -;;; any codegen-info args, and the remaining arguments are the runtime +;;; Convert to the %%PRIMITIVE funny function. The first argument is +;;; the template, the second is a list of the results of any +;;; codegen-info args, and the remaining arguments are the runtime ;;; arguments. ;;; -;;; We do a bunch of error checking now so that we don't bomb out with +;;; We do various error checking now so that we don't bomb out with ;;; a fatal error during IR2 conversion. ;;; ;;; KLUDGE: It's confusing having multiple names floating around for @@ -341,11 +340,10 @@ ;;; FIXME: Look at doing this ^, it doesn't look too hard actually. (def-ir1-translator %primitive ((name &rest args) start cont) (unless (symbolp name) - (compiler-error "The primitive name ~S is not a symbol." name)) - + (compiler-error "internal error: Primitive name ~S is not a symbol." name)) (let* ((template (or (gethash name *backend-template-names*) (compiler-error - "The primitive name ~A is not defined." + "internal error: Primitive name ~A is not defined." name))) (required (length (template-arg-types template))) (info (template-info-arg-count template)) @@ -353,13 +351,15 @@ (nargs (length args))) (if (template-more-args-type template) (when (< nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + (compiler-error "internal error: Primitive ~A was called ~ + with ~R argument~:P, ~ but wants at least ~R." name nargs min)) (unless (= nargs min) - (compiler-error "Primitive ~A was called with ~R argument~:P, ~ + (compiler-error "internal error: Primitive ~A was called ~ + with ~R argument~:P, ~ but wants exactly ~R." name nargs @@ -397,13 +397,19 @@ (if (consp thing) (case (car thing) ((lambda) - (reference-leaf start cont (ir1-convert-lambda thing))) + (reference-leaf start + cont + (ir1-convert-lambda thing + :debug-name (debug-namify + "#'~S" thing)))) ((setf) (let ((var (find-lexically-apparent-function thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) ((instance-lambda) - (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing))))) + (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)) + :debug-name (debug-namify "#'~S" + thing)))) (setf (getf (functional-plist res) :fin-function) t) (reference-leaf start cont res))) (t @@ -423,7 +429,7 @@ (%funcall ,(if (csubtypep (continuation-type function) (specifier-type 'function)) 'function - '(%coerce-callable-to-function function)) + '(%coerce-callable-to-fun function)) ,@arg-names)))) (def-ir1-translator %funcall ((function &rest args) start cont) @@ -441,9 +447,9 @@ `(%funcall ,function ,@args) (values nil t))) -(deftransform %coerce-callable-to-function ((thing) (function) * - :when :both - :important t) +(deftransform %coerce-callable-to-fun ((thing) (function) * + :when :both + :important t) "optimize away possible call to FDEFINITION at runtime" 'thing) @@ -501,7 +507,8 @@ (multiple-value-bind (vars values) (extract-let-variables bindings 'let) (let* ((*lexenv* (process-decls decls vars nil cont)) (fun-cont (make-continuation)) - (fun (ir1-convert-lambda-body forms vars))) + (fun (ir1-convert-lambda-body + forms vars :debug-name (debug-namify "LET ~S" bindings)))) (reference-leaf start fun-cont fun) (ir1-convert-combination-args fun-cont cont values))))) @@ -519,9 +526,9 @@ ;;; logic shared between IR1 translators for LOCALLY, MACROLET, ;;; and SYMBOL-MACROLET ;;; -;;; Note that all these things need to preserve top-level-formness, +;;; Note that all these things need to preserve toplevel-formness, ;;; but we don't need to worry about that within an IR1 translator, -;;; since top-level-formness is picked off by PROCESS-TOP-LEVEL-FOO +;;; since toplevel-formness is picked off by PROCESS-TOPLEVEL-FOO ;;; forms before we hit the IR1 transform level. (defun ir1-translate-locally (body start cont) (declare (type list body) (type continuation start cont)) @@ -533,8 +540,8 @@ #!+sb-doc "LOCALLY Declaration* Form* Sequentially evaluate the Forms in a lexical environment where the - the Declarations have effect. If LOCALLY is a top-level form, then - the Forms are also processed as top-level forms." + the Declarations have effect. If LOCALLY is a top level form, then + the Forms are also processed as top level forms." (ir1-translate-locally body start cont)) ;;;; FLET and LABELS @@ -554,12 +561,13 @@ (when (or (atom def) (< (length def) 2)) (compiler-error "The ~S definition spec ~S is malformed." context def)) - (let ((name (check-function-name (first def)))) + (let ((name (first def))) + (check-fun-name name) (names name) (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def)) (defs `(lambda ,(second def) ,@decls - (block ,(function-name-block-name name) + (block ,(fun-name-block-name name) . ,forms)))))) (values (names) (defs)))) @@ -574,19 +582,16 @@ (multiple-value-bind (names defs) (extract-flet-variables definitions 'flet) (let* ((fvars (mapcar (lambda (n d) - (ir1-convert-lambda d n)) + (ir1-convert-lambda d + :source-name n + :debug-name (debug-namify + "FLET ~S" n))) names defs)) (*lexenv* (make-lexenv :default (process-decls decls nil fvars cont) :functions (pairlis names fvars)))) (ir1-convert-progn-body start cont forms))))) -;;; For LABELS, we have to create dummy function vars and add them to -;;; the function namespace while converting the functions. We then -;;; modify all the references to these leaves so that they point to -;;; the real functional leaves. We also backpatch the FENV so that if -;;; the lexical environment is used for inline expansion we will get -;;; the right functions. (def-ir1-translator labels ((definitions &body body) start cont) #!+sb-doc "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form* @@ -596,36 +601,56 @@ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil) (multiple-value-bind (names defs) (extract-flet-variables definitions 'labels) - (let* ((new-fenv (loop for name in names - collect (cons name (make-functional :name name)))) + (let* (;; dummy LABELS function vars, to be used during + ;; conversion of real LABELS functions + (placeholder-funs (mapcar (lambda (name) + (make-functional + :%source-name name + :%debug-name (debug-namify + "LABELS placeholder ~S" + name))) + names)) + (placeholder-fenv (pairlis names placeholder-funs)) + ;; the real LABELS functions, compiled in a LEXENV which + ;; includes the dummy LABELS functions (real-funs - (let ((*lexenv* (make-lexenv :functions new-fenv))) + (let ((*lexenv* (make-lexenv :functions placeholder-fenv))) (mapcar (lambda (n d) - (ir1-convert-lambda d n)) + (ir1-convert-lambda d + :source-name n + :debug-name (debug-namify + "LABELS ~S" n))) names defs)))) - (loop for real in real-funs and env in new-fenv do - (let ((dum (cdr env))) - (substitute-leaf real dum) - (setf (cdr env) real))) + ;; Modify all the references to the dummy function leaves so + ;; that they point to the real function leaves. + (loop for real-fun in real-funs and envpair in placeholder-fenv do + (let ((placeholder-fun (cdr envpair))) + (substitute-leaf real-fun placeholder-fun) + (setf (cdr envpair) real-fun))) + ;; Voila. (let ((*lexenv* (make-lexenv :default (process-decls decls nil real-funs cont) - :functions (pairlis names real-funs)))) + ;; Use a proper FENV here (not the + ;; placeholder used earlier) so that if the + ;; lexical environment is used for inline + ;; expansion we'll get the right functions. + :functions (pairlis names real-funs)))) (ir1-convert-progn-body start cont forms)))))) -;;;; THE +;;;; the THE special operator, and friends ;;; Do stuff to recognize a THE or VALUES declaration. CONT is the ;;; continuation that the assertion applies to, TYPE is the type -;;; specifier and Lexenv is the current lexical environment. NAME is +;;; specifier and LEXENV is the current lexical environment. NAME is ;;; the name of the declaration we are doing, for use in error ;;; messages. ;;; ;;; This is somewhat involved, since a type assertion may only be made ;;; on a continuation, not on a node. We can't just set the ;;; continuation asserted type and let it go at that, since there may -;;; be parallel THE's for the same continuation, i.e.: +;;; be parallel THE's for the same continuation, i.e. ;;; (if ... ;;; (the foo ...) ;;; (the bar ...)) @@ -712,9 +737,7 @@ (find-free-variable name)))) (etypecase leaf (leaf - (when (or (constant-p leaf) - (and (global-var-p leaf) - (eq (global-var-kind leaf) :constant))) + (when (constant-p leaf) (compiler-error "~S is a constant and thus can't be set." name)) (when (and (lambda-var-p leaf) (lambda-var-ignorep leaf)) @@ -884,7 +907,7 @@ (ir1-convert start fun-cont (if (and (consp fun) (eq (car fun) 'function)) fun - `(%coerce-callable-to-function ,fun))) + `(%coerce-callable-to-fun ,fun))) (setf (continuation-dest fun-cont) node) (assert-continuation-type fun-cont (specifier-type '(or function symbol))) @@ -1002,7 +1025,7 @@ ((nil)) (:function (remhash name *free-functions*) - (undefine-function-name name) + (undefine-fun-name name) (compiler-warning "~S is being redefined as a macro when it was ~ previously ~(~A~) to be a function." @@ -1018,9 +1041,9 @@ (info :function :macro-function name) (coerce def 'function)) (let* ((*current-path* (revert-source-path 'defmacro)) - (fun (ir1-convert-lambda def name))) - (setf (leaf-name fun) - (concatenate 'string "DEFMACRO " (symbol-name name))) + (fun (ir1-convert-lambda def + :debug-name (debug-namify "DEFMACRO ~S" + name)))) (setf (functional-arg-documentation fun) (eval lambda-list)) (ir1-convert start cont `(%%defmacro ',name ,fun ,doc))) @@ -1059,10 +1082,10 @@ (coerce def 'function)) (let* ((*current-path* (revert-source-path 'define-compiler-macro)) - (fun (ir1-convert-lambda def name))) - (setf (leaf-name fun) - (let ((*print-case* :upcase)) - (format nil "DEFINE-COMPILER-MACRO ~S" name))) + (fun (ir1-convert-lambda def + :debug-name (debug-namify + "DEFINE-COMPILER-MACRO ~S" + name)))) (setf (functional-arg-documentation fun) (eval lambda-list)) (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))