~ chicken-core (chicken-5) a9d3a22e16c0ab5b888cf72301dedc8c20f1c201
commit a9d3a22e16c0ab5b888cf72301dedc8c20f1c201
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Apr 7 03:23:02 2011 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Apr 7 03:23:02 2011 -0400
predicate-specialization match fixes and tests
diff --git a/csc.scm b/csc.scm
index fd91fa98..f64d5bcf 100644
--- a/csc.scm
+++ b/csc.scm
@@ -353,7 +353,6 @@ Usage: #{csc} FILENAME | OPTION ...
file
-S -scrutinize perform local flow analysis
-types FILENAME load additional type database
- -strict-types assume variable do not change their type
Optimization options:
@@ -386,6 +385,7 @@ Usage: #{csc} FILENAME | OPTION ...
-no-procedure-checks-for-toplevel-bindings
disable procedure call checks for toplevel
bindings
+ -strict-types assume variable do not change their type
Configuration options:
diff --git a/distribution/manifest b/distribution/manifest
index 9636cce3..25b80b51 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -136,6 +136,7 @@ tests/test-finalizers.scm
tests/test-finalizers-2.scm
tests/module-tests-compiled.scm
tests/scrutiny-tests.scm
+tests/scrutiny-tests-2.scm
tests/scrutiny.expected
tests/syntax-rule-stress-test.scm
tests/syntax-tests.scm
diff --git a/manual/Using the compiler b/manual/Using the compiler
index ea782275..bed7bd1b 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -187,6 +187,8 @@ the source text should be read from standard input.
; -static-extension NAME : similar to {{-require-extension NAME}}, but links extension statically (also applies for an explicit {{(require-extension NAME)}}).
+; -strict-types : Assume that the type of variables does not change during their lifetime. This gives more type-information during specialization, but violating this assumption will result in unsafe and incorrectly behaving code.
+
; -types FILENAME : load additional type database from {{FILENAME}}. Type-definitions in {{FILENAME}} will override previous type-definitions.
; -compile-syntax : Makes macros also available at run-time. By default macros are not available at run-time.
diff --git a/scrutinizer.scm b/scrutinizer.scm
index f918d174..51baf162 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -514,52 +514,53 @@
(pname) i (car atypes) (car args)))))
(let ((r (procedure-result-types ptype values-rest (cdr args))))
(d " result-types: ~a" r)
- (when specialize
- ;;XXX we should check whether this is a standard- or extended binding
- (let ((pn (procedure-name ptype))
- (op #f))
- (when pn
- (cond ((and (fx= 1 nargs)
- (variable-mark pn '##compiler#predicate)) =>
- (lambda (pt)
- (cond ((match-specialization (list pt) (cdr args))
- (report
- loc
- (sprintf
- "~athe predicate is called with an argument of type `~a' and will always return true"
- (pname) pt))
+ ;;XXX we should check whether this is a standard- or extended binding
+ (let ((pn (procedure-name ptype))
+ (op #f))
+ (when pn
+ (cond ((and (fx= 1 nargs)
+ (variable-mark pn '##compiler#predicate)) =>
+ (lambda (pt)
+ (cond ((match-specialization (list pt) (cdr args))
+ (report
+ loc
+ (sprintf
+ "~athe predicate is called with an argument of type `~a' and will always return true"
+ (pname) pt))
+ (when specialize
(specialize-node!
node
`(let ((#:tmp #(1))) '#t))
- (set! op (list pn pt)))
- ((match-specialization (list `(not ,pt)) (cdr args))
- (report
- loc
- (sprintf
- "~athe predicate is called with an argument of type `~a' and will always return false"
- (pname) (cadr args)))
+ (set! op (list pn pt))))
+ ((match-specialization (list `(not ,pt)) (cdr args))
+ (report
+ loc
+ (sprintf
+ "~athe predicate is called with an argument of type `~a' and will always return false"
+ (pname) (cadr args)))
+ (when specialize
(specialize-node!
node
`(let ((#:tmp #(1))) '#f))
- (set! op (list pt `(not ,pt)))))))
- ((variable-mark pn '##compiler#specializations) =>
- (lambda (specs)
- (for-each
- (lambda (spec)
- (when (match-specialization (car spec) (cdr args))
- (set! op (cons pn (car spec)))
- (specialize-node! node (cadr spec))))
- specs))))
- (when op
- (cond ((assoc op specialization-statistics) =>
- (lambda (a) (set-cdr! a (add1 (cdr a)))))
- (else
- (set! specialization-statistics
- (cons (cons op 1)
- specialization-statistics))))))
- (when (and (not op) (procedure-type? ptype))
- (set-car! (node-parameters node) #t)
- (set! safe-calls (add1 safe-calls)))))
+ (set! op (list pt `(not ,pt))))))))
+ ((and specialize (variable-mark pn '##compiler#specializations)) =>
+ (lambda (specs)
+ (for-each
+ (lambda (spec)
+ (when (match-specialization (car spec) (cdr args))
+ (set! op (cons pn (car spec)))
+ (specialize-node! node (cadr spec))))
+ specs))))
+ (when op
+ (cond ((assoc op specialization-statistics) =>
+ (lambda (a) (set-cdr! a (add1 (cdr a)))))
+ (else
+ (set! specialization-statistics
+ (cons (cons op 1)
+ specialization-statistics))))))
+ (when (and specialize (not op) (procedure-type? ptype))
+ (set-car! (node-parameters node) #t)
+ (set! safe-calls (add1 safe-calls))))
r))))
(define (procedure-type? t)
(or (eq? 'procedure t)
@@ -862,8 +863,12 @@
(else (equal? st t))))
(else (equal? st t))))
(define (matchnot st t)
- (cond ((eq? 'list t) (matchnot st '(or null pair)))
+ (cond ((eq? st t) #f)
+ ((eq? 'list t) (matchnot st '(or null pair)))
+ ((eq? 'number t) (matchnot st '(or fixnum float)))
((eq? '* t) #f)
+ ((eq? 'list st) (not (match t '(or null pair))))
+ ((eq? 'number st) (not (match t '(or fixnum float))))
((pair? t)
(case (car t)
((or) (every (cut matchnot st <>) (cdr t)))
diff --git a/support.scm b/support.scm
index e9d20e86..d3d8e2f3 100644
--- a/support.scm
+++ b/support.scm
@@ -1535,7 +1535,6 @@ Usage: chicken FILENAME OPTION ...
-no-lambda-info omit additional procedure-information
-scrutinize perform local flow analysis for static checks
-types FILENAME load additional type database
- -strict-types assume variable do not change their type
-emit-type-file FILENAME write type-declaration information into file
Optimization options:
@@ -1567,6 +1566,7 @@ Usage: chicken FILENAME OPTION ...
-no-procedure-checks-for-toplevel-bindings
disable procedure call checks for toplevel
bindings
+ -strict-types assume variable do not change their type
Configuration options:
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 42c7d8b4..7d971c7b 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -79,6 +79,9 @@ fi
diff -bu scrutiny.out scrutiny.expected
+$compile scrutiny-tests-2.scm -scrutinize -analyze-only -ignore-repository -types ../types.db
+./a.out
+
echo "======================================== specialization tests ..."
rm -f foo.types foo.import.*
$compile specialization-test-1.scm -emit-type-file foo.types -specialize \
diff --git a/tests/scrutiny-tests-2.scm b/tests/scrutiny-tests-2.scm
new file mode 100644
index 00000000..986c303b
--- /dev/null
+++ b/tests/scrutiny-tests-2.scm
@@ -0,0 +1,27 @@
+;;;; scrutiny-tests-2.scm
+
+
+(define-syntax predicate
+ (syntax-rules ()
+ ((_ pred (proto ...) (nonproto ...))
+ (begin
+ (assert (pred proto)) ...
+ (assert (not (pred nonproto))) ...))))
+
+
+;;;
+
+(let ((p '(1 . 2))
+ (l (list))
+ (n '())
+ (i 123)
+ (f 12.3)
+ (u (+ i f)))
+ (predicate pair? (p) (l n i f))
+ (predicate list? (l) (p n i f))
+ (predicate null? (n) (p l i f))
+ (predicate fixnum? (i) (f u))
+ (predicate exact? (i) (f u))
+ (predicate flonum? (f) (i u))
+ (predicate inexact? (f) (i u))
+ (predicate number? (i f u) (n)))
diff --git a/types.db b/types.db
index d73a3c04..c3f34c90 100644
--- a/types.db
+++ b/types.db
@@ -580,8 +580,8 @@
(fixnum-bits fixnum)
(fixnum-precision fixnum)
-(fixnum? (procedure fixnum? (*) boolean)
- ((fixnum) (let ((#:tmp #(1))) '#t)))
+(fixnum? (procedure fixnum? (*) boolean))
+(predicate fixnum? fixnum)
(flonum-decimal-precision fixnum)
(flonum-epsilon float)
@@ -593,8 +593,8 @@
(flonum-print-precision (procedure! (#!optional fixnum) fixnum))
(flonum-radix fixnum)
-(flonum? (procedure flonum? (*) boolean)
- ((float) (let ((#:tmp #(1))) '#t)))
+(flonum? (procedure flonum? (*) boolean))
+(predicate flonum? float)
(flush-output (procedure! flush-output (#!optional port) undefined))
(force-finalizers (procedure force-finalizers () undefined))
Trap