fixed a bug in (not) handling variable-size frames in ikarus-exec.

mov8 mem1 -> mem2
to 
    mov mem1 -> reg
    mov8 reg -> mem2
instead of
    mov8 mem1 reg
    mov reg mem2
which causes unaligned and invalid memory access when the
address mem1 is at a page boundary and the next page is 
unmapped.

scheme/ikarus.compiler.altcogen.ss

@@ -2227,6 +2227,23 @@
         [else (error 'small-operand? "huh?")]))
     (define (mem? x)
       (or (disp? x) (fvar? x)))
+    (define (fix-address x k)
+      (cond
+        [(disp? x) 
+         (let ([s0 (disp-s0 x)] [s1 (disp-s1 x)])
+           (cond
+             [(not (small-operand? s0))
+              (let ([u (mku)])
+                (make-seq
+                  (E (make-asm-instr 'move u s0))
+                  (fix-address (make-disp u s1) k)))]
+             [(not (small-operand? s1))
+              (let ([u (mku)])
+                (make-seq
+                  (E (make-asm-instr 'move u s1))
+                  (fix-address (make-disp s0 u) k)))]
+             [else (k x)]))]
+        [else (k x)]))
     ;;; unspillable effect
     (define (E x)
       (struct-case x
@@ -2235,9 +2252,19 @@
          (make-conditional (P e0) (E e1) (E e2))]
         [(asm-instr op a b) 
          (case op
+           [(load8 load32)
+            (fix-address b
+              (lambda (b)
+                (cond
+                  [(or (register? a) (var? a)) 
+                   (make-asm-instr op a b)]
+                  [else 
+                   (let ([u (mku)])
+                     (make-seq
+                       (make-asm-instr op u b)
+                       (E (make-asm-instr 'move a u))))])))]
            [(logor logxor logand int+ int- int* move 
-                   load8 load32 
-                   int-/overflow int+/overflow int*/overflow)
+             int-/overflow int+/overflow int*/overflow)
             (cond
               [(and (eq? op 'move) (eq? a b)) 
                (make-primcall 'nop '())]
@@ -2256,17 +2283,10 @@
                      (E (make-asm-instr op u b)))
                    (E (make-asm-instr 'move a u))))]
               [(and (mem? a) (not (small-operand? b))) 
-               (case op
-                 [(load32)
-                  (let ([u (mku)])
-                    (make-seq
-                      (E (make-asm-instr 'load32 u b))
-                      (E (make-asm-instr 'move a u))))]
-                 [else
-                  (let ([u (mku)])
-                    (make-seq
-                      (E (make-asm-instr 'move u b))
-                      (E (make-asm-instr op a u))))])]
+               (let ([u (mku)])
+                 (make-seq
+                   (E (make-asm-instr 'move u b))
+                   (E (make-asm-instr op a u))))]
               [(disp? a) 
                (let ([s0 (disp-s0 a)] [s1 (disp-s1 a)])
                  (cond
@@ -2480,12 +2500,7 @@
 
            
 (define (compile-call-frame framesize livemask-vec multiarg-rp call-sequence)
-  (let ([L_CALL (label (gensym))]
-        [padding 
-         (- call-instruction-size
-            (instruction-size call-sequence))])
-    (when (< padding 0) 
-      (error 'compile-call-frame "call sequence too long" call-sequence))
+  (let ([L_CALL (label (gensym))])
     (list 'seq
       (if (or (= framesize 0) (= framesize 1))
           '(seq) 
@@ -2495,9 +2510,9 @@
       `(int ,(* framesize wordsize))
       '(current-frame-offset)
       multiarg-rp
-      `(byte-vector ,(make-vector padding 0))
-      L_CALL
-      call-sequence
+      `(pad ,call-instruction-size
+            ,L_CALL
+            ,call-sequence)
       (if (or (= framesize 0) (= framesize 1))
           '(seq) 
           `(addl ,(* (fxsub1 framesize) wordsize) ,fpr)))))

scheme/ikarus.compiler.ss

@@ -2084,19 +2084,6 @@
               (movl (mem (fx- 0 wordsize) fpr) eax)
               (ret)))))
     SL_values]
-   [(sl-nonprocedure-error-label)
-    (define SL_nonprocedure (gensym "SL_nonprocedure"))
-    (assemble-sources (lambda (x) #f)
-      (list
-        (list 0
-          (label SL_nonprocedure)
-          (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
-          (movl (obj (primref->symbol '$apply-nonprocedure-error-handler)) cpr)
-          (movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr)
-          ;(movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
-          (movl (int (argc-convention 1)) eax)
-          (tail-indirect-cpr-call))))
-    SL_nonprocedure]
    [(sl-cwv-label)
     (define SL_call_with_values (gensym "SL_call_with_values"))
     (assemble-sources (lambda (x) #f)
@@ -2104,18 +2091,20 @@
         (let ([L_cwv_done (gensym)]
               [L_cwv_loop (gensym)]
               [L_cwv_multi_rp (gensym)]
-              [L_cwv_call (gensym)])
+              [L_cwv_call (gensym)]
+              [SL_nonprocedure (gensym "SL_nonprocedure")]
+              [SL_invalid_args (gensym "SL_invalid_args")])
           (list 
               0 ; no free vars
               '(name call-with-values)
               (label SL_call_with_values)
               (cmpl (int (argc-convention 2)) eax)
-              (jne (label (sl-invalid-args-label)))
+              (jne (label SL_invalid_args))
               (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
               (movl ebx cpr)
               (andl (int closure-mask) ebx)
               (cmpl (int closure-tag) ebx)
-              (jne (label (sl-nonprocedure-error-label)))
+              (jne (label SL_nonprocedure))
               (movl (int (argc-convention 0)) eax)
               (compile-call-frame
                  3
@@ -2129,7 +2118,7 @@
               (movl (int (argc-convention 1)) eax)
               (andl (int closure-mask) ebx)
               (cmpl (int closure-tag) ebx)
-              (jne (label (sl-nonprocedure-error-label)))
+              (jne (label SL_nonprocedure))
               (tail-indirect-cpr-call)
               ;;; multiple values returned
               (label L_cwv_multi_rp)
@@ -2153,8 +2142,27 @@
               (movl cpr ebx)
               (andl (int closure-mask) ebx)
               (cmpl (int closure-tag) ebx)
-              (jne (label (sl-nonprocedure-error-label)))
-              (tail-indirect-cpr-call)))))
+              (jne (label SL_nonprocedure))
+              (tail-indirect-cpr-call)
+
+              (label SL_nonprocedure)
+              (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
+              (movl (obj (primref->symbol '$apply-nonprocedure-error-handler)) cpr)
+              (movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr)
+              (movl (int (argc-convention 1)) eax)
+              (tail-indirect-cpr-call)
+
+              (label SL_invalid_args)
+              ;;;
+              (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
+              (negl eax)
+              (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
+              (movl (obj (primref->symbol '$incorrect-args-error-handler)) cpr)
+              (movl (mem (- disp-symbol-record-proc record-tag) cpr) cpr)
+              (movl (int (argc-convention 2)) eax)
+              (tail-indirect-cpr-call)
+
+              ))))
     SL_call_with_values]
    ))
 

scheme/ikarus.intel-assembler.ss

@@ -16,7 +16,7 @@
 
 
 (library (ikarus.intel-assembler)
-  (export instruction-size assemble-sources code-entry-adjustment)
+  (export assemble-sources code-entry-adjustment)
   (import 
     (ikarus)
     (rnrs bytevectors)
@@ -35,9 +35,11 @@
       [else
        (f (car ls) (fold f init (cdr ls)))])))
 
+
 (define convert-instructions
   (lambda (ls)
-    (fold convert-instruction '() ls)))
+    (parameterize ([local-labels (uncover-local-labels ls)])
+      (fold convert-instruction '() ls))))
 
 (define register-mapping
   ;;; reg  cls  idx  REX.R
@@ -216,7 +218,11 @@
          (byte (sra n 24))
          ac)]
       [(label? n)
-       (cons (cons 'relative (label-name n)) ac)]
+       (cond 
+         [(local-label? (label-name n))
+          (cons (cons 'local-relative (label-name n)) ac)]
+         [else
+          (cons (cons 'relative (label-name n)) ac)])]
       [else (die 'IMM32 "invalid" n)])))
 
 (define IMM
@@ -255,7 +261,12 @@
       [(foreign? n)
        (cons (cons 'foreign-label (label-name n)) ac)]
       [(label? n)
-       (cons (cons 'relative (label-name n)) ac)]
+       (cond 
+         [(local-label? (label-name n))
+          (cons (cons 'local-relative (label-name n)) ac)]
+         [else
+          (cons (cons 'relative (label-name n)) ac)])]
+       ;(cons (cons 'relative (label-name n)) ac)]
       [else (die 'IMM "invalid" n)])))
 
 
@@ -376,6 +387,7 @@
      (begin
        (add-instruction (name* instr ac arg** ...) b* b** ...) ...)]))
 
+
 (define (convert-instruction a ac)
   (cond
     [(getprop (car a) *cogen*) =>
@@ -400,6 +412,21 @@
                 (die 'convert-instruction "incorrect args" a))])))]
     [(eq? (car a) 'seq) 
      (fold convert-instruction ac (cdr a))]
+    [(eq? (car a) 'pad)
+     (let ()
+       (define (find-prefix x ls)
+         (let f ([ls ls])
+           (cond
+             [(eq? ls x) '()]
+             [else 
+              (let ([a (car ls)])
+                (if (and (pair? a) (eq? (car a) 'bottom-code))
+                    (f (cdr ls))
+                    (cons a (f (cdr ls)))))])))
+       (let ([n (cadr a)] [code (cddr a)])
+         (let ([ls (fold convert-instruction ac code)])
+           (let ([m (compute-code-size (find-prefix ac ls))])
+             (append (make-list (- n m) 0) ls)))))]
     [else (die 'convert-instruction "unknown instruction" a)]))
 
 (define (RM /d dst ac)
@@ -562,6 +589,19 @@
           (cons (car ls) (f (cdr ls))))))
   ls)
 
+(define (jmp-pc-relative code0 code1 dst ac)
+  (when (= wordsize 4)
+    (error 'intel-assembler "no pc-relative jumps in 32-bit mode"))
+  (let ([g (gensym)])
+    (CODE code0
+      (CODE code1
+        (cons*
+          `(local-relative . ,g)
+          `(bottom-code
+             (label . ,g)
+             (label-addr . ,(label-name dst)))
+          ac)))))
+
 (add-instructions instr ac
    [(ret)                                 (CODE #xC3 ac)]
    [(cltd)                                (C #x99 ac)]
@@ -721,12 +761,22 @@
       [else (die who "invalid" instr)])]
    [(jmp dst)
     (cond
-      [(imm? dst)                     (CODE #xE9 (IMM32 dst ac))]
+      [(and (label? dst) (local-label? (label-name dst)))
+       (CODE #xE9 (cons `(local-relative . ,(label-name dst)) ac))]
+      [(imm? dst)
+       (if (= wordsize 4) 
+           (CODE #xE9 (IMM32 dst ac))
+           (jmp-pc-relative #xFF #x25 dst ac))]
       [(mem? dst)                     (CR*  #xFF '/4 dst ac)]
       [else (die who "invalid jmp target" dst)])]
    [(call dst)
     (cond
-      [(imm? dst)                     (CODE #xE8 (IMM32 dst ac))]
+      [(and (label? dst) (local-label? (label-name dst)))
+       (CODE #xE8 (cons `(local-relative . ,(label-name dst)) ac))]
+      [(imm? dst)
+       (if (= wordsize 4)
+           (CODE #xE8 (IMM32 dst ac))
+           (jmp-pc-relative #xFF #x15 dst ac))]
       [(mem? dst)                     (CR* #xFF '/2 dst ac)]
       [(reg? dst)                     (CR* #xFF '/2 dst ac)]
       [else (die who "invalid jmp target" dst)])]
@@ -812,7 +862,7 @@
 ))
 
 
-(define compute-code-size 
+(define compute-code-size
   (lambda (ls)
     (fold (lambda (x ac)
             (if (fixnum? x)
@@ -824,12 +874,13 @@
                   [(label) ac]
                   [(word reloc-word reloc-word+ label-addr 
                     current-frame-offset foreign-label)
-                   (+ ac wordsize)]
+                   (fx+ ac wordsize)]
+                  [(bottom-code) 
+                   (fx+ ac (compute-code-size (cdr x)))]
                   [else (die 'compute-code-size "unknown instr" x)])))
           0 
           ls)))
 
-
 (define set-label-loc!
   (lambda (x loc)
     (when (getprop x '*label-loc*)
@@ -841,7 +892,6 @@
     (or (getprop x '*label-loc*)
         (die 'compile "undefined label" x))))
 
-
 (define unset-label-loc!
   (lambda (x)
     (remprop x '*label-loc*)))
@@ -868,22 +918,41 @@
           (code-set! code (fx+ idx 7) (fxlogand (fxsra x 53) #xFF))])]
       [else (die 'set-code-word! "unhandled" x)])))
  
+(define local-labels (make-parameter '()))
+(define (local-label? x) (and (memq x (local-labels)) #t))
+
+(define (uncover-local-labels ls)
+  (define locals '())
+  (define find
+    (lambda (x)
+      (when (pair? x)
+        (case (car x)
+          [(label)
+           (set! locals (cons (label-name x) locals))]
+          [(seq pad)
+           (for-each find (cdr x))]))))
+  (for-each find ls)
+  locals)
+
 (define (optimize-local-jumps ls)
   (define locals '())
   (define g (gensym))
-  (for-each
-    (lambda (x)
-      (when (and (pair? x) (eq? (car x) 'label))
-        (putprop (cdr x) g 'local)
-        (set! locals (cons (cdr x) locals))))
-    ls)
-  (for-each
-    (lambda (x)
-      (when (and (pair? x)
-                 (eq? (car x) 'relative)
-                 (eq? (getprop (cdr x) g) 'local))
-        (set-car! x 'local-relative)))
-    ls)
+  (define (mark x)
+    (when (pair? x)
+      (case (car x)
+        [(label) 
+         (putprop (cdr x) g 'local)
+         (set! locals (cons (cdr x) locals))]
+        [(bottom-code) (for-each mark (cdr x))])))
+  (define (opt x)
+    (when (pair? x)
+      (case (car x)
+        [(relative) 
+         (when (eq? (getprop (cdr x) g) 'local)
+           (set-car! x 'local-relative))]
+        [(bottom-code) (for-each opt (cdr x))])))
+  (for-each mark ls)
+  (for-each opt ls)
   (for-each (lambda (x) (remprop x g)) locals)
   ls)
 
@@ -892,47 +961,52 @@
 (define whack-instructions
   (lambda (x ls)
     (define f
-      (lambda (ls idx reloc)
+      (lambda (ls idx reloc bot*)
         (cond
-          [(null? ls) reloc]
+          [(null? ls) 
+           (if (null? bot*) 
+               reloc
+               (f (car bot*) idx reloc (cdr bot*)))]
           [else
            (let ([a (car ls)])
              (if (fixnum? a)
                  (begin
                    (code-set! x idx a)
-                   (f (cdr ls) (fxadd1 idx) reloc))
+                   (f (cdr ls) (fxadd1 idx) reloc bot*))
                  (case (car a)
                   [(byte) 
                    (code-set! x idx (cdr a))
-                   (f (cdr ls) (fx+ idx 1) reloc)]
+                   (f (cdr ls) (fx+ idx 1) reloc bot*)]
                   [(relative local-relative)
-                   (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc))]
+                   (f (cdr ls) (fx+ idx 4) (cons (cons idx a) reloc) bot*)]
                   [(reloc-word reloc-word+ label-addr foreign-label)
-                   (f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc))]
+                   (f (cdr ls) (fx+ idx wordsize) (cons (cons idx a) reloc) bot*)]
                   [(word)
                    (let ([v (cdr a)])
                       (set-code-word! x idx v)
-                      (f (cdr ls) (fx+ idx wordsize) reloc))]
+                      (f (cdr ls) (fx+ idx wordsize) reloc bot*))]
                   [(current-frame-offset)
                    (set-code-word! x idx idx) ;;; FIXME 64bit
-                   (f (cdr ls) (fx+ idx wordsize) reloc)]
+                   (f (cdr ls) (fx+ idx wordsize) reloc bot*)]
                   [(label)
                    (set-label-loc! (cdr a) (list x idx))
-                   (f (cdr ls) idx reloc)]
+                   (f (cdr ls) idx reloc bot*)]
+                  [(bottom-code)
+                   (f (cdr ls) idx reloc (cons (cdr a) bot*))]
                   [else
                    (die 'whack-instructions "unknown instr" a)])))])))
-    (f ls 0 '())))
+    (f ls 0 '() '())))
 
-
-(define compute-reloc-size 
+(define compute-reloc-size
   (lambda (ls)
     (fold (lambda (x ac)
             (if (fixnum? x)
                 ac
                 (case (car x)
+                  [(word byte label current-frame-offset local-relative) ac]
                   [(reloc-word foreign-label)        (fx+ ac 2)]
                   [(relative reloc-word+ label-addr) (fx+ ac 3)]
-                  [(word byte label current-frame-offset local-relative) ac]
+                  [(bottom-code) (fx+ ac (compute-reloc-size (cdr x)))]
                   [else (die 'compute-reloc-size "unknown instr" x)])))
           0 
           ls)))
@@ -1031,14 +1105,6 @@
           [else (die 'whack-reloc "invalid reloc type" type)]))
       )))
 
-  (define (instruction-size x)
-    (unless (and (pair? x) (getprop (car x) *cogen*))
-      (die 'instruction-size "not an instruction" x))
-    ;;; limitations: does not work if the instruction contains 
-    ;;; a jump to a local label, and the jump is later optimized
-    ;;; to a short jump.
-    (compute-code-size
-      (convert-instruction x '())))
 
 
   (define assemble-sources

scheme/last-revision

@@ -1 +1 @@
-1864
+1869

scheme/pass-specify-rep-primops.ss

@@ -1226,7 +1226,7 @@
   [(V x) 
    (prm 'sll 
      (prm 'srl 
-       (prm 'mref (T x)
+       (prm 'mref32 (T x)
           (K (- (+ disp-flonum-data 4) vector-tag)))
        (K 20))
      (K fx-shift))])

src/ikarus-exec.c

@@ -40,6 +40,9 @@ ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr, ikptr argcount, ikptr cp){
     fprintf(stderr, "exec framesize=0x%016lx  ksize=%ld  rp=0x%016lx\n", 
         framesize, k->size, rp);
 #endif
+    if(framesize == 0){
+      framesize = ref(top, wordsize);
+    }
     if(framesize <= 0){
       fprintf(stderr, "invalid framesize %ld\n", framesize);
       exit(-10);