Changeset 11781

Timestamp:

04/25/09 05:42:28 (14 years ago)

Author:

ehuelsmann

Message:

Instead of interning symbols over and over,
use the ones already interned.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (11 diffs)

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -747 +747 @@
 
 (defun emit-push-variable-name (variable)
-  (emit 'getstatic *this-class* (declare-symbol (variable-name variable))
-        +lisp-symbol+))
+  (multiple-value-bind
+        (name class)
+      (lookup-or-declare-symbol (variable-name variable))
+  (emit 'getstatic class name +lisp-symbol+)))
 
 (defknown generate-instanceof-type-check-for-variable (t t) t)
@@ -2039 +2041 @@
       (setf (gethash symbol ht) g))))))
 
+(defun lookup-or-declare-symbol (symbol)
+  "Returns the value-pair (VALUES field class) from which
+the Java object representing SYMBOL can be retrieved."
+  (multiple-value-bind
+        (name class)
+      (lookup-known-symbol symbol)
+    (if name
+        (values name class)
+        (values (declare-symbol symbol) *this-class*))))
+
 (defknown declare-keyword (symbol) string)
 (defun declare-keyword (symbol)
@@ -2063 +2075 @@
      (when s
        (setf f (concatenate 'string f "_" s))))
-   (let ((*code* *static-code*)
-   (g (gethash1 symbol (the hash-table *declared-symbols*))))
-     (cond (g
-      (emit 'getstatic *this-class* g +lisp-symbol+))
-     (t
-      (emit 'ldc (pool-string (symbol-name symbol)))
-      (emit 'ldc (pool-string (package-name (symbol-package symbol))))
-      (emit-invokestatic +lisp-class+ "internInPackage"
-             (list +java-string+ +java-string+)
-             +lisp-symbol+)))
-     (declare-field f +lisp-object+)
-     (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
-       nil +lisp-object+)
-     (emit 'putstatic *this-class* f +lisp-object+)
-     (setf *static-code* *code*)
-     (setf (gethash symbol ht) f))))
+   (declare-field f +lisp-object+)
+   (multiple-value-bind
+         (name class)
+       (lookup-or-declare-symbol symbol)
+     (let ((*code* *static-code*))
+       (emit 'getstatic class name +lisp-symbol+)
+       (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
+                           nil +lisp-object+)
+       (emit 'putstatic *this-class* f +lisp-object+)
+       (setf *static-code* *code*)
+       (setf (gethash symbol ht) f)))))
 
 (defknown declare-setf-function (name) string)
@@ -2090 +2097 @@
        (when s
    (setf f (concatenate 'string f "_SETF_" s))))
-     (let ((*code* *static-code*)
-     (g (gethash1 symbol (the hash-table *declared-symbols*))))
-       (cond (g
-        (emit 'getstatic *this-class* g +lisp-symbol+))
-       (t
-        (emit 'ldc (pool-string (symbol-name symbol)))
-        (emit 'ldc (pool-string (package-name (symbol-package symbol))))
-        (emit-invokestatic +lisp-class+ "internInPackage"
-         (list +java-string+ +java-string+)
-         +lisp-symbol+)))
-       (declare-field f +lisp-object+)
-       (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
-         nil +lisp-object+)
-       (emit 'putstatic *this-class* f +lisp-object+)
-       (setf *static-code* *code*)
-       (setf (gethash name ht) f)))))
+     (multiple-value-bind
+           (name class)
+         (lookup-or-declare-symbol symbol)
+       (let ((*code* *static-code*))
+         (emit 'getstatic class name +lisp-symbol+)
+         (declare-field f +lisp-object+)
+         (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
+                             nil +lisp-object+)
+         (emit 'putstatic *this-class* f +lisp-object+)
+         (setf *static-code* *code*)
+         (setf (gethash name ht) f))))))
 
 
@@ -2950 +2952 @@
       (cond ((eq op (compiland-name *current-compiland*)) ; recursive call
              (if (notinline-p op)
-                 (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+)
+                 (multiple-value-bind
+                       (name class)
+                     (lookup-or-declare-symbol op)
+                   (emit 'getstatic class name +lisp-symbol+))
                  (aload 0)))
-            ((null (symbol-package op))
-             (let ((g (if *file-compilation*
-                          (declare-object-as-string op)
-                          (declare-object op))))
-               (emit 'getstatic *this-class* g +lisp-object+)))
             (t
              (multiple-value-bind
                    (name class)
-                 (lookup-known-symbol op)
-               (if name
-                   (emit 'getstatic class name +lisp-symbol+)
-                   (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+)))))
+                 (lookup-or-declare-symbol op)
+               (emit 'getstatic class name +lisp-symbol+))))
       (process-args args)
       (if (or (<= *speed* *debug*) *require-stack-frame*)
@@ -4927 +4925 @@
            (multiple-value-bind
                  (name class)
-               (lookup-known-symbol obj)
-             (cond (name
-                    (emit 'getstatic class name +lisp-symbol+))
-                   ((symbol-package (truly-the symbol obj))
-                    (emit 'getstatic *this-class* (declare-symbol obj)
-                          +lisp-symbol+))
-                   (t
-                    ;; An uninterned symbol.
-                    (let ((g (if *file-compilation*
-                                 (declare-object-as-string obj)
-                                 (declare-object obj))))
-                      (emit 'getstatic *this-class* g +lisp-object+))))
-             (emit-move-from-stack target representation)))
+               (lookup-or-declare-symbol obj)
+             (emit 'getstatic class name +lisp-symbol+))
+           (emit-move-from-stack target representation))
           ((listp obj)
            (let ((g (if *file-compilation*
@@ -5191 +5179 @@
                   (emit-move-from-stack target))
                  (t
-                  (emit 'getstatic *this-class*
-                        (declare-symbol name) +lisp-symbol+)
-                  (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie"
+                  (multiple-value-bind
+                        (name class)
+                      (lookup-or-declare-symbol name)
+                    (emit 'getstatic class name +lisp-symbol+))
+                  (emit-invokevirtual +lisp-object-class+
+                                      "getSymbolFunctionOrDie"
                                       nil +lisp-object+)
                   (emit-move-from-stack target))))
@@ -5227 +5218 @@
                   (emit-move-from-stack target))
                  (t
-                  (emit 'getstatic *this-class*
-                        (declare-symbol (cadr name)) +lisp-symbol+)
+                  (multiple-value-bind
+                        (name class)
+                      (lookup-or-declare-symbol (cadr name))
+                    (emit 'getstatic class name +lisp-symbol+))
                   (emit-invokevirtual +lisp-symbol-class+
                                       "getSymbolSetfFunctionOrDie"
@@ -7487 +7480 @@
         (compile-constant value target representation)
         (return-from compile-special-reference))))
-  (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+)
+  (multiple-value-bind
+        (name class)
+      (lookup-or-declare-symbol name)
+    (emit 'getstatic class name +lisp-symbol+))
   (cond ((constantp name)
          ;; "... a reference to a symbol declared with DEFCONSTANT always
@@ -7562 +7558 @@
       ;; We're setting a special variable.
       (emit-push-current-thread)
-      (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+)
+      (multiple-value-bind
+            (name class)
+          (lookup-or-declare-symbol name)
+        (emit 'getstatic class name +lisp-symbol+))
 ;;       (let ((*print-structure* nil))
 ;;         (format t "p2-setq name = ~S value-form = ~S~%" name value-form))
@@ -8010 +8009 @@
                    (multiple-value-bind
                          (name class)
-                       (lookup-known-symbol form)
-                     (if name
-                         (emit 'getstatic class name +lisp-symbol+)
-                         (emit 'getstatic *this-class* (declare-keyword form)
-                               +lisp-symbol+)))))
+                       (lookup-or-declare-symbol form)
+                     (emit 'getstatic class name +lisp-symbol+))))
                 (emit-move-from-stack target representation))
                (t