~ chicken-core (chicken-5) cae038d42c0c0be0eb4703c6be874f323f7f126c
commit cae038d42c0c0be0eb4703c6be874f323f7f126c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jan 18 10:55:50 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Jan 18 10:55:50 2010 +0100
fixed unboxing bug (#164)
diff --git a/distribution/manifest b/distribution/manifest
index db53dbca..7d554159 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -113,6 +113,7 @@ tcp.scm
tests/library-tests.scm
tests/compiler-tests.scm
tests/compiler-tests-2.scm
+tests/compiler-tests-3.scm
tests/inlining-tests.scm
tests/locative-stress-test.scm
tests/r4rstest.scm
diff --git a/tests/compiler-tests-2.scm b/tests/compiler-tests-2.scm
index cd4a567b..f306ed10 100644
--- a/tests/compiler-tests-2.scm
+++ b/tests/compiler-tests-2.scm
@@ -1,4 +1,4 @@
-;;; compiler-tests-2.scm - tests for particular compiler optimizations
+;;; compiler-tests-2.scm - tests for lambda-lifting
;;; rev. 12113 - lambda-lifting breakage, because lambda-bound variables
@@ -24,29 +24,3 @@
(len 0))
(assert (= 3 (len '(1 2 3))))
-
-
-;;; compiler-syntax for map/for-each must be careful when the
-; operator may have side-effects (currently only lambda exprs and symbols
-; are allowed)
-
-(let ((x #f))
- (define (f1 x) (print* x " "))
- (map f1 '(1 2 3))
- (newline)
- (map (begin (assert (not x))
- (set! x #t)
- f1)
- '(1 2 3))
- (map (lambda (x) (print* ":" x)) '(1 2 3))
- (newline))
-
-(let ((x #f))
- (define (f1 x) (print* x " "))
- (let-syntax ((f1 (syntax-rules ()
- ((_ y)
- (begin
- (assert (not x))
- (set! x #t)
- f1)))))
- (for-each f1 '(1 2 3))))
diff --git a/tests/compiler-tests-3.scm b/tests/compiler-tests-3.scm
new file mode 100644
index 00000000..3c3a12e3
--- /dev/null
+++ b/tests/compiler-tests-3.scm
@@ -0,0 +1,54 @@
+;;; compiler-tests-3.scm - tests for unboxing
+
+
+;;; unboxing introduced binding in test-position of conditional
+
+;;; MBROT -- Generation of Mandelbrot set fractal.
+
+(define (count r i step x y)
+
+ (let ((max-count 64)
+ (radius^2 16.0))
+
+ (let ((cr (fp+ r (fp* (exact->inexact x) step)))
+ (ci (fp+ i (fp* (exact->inexact y) step))))
+
+ (let loop ((zr cr)
+ (zi ci)
+ (c 0))
+ (if (= c max-count)
+ c
+ (let ((zr^2 (fp* zr zr))
+ (zi^2 (fp* zi zi)))
+ (if (fp> (fp+ zr^2 zi^2) radius^2)
+ c
+ (let ((new-zr (fp+ (fp- zr^2 zi^2) cr))
+ (new-zi (fp+ (fp* 2.0 (fp* zr zi)) ci)))
+ (loop new-zr new-zi (+ c 1))))))))))
+
+(define (mbrot matrix r i step n)
+ (let loop1 ((y (- n 1)))
+ (if (>= y 0)
+ (let loop2 ((x (- n 1)))
+ (if (>= x 0)
+ (begin
+ (vector-set! (vector-ref matrix x) y (count r i step x y))
+ (loop2 (- x 1)))
+ (loop1 (- y 1)))))))
+
+(define (test n)
+ (let ((matrix (make-vector n)))
+ (let loop ((i (- n 1)))
+ (if (>= i 0)
+ (begin
+ (vector-set! matrix i (make-vector n))
+ (loop (- i 1)))))
+ (mbrot matrix -1.0 -0.5 0.005 n)
+ (vector-ref (vector-ref matrix 0) 0)))
+
+(define (main . args)
+ (let ((r (test 75)))
+ (unless (equal? r 5)
+ (error "incorrect result: " r))))
+
+(main)
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index ec3adb2b..23bcf601 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -95,3 +95,28 @@
(strlen-safe-macro "hello, world")
(strlen-safe-macro* "hello, world")
(strlen-primitive-macro "hello, world"))
+
+;;; compiler-syntax for map/for-each must be careful when the
+; operator may have side-effects (currently only lambda exprs and symbols
+; are allowed)
+
+(let ((x #f))
+ (define (f1 x) (print* x " "))
+ (map f1 '(1 2 3))
+ (newline)
+ (map (begin (assert (not x))
+ (set! x #t)
+ f1)
+ '(1 2 3))
+ (map (lambda (x) (print* ":" x)) '(1 2 3))
+ (newline))
+
+(let ((x #f))
+ (define (f1 x) (print* x " "))
+ (let-syntax ((f1 (syntax-rules ()
+ ((_ y)
+ (begin
+ (assert (not x))
+ (set! x #t)
+ f1)))))
+ (for-each f1 '(1 2 3))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 4374be98..dec3090b 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -37,10 +37,14 @@ echo "======================================== compiler tests ..."
$compile compiler-tests.scm
./a.out
-echo "======================================== compiler tests (2) ..."
+echo "======================================== compiler tests (lambda-lift) ..."
$compile compiler-tests-2.scm -lambda-lift
./a.out
+echo "======================================== compiler tests (unboxing) ..."
+$compile compiler-tests-3.scm -unsafe -unboxing
+./a.out
+
echo "======================================== compiler inlining tests ..."
$compile inlining-tests.scm -optimize-level 3
./a.out
@@ -211,7 +215,7 @@ $compile -e embedded2.scm
./a.out
echo "======================================== timing compilation ..."
-time $compile compiler.scm -O5 -debug pb -v
+time $compile compiler.scm -O5 -debug pb -v -C -Wa,-W
echo "executing ..."
time ./a.out
diff --git a/unboxing.scm b/unboxing.scm
index b563cd53..bdee8a27 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -169,7 +169,7 @@
(straighten-binding! n) ))
(define (straighten-binding! n)
- ;; change `(let ((<v> (let (...) <x2>))) <>x)' into
+ ;; change `(let ((<v> (let (...) <x2>))) <x>)' into
;; `(let (...) (let ((<v> <x2>)) <x>))'
(let* ((subs (node-subexpressions n))
(bnode (first subs))
@@ -192,6 +192,29 @@
(straighten-binding! n)
(straighten-binding! (second (node-subexpressions n))))))
+ (define (straighten-conditional! n)
+ ;; change `(if (let (...) <x1>) <x2> <x3>)' into
+ ;; `(let (...) (if <x1> <x2> <x3>))'
+ (let* ((subs (node-subexpressions n))
+ (bnode (first subs))
+ (bcl (node-class bnode)))
+ (when (memq bcl '(let ##core#let_unboxed))
+ (d "straighten conditional: ~a" (node-parameters bnode))
+ (copy-node!
+ (make-node
+ bcl
+ (node-parameters bnode)
+ (let ((bsubs (node-subexpressions bnode)))
+ (list (first bsubs)
+ (make-node
+ (node-class n)
+ (node-parameters n)
+ (cons (second bsubs) (cdr subs))))))
+ n)
+ (straighten-conditional! (second (node-subexpressions n)))
+ ;;(pp (build-expression-tree n))
+ (straighten-binding! n))))
+
(define (straighten-call! n)
;; change `(<proc> ... (let (...) <x>) ...)' into
;; `(let (...) (<proc> ... <x> ...))'
@@ -321,6 +344,7 @@
((if ##core#cond)
(invalidate (walk (first subs) #f #f pass2?))
+ (straighten-conditional! n)
(let ((r1 (walk (second subs) dest udest pass2?))
(r2 (walk (third subs) dest udest pass2?)))
(merge r1 r2)))
Trap