~ chicken-core (chicken-5) 0cb8eb7c910284c1696700ab5f45018c8822286e

commit 0cb8eb7c910284c1696700ab5f45018c8822286e
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri May 20 12:32:07 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri May 20 12:32:07 2011 +0200

    fixed unboxing bugs related to assignment; unbox C_a_i_fix_to_flo

diff --git a/chicken.h b/chicken.h
index dfa41a7b..3c3d676a 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1170,6 +1170,7 @@ extern double trunc(double);
 #define C_a_i_flonum(ptr, i, n)         C_flonum(ptr, n)
 #define C_a_i_data_mpointer(ptr, n, x)  C_mpointer(ptr, C_data_pointer(x))
 #define C_a_i_fix_to_flo(p, n, f)       C_flonum(p, C_unfix(f))
+#define C_cast_to_flonum(n)             ((double)(n))
 #define C_a_i_mpointer(ptr, n, x)       C_mpointer(ptr, (x))
 #define C_a_u_i_pointer_inc(ptr, n, p, i) C_mpointer(ptr, (C_char *)(p) + C_unfix(i))
 #define C_pointer_eqp(x, y)             C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
diff --git a/unboxing.scm b/unboxing.scm
index 4871e256..174ede5d 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -301,6 +301,51 @@
 	       n))
 	    n))
 
+	(define (straighten-unboxed-assignment! n)
+	  ;; change `(##core#unboxed_set! <v> <type> (let (...) <x>))' and
+	  ;;        `(let (...) (##core#unboxed_set! <v> <type> <x>))' 
+	  ;; (also for "##core#let_unboxed")
+	  (let* ((class (node-class n))
+		 (subs (node-subexpressions n))
+		 (params (node-parameters n))
+		 (arg1 (first subs))
+		 (letsubs (node-subexpressions arg1)))
+	    (when (memq (node-class arg1) '(let ##core#let_unboxed))
+	      (d "straighten unboxed assignment: ~a" params)
+	      (let-values (((bvals body) (split-at letsubs (sub1 (length letsubs)))))
+		(copy-node!
+		 (make-node
+		  (node-class arg1)
+		  (node-parameters arg1)
+		  (append
+		   bvals
+		   (list 
+		    (straighten-unboxed-assignment! (make-node class params body)))))
+		 n)))
+	    n))
+
+	(define (straighten-assignment! n)
+	  ;; change `(set! <v> (##core#let_unboxed (...) <x>))' to
+	  ;;        `(##core#let_unboxed (...) (set! <v> <x>))' 
+	  (let* ((class (node-class n))
+		 (subs (node-subexpressions n))
+		 (params (node-parameters n))
+		 (arg1 (first subs))
+		 (letsubs (node-subexpressions arg1)))
+	    (when (eq? (node-class arg1) '##core#let_unboxed)
+	      (d "straighten assignment: ~a" params)
+	      (let-values (((bvals body) (split-at letsubs (sub1 (length letsubs)))))
+		(copy-node!
+		 (make-node
+		  '##core#let_unboxed
+		  (node-parameters arg1)
+		  (append
+		   bvals
+		   (list 
+		    (straighten-assignment! (make-node class params body)))))
+		 n)))
+	    n))
+
 	;; walk node and return either "(<var> . <type>)" or #f
 	;; - at second pass: rewrite "##core#inline[_allocate]" nodes
 	(define (walk n dest udest pass2?)
@@ -395,12 +440,15 @@
 			     (a (assq var e))
 			     (val (walk (first subs) var (and a (cdr a)) pass2?)))
 			(cond (pass2?
-			       (when (and a (cdr a)) ; may have mutated
-				 (copy-node!
-				  (make-node
-				   '##core#unboxed_set! (list (alias var) (cdr a)) subs)
-				  n)))
-			      ((and val (cdr val))
+			       (cond ((and a (cdr a)) ; may have mutated in walk above
+				      (copy-node!
+				       (make-node
+					'##core#unboxed_set! (list (alias var) (cdr a)) subs)
+				       n)
+				      (straighten-unboxed-assignment! n))
+				     (else
+				      (straighten-assignment! n))))
+			      ((and a val (cdr val))
 			       (unboxed! var (cdr val)))
 			      (else 
 			       (boxed! var)
@@ -505,7 +553,8 @@
   (C_a_i_flonum_truncate (flonum) flonum "C_trunc")
   (C_a_i_flonum_ceiling (flonum) flonum "C_ceil")
   (C_a_i_flonum_floor (flonum) flonum "C_floor")
-  (C_a_i_flonum_round (flonum) flonum "C_round"))
+  (C_a_i_flonum_round (flonum) flonum "C_round")
+  (C_a_i_fix_to_flo (fixnum) flonum "C_cast_to_flonum"))
 
 ;; others
 (define-unboxed-ops