guile/guile-lightning test.scm

[Marius Vollmer]

CVSROOT:        /cvs
Module name:    guile
Changes by:     Marius Vollmer <address@hidden> 01/03/24 20:32:17

Modified files:
        guile-lightning: test.scm 

Log message:
        More fun with fixnums.

CVSWeb URLs:
http://subversions.gnu.org/cgi-bin/cvsweb/guile/guile-lightning/test.scm.diff?r1=1.3&r2=1.4

Patches:
Index: guile/guile-lightning/test.scm
diff -u guile/guile-lightning/test.scm:1.3 guile/guile-lightning/test.scm:1.4
--- guile/guile-lightning/test.scm:1.3  Tue Mar 20 15:47:43 2001
+++ guile/guile-lightning/test.scm      Sat Mar 24 20:32:17 2001
@@ -1,50 +1,87 @@
-(load "lightning.scm")
+(use-modules (ice-9 time))
 (use-modules (lightning))
 
+(dynamic-call "init_fib" (dynamic-link "./x.so"))
+
 (define (fib n)
   (if (< n 2)
       1
       (+ (fib (- n 1)) (fib (- n 2)))))
 
+(define-asm-macro (arg-prolog . args)
+  (let ((n (length args)))
+    (cons `(prolog ,n)
+         (map (lambda (name) `(arg ,name))
+              args))))
+
+(define-asm-macro (scm-blt-constfix label a fix tmp1)
+  (let ((l0 (gensym "ll"))
+       (l1 (gensym "ll")))
+    `(  (bmc ,l0 ,a (scm 0))
+        (blt ,label ,a ,fix)
+        (b ,l1)
+      ,l0
+        (prepare 2)
+       (mov ,tmp1 ,fix)
+       (pusharg ,tmp1)
+       (pusharg ,a)
+       (finish (subr "scm_less_p"))
+       (retval ,tmp1)
+       (bne ,label ,tmp1 (scm #f))
+      ,l1)))
+
+(define-asm-macro (scm-add-constfix res a fix)
+  (let ((l0 (gensym "ll"))
+       (l1 (gensym "ll"))
+       (fix-sans-tag (logand #xffffffff (* 4 (cadr fix))))) ;; XXX
+  `(  (bmc ,l0 ,a (scm 0))
+      (mov ,res ,a)
+      (boadd ,l0 ,res ,fix-sans-tag)
+      (b ,l1)
+    ,l0
+      (prepare 2)
+      (mov ,res ,fix)
+      (pusharg ,res)
+      (pusharg ,a)
+      (finish (subr "scm_sum"))
+      (retval ,res)
+    ,l1)))
+
+(define-asm-macro (scm-add res a b)
+  (let ((l0 (gensym "ll"))
+       (l1 (gensym "ll")))
+    `(  (bmc ,l0 ,a (scm 0))
+       (bmc ,l0 ,b (scm 0))
+       (sub ,res ,a (scm 0))
+       (boadd ,l0 ,res ,b)
+       (b ,l1)
+      ,l0
+        (prepare 2)
+       (pusharg ,b)
+       (pusharg ,a)
+       (finish (subr "scm_sum"))
+       (retval ,res)
+      ,l1)))
+
 (define asm-fib (assemble `(fib
-                             (prolog 1)
-                             (arg n)
+                             (arg-prolog n)
                              (getarg v0 n)
-                             (prepare 2)
-                             (mov r0 (scm 2))
-                             (pusharg r0)
-                             (pusharg v0)
-                             (finish (subr "less_p"))
-                             (retval r0)
-                             (beq l0 r0 (scm #f))
-                             (mov ret (scm 1))
-                             (ret)
-                           l0
-                             (prepare 2)
-                             (mov r0 (scm 2))
-                             (pusharg r0)
-                             (pusharg v0)
-                             (finish (subr "difference"))
-                             (retval r0)
+                             (scm-blt-constfix l0 v0 (scm 2) r0)
+                             (scm-add-constfix r0 v0 (scm -2))
                              (prepare 1)
                              (pusharg r0)
                              (finish (label fib))
                              (retval v2)
-                             (prepare 2)
-                             (mov r0 (scm 1))
-                             (pusharg r0)
-                             (pusharg v0)
-                             (finish (subr "difference"))
-                             (retval r0)
+                             (scm-add-constfix r0 v0 (scm -1))
                              (prepare 1)
                              (pusharg r0)
                              (finish (label fib))
                              (retval v1)
-                             (prepare 2)
-                             (pusharg v2)
-                             (pusharg v1)
-                             (finish (subr "sum"))
-                             (retval ret)
+                             (scm-add ret v1 v2)
+                             (b l1)
+                           l0
+                             (mov ret (scm 1))
+                           l1
                              (ret))))
 
 (define asm-fixfib (assemble `(fib
@@ -71,6 +108,16 @@
                                 (add ret ret v1)
                                 (ret))))
 
-;(disassemble asm-fib)
+(define asm-inc (assemble `(  (prolog 1)
+                             (arg n)
+                             (getarg r1 n)
+                             (scm-add-constfix ret r1 (scm 1))
+                             (ret))))
 
-(assert-repl-verbosity #t)
+(define asm-dec (assemble `(  (prolog 1)
+                             (arg n)
+                             (getarg r1 n)
+                             (scm-add-constfix ret r1 (scm -1))
+                             (ret))))
+
+;(disassemble asm-fib)