~ chicken-core (chicken-5) 0e2916d1d90bdf95fdd57ecad9c75b9ff6fec647
commit 0e2916d1d90bdf95fdd57ecad9c75b9ff6fec647
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Mar 2 07:11:38 2011 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 2 07:11:38 2011 -0500
don't drop arguments for specialization-rewrites that expand into constant
diff --git a/batch-driver.scm b/batch-driver.scm
index 81a74e1e..15c8809e 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -514,6 +514,8 @@
(debugging 'p "performing scrutiny")
(scrutinize node0 db do-scrutinize do-specialize)
(end-time "scrutiny")
+ (when do-specialize
+ (print-node "specialization" '|P| node0))
(set! first-analysis #t) )
(when do-lambda-lifting
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 45374e52..ce8b3ed7 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -53,6 +53,7 @@ the source text should be read from standard input.
0 show database before lambda-lifting pass
S show applications of compiler syntax
T show expressions after converting to node tree
+ P show expressions after specialization
L show expressions after lambda-lifting
U show expressions after unboxing
M show syntax-/runtime-requirements
diff --git a/support.scm b/support.scm
index cb9c100a..19e333db 100644
--- a/support.scm
+++ b/support.scm
@@ -495,7 +495,11 @@
[body (caddr x)] )
(if (null? bs)
(walk body)
- (make-node 'let (unzip1 bs)
+ (make-node 'let
+ (map (lambda (v)
+ ;; for temporaries introduced by specialization
+ (if (eq? '#:tmp v) (gensym) v))
+ (unzip1 bs))
(append (map (lambda (b) (walk (cadr b))) (cadr x))
(list (walk body)) ) ) ) ) )
((lambda ##core#lambda)
@@ -541,7 +545,8 @@
(map walk x) ) ) ) ) )
(else (make-node '##core#call '(#f) (map walk x))) ) )
(let ([exp2 (walk exp)])
- (debugging 'o "eliminated procedure checks" count)
+ (when (positive? count)
+ (debugging 'o "eliminated procedure checks" count))
exp2) ) )
(define (build-expression-tree node)
diff --git a/types.db b/types.db
index 21f98787..b2faae22 100644
--- a/types.db
+++ b/types.db
@@ -27,11 +27,11 @@
;; scheme
(not (procedure not (*) boolean)
- (((not boolean)) '#t))
+ (((not boolean)) (let ((#:tmp #(1))) '#t)))
(boolean? (procedure boolean? (*) boolean)
- ((boolean) '#t)
- (((not boolean)) '#f))
+ ((boolean) (let ((#:tmp #(1))) '#t))
+ (((not boolean)) (let ((#:tmp #(1))) '#f)))
(eq? (procedure eq? (* *) boolean))
@@ -44,8 +44,8 @@
((* (or fixnum symbol char eof null undefined) (eq? #(1) #(2)))))
(pair? (procedure pair? (*) boolean)
- ((pair) '#t)
- (((not pair)) '#f))
+ ((pair) (let ((#:tmp #(1))) '#t))
+ (((not pair)) (let ((#:tmp #(1))) '#f)))
(cons (procedure cons (* *) pair))
@@ -84,8 +84,8 @@
(set-car! (procedure set-car! (pair *) undefined) ((pair *) (##sys#setslot #(1) 0 #(2))))
(set-cdr! (procedure set-cdr! (pair *) undefined) ((pair *) (##sys#setslot #(1) 1 #(2))))
-(null? (procedure null? (*) boolean) ((null) #t) ((not null) #f))
-(list? (procedure list? (*) boolean) (((or null pair list)) #t) (((not (or null pair list))) #f))
+(null? (procedure null? (*) boolean) ((null) (let ((#:tmp #(1))) #t)) ((not null) (let ((#:tmp #(1))) #f)))
+(list? (procedure list? (*) boolean) (((or null pair list)) (let ((#:tmp #(1))) #t)) (((not (or null pair list))) (let ((#:tmp #(1))) #f)))
(list (procedure list (#!rest) list))
(length (procedure length (list) fixnum) ((list) (##core#inline "C_u_i_length" #(1))))
(list-tail (procedure list-tail (list fixnum) *))
@@ -100,38 +100,38 @@
(assoc (procedure assoc (* list #!optional (procedure (* *) *)) *))
(symbol? (procedure symbol? (*) boolean)
- ((symbol) #t)
- (((not symbol)) #f))
+ ((symbol) (let ((#:tmp #(1))) #t))
+ (((not symbol)) (let ((#:tmp #(1))) #f)))
(symbol-append (procedure symbol-append (#!rest symbol) symbol))
(symbol->string (procedure symbol->string (symbol) string))
(string->symbol (procedure string->symbol (string) symbol))
(number? (procedure number? (*) boolean)
- (((or fixnum float number)) #t)
- (((not (or fixnum float number)) #f)))
+ (((or fixnum float number)) (let ((#:tmp #(1))) #t))
+ (((not (or fixnum float number)) (let ((#:tmp #(1))) #f))))
(integer? (procedure integer? (*) boolean)
- ((fixnum) #t)
+ ((fixnum) (let ((#:tmp #(1))) #t))
((float) (fpinteger? #(1))))
(exact? (procedure exact? (*) boolean)
- ((fixnum) #t)
- ((float) #f))
+ ((fixnum) (let ((#:tmp #(1))) #t))
+ ((float) (let ((#:tmp #(1))) #f)))
(real? (procedure real? (*) boolean)
- (((or fixnum float number)) #t))
+ (((or fixnum float number)) (let ((#:tmp #(1))) #t)))
(complex? (procedure complex? (*) boolean)
- (((or fixnum float number)) #t)
- (((not (or fixnum float number))) #f))
+ (((or fixnum float number)) (let ((#:tmp #(1))) #t))
+ (((not (or fixnum float number))) (let ((#:tmp #(1))) #f)))
(inexact? (procedure inexact? (*) boolean)
- ((fixnum) #f)
- ((float) #t))
+ ((fixnum) (let ((#:tmp #(1))) #f))
+ ((float) (let ((#:tmp #(1))) #t)))
(rational? (procedure rational? (*) boolean)
- ((fixnum) #t))
+ ((fixnum) (let ((#:tmp #(1))) #t)))
(zero? (procedure zero? (number) boolean)
((fixnum) (eq? #(1) 0)))
@@ -363,7 +363,7 @@
(fixnum-bits fixnum)
(fixnum-precision fixnum)
(fixnum? (procedure fixnum? (*) boolean)
- ((fixnum) #t))
+ ((fixnum) (let ((#:tmp #(1))) #t)))
(flonum-decimal-precision fixnum)
(flonum-epsilon float)
(flonum-maximum-decimal-exponent fixnum)
@@ -374,7 +374,7 @@
(flonum-print-precision (procedure (#!optional fixnum) fixnum))
(flonum-radix fixnum)
(flonum? (procedure flonum? (*) boolean)
- ((float) #t))
+ ((float) (let ((#:tmp #(1))) #t)))
(flush-output (procedure flush-output (#!optional port) undefined))
(force-finalizers (procedure force-finalizers () undefined))
(fp- (procedure fp- (float float) float))
Trap