From 42e3d53d0086e953b83c86dca333ad2e51e91d00 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Mon, 7 Apr 2008 10:20:05 -0400
Subject: [PATCH] I CAN HAZ CONS in 64BIT!

---
 scheme/ikarus.intel-assembler.ss | 33 ++++++++++++++++++--------------
 scheme/test64.ss                 | 24 +++++++++++++++++++++--
 src/ikarus-print.c               |  2 +-
 3 files changed, 42 insertions(+), 17 deletions(-)

diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss
index 08a724b..ca47410 100644
--- a/scheme/ikarus.intel-assembler.ss
+++ b/scheme/ikarus.intel-assembler.ss
@@ -469,27 +469,24 @@
             (lambda (a0 a1)
               (cond
                 [(and (imm? a0) (reg32? a1))
-                 (error 'REC+RM "not here 5")
-                 (if (reg-requires-REX? a1) 
-                     (C 4 (REX.R #b001 ac))
-                     ac)]
+                 (if (reg-requires-REX? a1)
+                     (REX.R #b001 ac)
+                     (REX.R 0 ac))]
                 [(and (imm? a1) (reg32? a0))
-                 (error 'REC+RM "not here 6")
                  (if (reg-requires-REX? a0) 
-                     (C 5 (REX.R #b001 ac))
-                     ac)]
+                     (REX.R #b001 ac)
+                     (REX.R 0 ac))]
                 [(and (reg32? a0) (reg32? a1))
-                 (error 'REC+RM "not here 7")
                  (if (reg-requires-REX? a0) 
                      (if (reg-requires-REX? a1)
                          (error 'REX+RM "unhandled x1" a0 a1)
                          (C 6 (REX.R #b010 ac)))
                      (if (reg-requires-REX? a1)
                          (error 'REX+RM "unhandled x3" a0 a1)
-                         ac))]
+                         (REX.R 0 ac)))]
                 [(and (imm? a0) (imm? a1)) 
-                 (error 'REC+RM "not here 8")
-                 ac]
+                 ;(error 'REC+RM "not here 8")
+                 (REX.R 0 ac)]
                 [else (die 'REX+RM "unhandled" a0 a1)]))))]
     [(reg? rm) 
      (let* ([bits 0]
@@ -509,6 +506,14 @@
     [(4) (CODE c ac)]
     [else (REX.R 0 (CODE c ac))]))
 
+(define (trace-ac ac1 ac2)
+  (printf "~s\n" 
+    (let f ([ls ac2]) 
+      (cond
+        [(eq? ls ac1) '()]
+        [else (cons (car ls) (f (cdr ls)))])))
+  ac2)
+
 (define (CR c r ac) 
   (REX+r r (CODE+r c r ac)))
 (define (CR* c r rm ac)
@@ -541,9 +546,9 @@
    [(cltd)                                (CODE #x99 ac)]
    [(movl src dst)
     (cond
-      [(and (imm? src) (reg? dst))        (CR #xB8 dst (IMM src ac))]
-      [(and (imm? src) (mem? dst))        (CR* #xC7 '/0 dst (IMM src ac))]
-      [(and (reg? src) (reg? dst))    (CR* #x89 src dst ac)]
+      [(and (imm? src) (reg? dst))      (CR #xB8 dst (IMM src ac))]
+      [(and (imm? src) (mem? dst))      (CR* #xC7 '/0 dst (IMM32 src ac))]
+      [(and (reg? src) (reg? dst))      (CR* #x89 src dst ac)]
       [(and (reg? src) (mem? dst))      (CR* #x89 src dst ac)]
       [(and (mem? src) (reg? dst))      (CR* #x8B dst src ac)]
       [else (die who "invalid" instr)])]
diff --git a/scheme/test64.ss b/scheme/test64.ss
index 4081787..3490556 100755
--- a/scheme/test64.ss
+++ b/scheme/test64.ss
@@ -16,9 +16,9 @@
 
 ;;; vim:syntax=scheme
 (import 
-  (ikarus compiler)
+  (ikarus.compiler)
   (match)
-  (except (ikarus) assembler-output))
+  (except (ikarus) scc-letrec  optimize-cp optimize-level assembler-output))
 
 (define (compile1 x)
   (let ([p (open-file-output-port "test64.fasl" (file-options no-fail))])
@@ -69,6 +69,7 @@
     [fx+ $fx+]
     [fx- $fx-]
     [fx* $fx*]
+    [fxadd1 $fxadd1]
     [fxlogor $fxlogor]
     [fxlogand $fxlogand]
     [fxlognot $fxlognot]
@@ -77,6 +78,10 @@
     [fx<= $fx<=]
     [fx> $fx>]
     [fx>= $fx>=]
+    [pair? pair?]
+    [cons cons]
+    [car $car]
+    [cdr $cdr]
     ))
 
 
@@ -120,6 +125,21 @@
 (include "tests/tests-1.4-req.scm")
 (include "tests/tests-1.5-req.scm")
 (include "tests/tests-1.6-req.scm")
+(include "tests/tests-1.7-req.scm")
+(include "tests/tests-1.8-req.scm")
+
+
+(current-primitive-locations
+  (lambda (x) 
+    (define prims
+      '(do-overflow 
+        $apply-nonprocedure-error-handler 
+        $incorrect-args-error-handler 
+        $multiple-values-error))
+    (cond
+      [(memq x prims) x]
+      [else (error 'current-primloc "invalid" x)])))
+
 
 (test-all)
 (printf "Passed ~s tests\n" (length all-tests))
diff --git a/src/ikarus-print.c b/src/ikarus-print.c
index 35a305f..2fe5271 100644
--- a/src/ikarus-print.c
+++ b/src/ikarus-print.c
@@ -107,7 +107,7 @@ print(FILE* fh, ikptr x){
     fprintf(fh, "(");
     print(fh, ref(x, off_car));
     ikptr d = ref(x, off_cdr);
-    fprintf(stderr, "d=0x%016lx\n", (long int)d);
+    /* fprintf(stderr, "d=0x%016lx\n", (long int)d); */
     while(1){
       if(is_pair(d)){
         fprintf(fh, " ");