X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Fmain.lisp;h=9bdf959539eac92537623f5c35b6b7503de12efe;hb=45bc305be4e269d2e1a477c8e0ae9a64df1ccd1c;hp=9ee255c6877f7ff4942d679f457aee8ff823338e;hpb=26bd73ecbd7af2473ff97bfbdc7eae9e39f54ba4;p=sbcl.git

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 9ee255c..9bdf959 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -973,7 +973,7 @@
                            (maybe-frob (optional-dispatch-main-entry f)))
                          result))))
 
-(defun make-functional-from-toplevel-lambda (definition
+(defun make-functional-from-toplevel-lambda (lambda-expression
                                              &key
                                              name
                                              (path
@@ -983,17 +983,15 @@
                                               (missing-arg)))
   (let* ((*current-path* path)
          (component (make-empty-component))
-         (*current-component* component))
-    (setf (component-name component)
-          (debug-name 'initial-component name))
-    (setf (component-kind component) :initial)
+         (*current-component* component)
+         (debug-name-tail (or name (name-lambdalike lambda-expression)))
+         (source-name (or name '.anonymous.)))
+    (setf (component-name component) (debug-name 'initial-component debug-name-tail)
+          (component-kind component) :initial)
     (let* ((locall-fun (let ((*allow-instrumenting* t))
                          (funcall #'ir1-convert-lambdalike
-                                  definition
-                                  :source-name name)))
-           (debug-name (debug-name 'tl-xep
-                                   (or name
-                                       (functional-%source-name locall-fun))))
+                                  lambda-expression
+                                  :source-name source-name)))
            ;; Convert the XEP using the policy of the real
            ;; function. Otherwise the wrong policy will be used for
            ;; deciding whether to type-check the parameters of the
@@ -1002,8 +1000,8 @@
            (*lexenv* (make-lexenv :policy (lexenv-policy
                                            (functional-lexenv locall-fun))))
            (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
-                                    :source-name (or name '.anonymous.)
-                                    :debug-name debug-name)))
+                                    :source-name source-name
+                                    :debug-name (debug-name 'tl-xep debug-name-tail))))
       (when name
         (assert-global-function-definition-type name locall-fun))
       (setf (functional-entry-fun fun) locall-fun
@@ -1814,7 +1812,7 @@ SPEED and COMPILATION-SPEED optimization values, and the
 (defvar *constants-being-created* nil)
 (defvar *constants-created-since-last-init* nil)
 ;;; FIXME: Shouldn't these^ variables be unbound outside LET forms?
-(defun emit-make-load-form (constant)
+(defun emit-make-load-form (constant &optional (name nil namep))
   (aver (fasl-output-p *compile-object*))
   (unless (or (fasl-constant-already-dumped-p constant *compile-object*)
               ;; KLUDGE: This special hack is because I was too lazy
@@ -1830,10 +1828,14 @@ SPEED and COMPILATION-SPEED optimization values, and the
           (throw constant t))
         (throw 'pending-init circular-ref)))
     (multiple-value-bind (creation-form init-form)
-        (handler-case
-            (sb!xc:make-load-form constant (make-null-lexenv))
-          (error (condition)
-            (compiler-error condition)))
+        (if namep
+            ;; If the constant is a reference to a named constant, we can
+            ;; just use SYMBOL-VALUE during LOAD.
+            (values `(symbol-value ',name) nil)
+            (handler-case
+                (sb!xc:make-load-form constant (make-null-lexenv))
+              (error (condition)
+                (compiler-error condition))))
       (case creation-form
         (:sb-just-dump-it-normally
          (fasl-validate-structure constant *compile-object*)