Changeset 13160

Timestamp:

01/20/11 12:20:29 (13 years ago)

Author:

ehuelsmann

Message:

Further transition to unsafety detection in pass2.

Location:

branches/unsafe-p-removal/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (1 diff)
• compiler-pass2.lisp (modified) (9 diffs)

branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -1153 +1153 @@
 (defvar *pass2-unsafe-p-special-treatment-functions*
   '(
-     coerce-to-function
-     cons
-     sys::backq-cons
-     find-class
-     list
-     sys::backq-list
-     list*
-     sys::backq-list*
-     load-time-value
      logand
      logior
      lognot
      logxor
-     max
-     min
-     mod
-       stream-element-type
-       truncate
 )
 "The functions named in the list bound to this variable

branches/unsafe-p-removal/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -761 +761 @@
         (emit-move-from-stack register (variable-representation variable)))))))
 
+(defun emit-register-operand (register representation)
+  (push representation *operand-representations*)
+  (cond (*saved-operands*
+         (push register *saved-operands*))
+        (t
+         (emit-push-register register representation))))
+
 (defun emit-thread-operand ()
-  (push nil *operand-representations*)
-  (emit-push-current-thread)
-  (when *saved-operands*
-    (let ((register (allocate-register nil)))
-      (push register *saved-operands*)
-      (emit 'astore register))))
+  (ensure-thread-var-initialized)
+  (emit-register-operand *thread* nil))
 
 (defun emit-load-externalized-object-operand (object)
@@ -3956 +3959 @@
 (define-inlined-function p2-cons (form target representation)
   ((check-arg-count form 2))
-  (emit-new +lisp-cons+)
-  (emit 'dup)
   (let* ((args (%cdr form))
          (arg1 (%car args))
-         (arg2 (%cadr args)))
-    (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
-                                               arg2 'stack nil))
-  (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
-  (emit-move-from-stack target))
+         (arg2 (%cadr args))
+         (cons-register (when (some-nested-block #'node-opstack-unsafe-p
+                                                 (find-enclosed-blocks args))
+                          (allocate-register nil))))
+    (emit-new +lisp-cons+)
+    (if cons-register
+        (astore cons-register)
+      (emit 'dup))
+    (with-operand-accumulation
+        ((when cons-register
+           (emit-register-operand cons-register nil))
+         (compile-operand arg1 nil)
+         (compile-operand arg2 nil)
+         (maybe-emit-clear-values arg1 arg2)))
+    (emit-invokespecial-init +lisp-cons+ (lisp-object-arg-types 2))
+    (when cons-register
+      (emit-push-register cons-register nil))
+    (emit-move-from-stack target)))
 
 (defun compile-progn (form target representation)
@@ -4712 +4726 @@
                 (fixnum-type-p type1)
                 (fixnum-type-p type2))
-           (compile-forms-and-maybe-emit-clear-values arg1 'stack :int
-                                                      arg2 'stack :int)
+           (with-operand-accumulation
+               ((compile-operand arg1 :int)
+                (compile-operand arg2 :int)
+                (maybe-emit-clear-values arg1 arg2)))
            (emit-invokestatic +lisp+ "mod" '(:int :int) :int)
            (emit-move-from-stack target representation))
           ((fixnum-type-p type2)
-           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
-                                                      arg2 'stack :int)
+           (with-operand-accumulation
+               ((compile-operand arg1 nil)
+                (compile-operand arg2 :int)
+                (maybe-emit-clear-values arg1 arg2)))
            (emit-invokevirtual +lisp-object+ "MOD" '(:int) +lisp-object+)
            (fix-boxing representation nil) ; FIXME use derived result type
            (emit-move-from-stack target representation))
           (t
-           (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
-                                                      arg2 'stack nil)
+           (with-operand-accumulation
+               ((compile-operand arg1 nil)
+                (compile-operand arg2 nil)
+                (maybe-emit-clear-values arg1 arg2)))
            (emit-invokevirtual +lisp-object+ "MOD"
                                (lisp-object-arg-types 1) +lisp-object+)
@@ -4799 +4819 @@
       (2
        (let ((arg2 (second args)))
-         (compile-forms-and-maybe-emit-clear-values arg1 'stack nil
-                                                    arg2 'stack :boolean)
+         (with-operand-accumulation
+             ((compile-operand arg1 nil)
+              (compile-operand arg2 :boolean)
+              (maybe-emit-clear-values arg1 arg2)))
          (emit-invokestatic +lisp-class+ "findClass"
                             (list +lisp-object+ :boolean) +lisp-object+)
@@ -5529 +5551 @@
                          (butlast args 1)
                          args)))
-    (cond ((>= 4 length 1)
+    (cond ((and (not (some-nested-block #'node-opstack-unsafe-p
+                                        (find-enclosed-blocks args)))
+                (>= 4 length 1))
            (dolist (cons-head cons-heads)
              (emit-new +lisp-cons+)
@@ -5629 +5653 @@
               (args (%cdr form))
               (arg1 (%car args))
-              (arg2 (%cadr args)))
+              (arg2 (%cadr args))
+              (*register* *register*))
          (when (null target)
+           ;; compile for effect
            (compile-forms-and-maybe-emit-clear-values arg1 nil nil
                                                       arg2 nil nil)
@@ -5640 +5666 @@
                (type2 (derive-compiler-type arg2)))
            (cond ((and (java-long-type-p type1) (java-long-type-p type2))
-                  (let ((common-rep (if (and (fixnum-type-p type1)
-                                             (fixnum-type-p type2))
-                                        :int :long))
-                        (LABEL1 (gensym)))
-                    (compile-form arg1 'stack common-rep)
+                  (let* ((common-rep (if (and (fixnum-type-p type1)
+                                              (fixnum-type-p type2))
+                                         :int :long))
+                        (LABEL1 (gensym))
+                        (LABEL2 (gensym))
+                        (arg1-register (allocate-register common-rep))
+                        (arg2-register (allocate-register common-rep)))
+                    (compile-form arg1 arg1-register common-rep)
+                    (compile-form arg2 'stack common-rep)
                     (emit-dup common-rep)
-                    (compile-form arg2 'stack common-rep)
-                    (emit-dup common-rep :past common-rep)
+                    (emit-move-from-stack arg2-register common-rep)
+                    (emit-push-register arg1-register common-rep)
+                    ;; note: we've now reversed the arguments on the stack!
                     (emit-numeric-comparison (if (eq op 'max) '<= '>=)
                                              common-rep LABEL1)
-                    (emit-swap common-rep common-rep)
+                    (emit-push-register arg1-register common-rep)
+                    (emit 'goto LABEL2)
                     (label LABEL1)
-                    (emit-move-from-stack nil common-rep)
+                    (emit-push-register arg2-register common-rep)
+                    (label LABEL2)
                     (convert-representation common-rep representation)
                     (emit-move-from-stack target representation)))
                  (t
-                  (compile-form arg1 'stack nil)
-                  (emit-dup nil)
-                  (compile-form arg2 'stack nil)
-                  (emit-dup nil :past nil)
-                  (emit-invokevirtual +lisp-object+
-                                      (if (eq op 'max)
-                                          "isLessThanOrEqualTo"
+                  (let* ((arg1-register (allocate-register nil))
+                         (arg2-register (allocate-register nil)))
+                    (compile-form arg1 arg1-register nil)
+                    (compile-form arg2 'stack nil)
+                    (emit-dup nil)
+                    (astore arg2-register)
+                    (emit-push-register arg1-register nil)
+                    (emit-invokevirtual +lisp-object+
+                                        (if (eq op 'max)
+                                            "isLessThanOrEqualTo"
                                           "isGreaterThanOrEqualTo")
-                                      (lisp-object-arg-types 1) :boolean)
-                  (let ((LABEL1 (gensym)))
-                    (emit 'ifeq LABEL1)
-                    (emit 'swap)
-                    (label LABEL1)
-                    (emit 'pop))
-                  (fix-boxing representation nil)
-                  (emit-move-from-stack target representation))))))
+                                        (lisp-object-arg-types 1) :boolean)
+                    (let ((LABEL1 (gensym))
+                          (LABEL2 (gensym)))
+                      (emit 'ifeq LABEL1)
+                      (emit-push-register arg1-register nil)
+                      (emit 'goto LABEL2)
+                      (label LABEL1)
+                      (emit-push-register arg2-register nil)
+                      (label LABEL2))
+                    (fix-boxing representation nil)
+                    (emit-move-from-stack target representation)))))))
     (t
      (p2-min/max `(,(car form) (,(car form) ,(second form) ,(third form))
@@ -5949 +5988 @@
        (compile-function-call form target representation)
        (return-from p2-truncate)))
-    (compile-form arg1 'stack nil)
-    (compile-form arg2 'stack nil)
-    (emit-invokevirtual +lisp-object+ "truncate" (lisp-object-arg-types 1) +lisp-object+)
+    (with-operand-accumulation
+        ((compile-operand arg1 nil)
+         (compile-operand arg2 nil)))
+    (maybe-emit-clear-values arg1 arg2)
+    (emit-invokevirtual +lisp-object+ "truncate"
+                        (lisp-object-arg-types 1) +lisp-object+)
     (fix-boxing representation nil) ; FIXME use derived result type
     (emit-move-from-stack target representation)))
@@ -6287 +6329 @@
          (compile-forms-and-maybe-emit-clear-values arg target representation)))
       (2
-       (emit-push-current-thread)
        (let ((arg1 (%car args))
              (arg2 (%cadr args)))
          (cond ((and (eq arg1 t)
                      (eq arg2 t))
+                (emit-push-current-thread)
                 (emit-push-t)
                 (emit 'dup))
                ((and (eq arg1 nil)
                      (eq arg2 nil))
+                (emit-push-current-thread)
                 (emit-push-nil)
                 (emit 'dup))
                (t
                 (with-operand-accumulation
-                   ((compile-operand arg1 nil)
+                   ((emit-thread-operand)
+                    (compile-operand arg1 nil)
                     (compile-operand arg2 nil)
                     (maybe-emit-clear-values arg1 arg2))))))