[armedbear-cvs] r11580 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sat Jan 24 11:04:17 2009
New Revision: 11580

Log:
Commit some of the changes required for FLOAT and DOUBLE support (clean up my wc a bit)

- Add debugging output before triggering an ASSERT or AVER.
- Add boxing/unboxing routines (for future use).
- Add a new type (also for future use).

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

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sat Jan 24 11:04:17 2009
@@ -222,6 +222,8 @@
 (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;")
 (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
 (defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;")
+(defconstant +lisp-integer-class+ "org/armedbear/lisp/LispInteger")
+(defconstant +lisp-integer+ "Lorg/armedbear/lisp/LispInteger;")
 (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
 (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
 (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
@@ -735,6 +737,31 @@
          (emit 'checkcast +lisp-character-class+)
          (emit 'getfield +lisp-character-class+ "value" "C"))))
 
+(defknown emit-unbox-long () t)
+(defun emit-unbox-long ()
+  (emit-invokestatic +lisp-bignum-class+ "longValue"
+                     (lisp-object-arg-types 1) "J"))
+
+(defknown emit-unbox-float () t)
+(defun emit-unbox-float ()
+  (declare (optimize speed))
+  (cond ((= *safety* 3)
+         (emit-invokestatic +lisp-single-float-class+ "getValue"
+                            (lisp-object-arg-types 1) "F"))
+        (t
+         (emit 'checkcast +lisp-single-float-class+)
+         (emit 'getfield +lisp-single-float-class+ "value" "F"))))
+
+(defknown emit-unbox-double () t)
+(defun emit-unbox-double ()
+  (declare (optimize speed))
+  (cond ((= *safety* 3)
+         (emit-invokestatic +lisp-double-float-class+ "getValue"
+                            (lisp-object-arg-types 1) "D"))
+        (t
+         (emit 'checkcast +lisp-double-float-class+)
+         (emit 'getfield +lisp-double-float-class+ "value" "D"))))
+
 (defknown emit-unbox-boolean () t)
 (defun emit-unbox-boolean ()
   (let ((LABEL1 (gensym))
@@ -771,6 +798,13 @@
          (emit-invokevirtual +lisp-object-class+ "doubleValue" nil "D"))
         (t (assert nil))))
 
+(defknown emit-box-int () t)
+(defun emit-box-int ()
+  (declare (optimize speed))
+  (new-fixnum)
+  (emit 'dup_x1)
+  (emit-fixnum-init nil))
+
 (defknown emit-box-long () t)
 (defun emit-box-long ()
   (declare (optimize speed))
@@ -834,6 +868,7 @@
              'astore))
           target))
         (t
+         (sys::%format t "emit-move-from-stack general case~%")
          (aver nil))))
 
 ;; Expects value on stack.
@@ -2241,6 +2276,7 @@
             (emit-move-from-stack target representation)
             (return-from compile-constant))
            (t
+            (sys::%format t "compile-constant int representation~%")
             (assert nil))))
     (:long
      (cond ((fixnump form)
@@ -2263,6 +2299,7 @@
             (emit-move-from-stack target representation)
             (return-from compile-constant))
            (t
+            (sys::%format t "compile-constant long representation~%")
             (assert nil))))
     (:char
      (cond ((characterp form)
@@ -2270,6 +2307,7 @@
             (emit-move-from-stack target representation)
             (return-from compile-constant))
            (t
+            (sys::%format t "compile-constant :char representation~%")
             (assert nil))))
     (:boolean
      (emit (if form 'iconst_1 'iconst_0))
@@ -2292,7 +2330,9 @@
            ((typep form 'double-float)
             (emit 'ldc2_w (pool-double form))
             (emit 'd2f))
-           (t (assert nil)))
+           (t
+            (sys::%format t "compile-constant :float representation~%")
+            (assert nil)))
      (emit-move-from-stack target representation)
      (return-from compile-constant))
     (:double
@@ -2312,7 +2352,9 @@
             (emit 'f2d))
            ((typep form 'double-float)
             (emit 'ldc2_w (pool-double form)))
-           (t (assert nil)))
+           (t
+            (sys::%format t "compile-constant :double representation~%")
+            (assert nil)))
      (emit-move-from-stack target representation)
      (return-from compile-constant)))
   (cond ((fixnump form)
@@ -2540,7 +2582,9 @@
       (let ((variable (unboxed-fixnum-variable arg)))
         (if variable
             (emit 'iload (variable-register variable))
-            (aver nil)))))
+            (progn
+              (sys::%format t "emit-push-int~%")
+              (aver nil))))))
 
 (declaim (ftype (function (t) t) emit-push-long))
 (defun emit-push-long (arg)
@@ -3940,6 +3984,7 @@
          (emit 'swap) ; array index value
          (emit 'aastore))
         (t
+         (sys::%format t "compile-binding~%")
          (aver nil))))
 
 (defknown compile-progn-body (t t &optional t) t)
@@ -6457,6 +6502,7 @@
        (emit 'pop)
        (emit 'iconst_1))
       (:char
+       (sys::%format t "p2-length: :char case~%")
        (aver nil))
       (t
        (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+)))
@@ -7454,6 +7500,7 @@
                    (:int
                     (emit 'iload (variable-register variable)))
                    (:char
+                    (sys::%format t "compile-var-ref :char case~%")
                     (aver nil))
                    (:long
                     (emit 'iload (variable-register variable))
@@ -7486,6 +7533,7 @@
                     (emit 'lload (variable-register variable))
                     (emit 'l2i))
                    (:char
+                    (sys::%format t "compile-var-ref :char case 2~%")
                     (aver nil))
                    (:long
                     (emit 'lload (variable-register variable)))
@@ -7523,6 +7571,7 @@
                  (fix-boxing representation (variable-derived-type variable))
                  (emit-move-from-stack target representation))
                 (t
+                 (sys::%format t "compile-var-ref general case~%")
                  (aver nil)))))))
 
 (defun p2-set (form target representation)