Passing 685 tests in 64bit including handling of some foreign calls.

scheme/ikarus.intel-assembler.ss

@@ -802,10 +802,11 @@
                 (fx+ ac 1)
                 (case (car x)
                   [(byte) (fx+ ac 1)]
-                  [(relative foreign-label local-relative)
+                  [(relative local-relative)
                    (fx+ ac 4)]
                   [(label) ac]
-                  [(word reloc-word reloc-word+ label-addr current-frame-offset)
+                  [(word reloc-word reloc-word+ label-addr 
+                    current-frame-offset foreign-label)
                    (+ ac wordsize)]
                   [else (die 'compute-code-size "unknown instr" x)])))
           0 
@@ -876,9 +877,9 @@
                   [(byte) 
                    (code-set! x idx (cdr a))
                    (f (cdr ls) (fx+ idx 1) reloc)]
-                  [(relative local-relative foreign-label)
+                  [(relative local-relative)
                    (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
-                  [(reloc-word reloc-word+ label-addr)
+                  [(reloc-word reloc-word+ label-addr foreign-label)
                    (f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc))]
                   [(word)
                    (let ([v (cdr a)])

scheme/last-revision

@@ -1 +1 @@
-1442
+1443

scheme/test64.ss

@@ -29,9 +29,13 @@
 (define (compile-and-run x) 
   (compile1 x)
   (let ([rs (system "../src/ikarus -b test64.fasl > test64.out")])
-    (unless (= rs 0) (error 'run1 "died"))
+    (unless (= rs 0) (error 'run1 "died with status" rs))
     (with-input-from-file "test64.out"
-      (lambda () (get-string-all (current-input-port))))))
+      (lambda () 
+        (let ([s (get-string-all (current-input-port))])
+          (if (eof-object? s) 
+              ""
+              s))))))
 
 (define (compile-test-and-run expr expected)
   (printf "Compiling:\n")
@@ -233,6 +237,9 @@
        (cond
          [(assq x env) => (lambda (p) `(set! ,(cdr p) ,v))]
          [else (error 'fixup "unbound" x)])]
+      [(foreign-call ,str ,[arg*] ...) 
+       (guard (string? str))
+       `(foreign-call ',str ,arg* ...)]
       [(,[rator] ,[rand*] ...) `(,rator ,rand* ...)]
       [,_ (error 'fixup "invalid expression" _)]))
   (Expr x '()))
@@ -260,7 +267,10 @@
  (include "tests/tests-2.3-req.scm")
  (include "tests/tests-2.4-req.scm")
  (include "tests/tests-2.6-req.scm")
- (include "tests/tests-2.8-req.scm"))
+ (include "tests/tests-2.8-req.scm")
+ (include "tests/tests-2.9-req.scm")
+ )
+
 
 (current-primitive-locations
   (lambda (x) 
@@ -277,8 +287,6 @@
       [else (error 'current-primloc "invalid" x)])))
 
 
-;(assembler-output #t)
-
 (test-all)
 (printf "Passed ~s tests\n" (length all-tests))
 (printf "Happy Happy Joy Joy\n")

src/ikarus-enter.S

@@ -124,47 +124,44 @@ L_multi_reentry:
 .align 8
 ik_foreign_call:
 _ik_foreign_call:
-  movl %esp, 8(%esi)     # (movl fpr (pcb-ref 'frame-pointer))
-  movl %ebp, 0(%esi)     # (movl apr (pcb-ref 'allocation-pointer))
-  movl %esp, %ebx        # (movl fpr ebx)
-  movl 24(%esi), %esp    # (movl (pcb-ref 'system-stack) esp)
+  movq %rsp, 16(%rsi)    # (movl fpr (pcb-ref 'frame-pointer))
+  movq %rbp, 0(%rsi)     # (movl apr (pcb-ref 'allocation-pointer))
+  movq %rsp, %rbx        # (movl fpr ebx)
+  movq 48(%rsi), %rsp    # (movl (pcb-ref 'system-stack) esp)
   # %esp is the system stack, %eax is the index to the last arg,
   # %esi is the pcb.
-  # Now, the value of %esp is 16-byte aligned
-  # we always push %esi (4 bytes) and do a call (4 bytes),
-  # 0 args require 6 (2) pushes => argc=   0 (0000): %esp +=  -8
-  # 1 args require 5 (1) pushes => argc=  -4 (1100): %esp +=  -4
-  # 2 args require 4 (0) pushes => argc=  -8 (1000): %esp +=   0
-  # 3 args require 3 (3) pushes => argc= -12 (0100): %esp += -12
-  movl %eax, %ecx
-  andl $15, %ecx
-check_ecx:
-  cmpl $8, %ecx
-  je L_zero
-  cmpl $12, %ecx
-  je L_one
-  cmpl $0, %ecx
-  je L_two
-  push $0
-L_two:
-  push $0
-L_one:
-  push $0
-L_zero:
-  push %rsi             # (pushl pcr)
-  cmpl $0, %eax          # (cmpl (int 0) eax)
-  je L_set               # (je (label Lset))
-L_loop:                  # (label Lloop)
-  movl (%ebx,%eax), %ecx # (movl (mem ebx eax) ecx)
-  push %rcx             # (pushl ecx)
-  addl $4, %eax          # (addl (int 4) eax)
-  cmpl $0, %eax          # (cmpl (int 0) eax)
-  jne L_loop             # (jne (label Lloop))
+
+  # align the system stack by subtracting 8 if it's not 16-byte aligned
+  movq %rsp, %r12
+  andq $15, %r12
+  subq %r12, %rsp
+
+  # AMD64 says: %rbp, %rbx, %r12 .. %r15 are preserved by the callee
+  #             %rdi, %rsi, %rdx, %rcx, %r8, %r9 are parameter regs
+
+  movq %rdi, %r12 # put target of call in %r12
+  movq %rsi, %r13 # put pcb in %r13
+
+  movq %rsi, %rdi # put pcb in first arg reg
+  cmpq $0, %rax
+  je L_zero_args
+  cmpq $-8, %rax
+  je L_one_arg
+  movq $0, %rax
+  movq %rax,0(%rax)
+L_one_arg:
+  movq %rdi, %rsi
+  movq -8(%rbx), %rdi
+  jmp L_set
+
+L_zero_args:
 L_set:                   # (label Lset)
-  call *%rdi             # (call cpr)
-  movl 8(%esi), %esp     # (movl (pcb-ref 'frame-pointer) fpr)
-  movl 0(%esi), %ebp     # (movl (pcb-ref 'allocation-pointer) apr)
-  ret                    # (ret)))
+  call *%r12             # (call cpr)
+L_back:
+  movq %r13, %rsi        # restore pcb from r13
+  movq 16(%rsi), %rsp    # get frame pointer from 16(pcb)
+  movq 0(%rsi), %rbp     # get allocation pointer from 0(pcb)
+  ret                    # return to scheme
 
 #else  
 

src/ikarus-fasl.c

@@ -213,7 +213,7 @@ ik_relocate_code(ikptr code){
         fprintf(stderr, "failed to find foreign name %s: %s\n", name, err);
         exit(-1);
       }
-      ref(data,code_off) = (ikptr)(long)sym;
+      ref(data,code_off) = (ikptr)sym;
       p += (2*wordsize);
     }
     else {