From 943a72f01f3135f7e168cafef7d4d03db43ea3dd Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@gmail.com>
Date: Sun, 24 Jan 2010 00:13:01 +0300
Subject: [PATCH] fixed a bug in the register allocator that was rewriting    
 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 | 46 +++++++++++++++++++++---------
 scheme/ikarus.compiler.ss          | 13 ---------
 scheme/last-revision               |  2 +-
 3 files changed, 34 insertions(+), 27 deletions(-)

diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss
index b6c687f..6df5a58 100644
--- a/scheme/ikarus.compiler.altcogen.ss
+++ b/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
diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index b5ca386..e2f7e07 100644
--- a/scheme/ikarus.compiler.ss
+++ b/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)
diff --git a/scheme/last-revision b/scheme/last-revision
index 824cab0..e4cda12 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1867
+1868