~ chicken-core (chicken-5) b50d7cec890ec6a4c3179ae3c1d78e968f6ba9c8
commit b50d7cec890ec6a4c3179ae3c1d78e968f6ba9c8
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Aug 21 00:19:49 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Aug 21 00:19:49 2011 +0200
scrutinizer fixes; make check runs with new types.db
diff --git a/TODO b/TODO
new file mode 100644
index 00000000..ee63a1e4
--- /dev/null
+++ b/TODO
@@ -0,0 +1,14 @@
+TODO -*- Outline -*-
+
+
+* replace "types.db" with "types.db.new"
+
+* enable specialization in "common-declarations.scm" and "tweaks.scm"
+
+* "tests/runtests.sh": remove command to cp "types.db.new"
+
+* compare "-debug x" output for specialization with results from complete self-compile
+
+* test self-build
+
+* run mini-salmonella
diff --git a/batch-driver.scm b/batch-driver.scm
index 756ea02f..f3dc41f0 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -546,7 +546,8 @@
(when (or do-scrutinize enable-specialization)
;;XXX hardcoded database file name
(unless (memq 'ignore-repository options)
- (load-type-database "types.db"))
+ (unless (load-type-database "types.db")
+ (quit "default type-database `types.db' not found")))
(for-each (cut load-type-database <> #f) (collect-options 'types))
(for-each
(lambda (id)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 9ed0916a..17c2ca6a 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -212,7 +212,7 @@
(report-notice
loc
(sprintf
- "expected value of type boolean in conditional but were given a value of\ntype `~a' which is always true:~%~%~a"
+ "expected value of type boolean in conditional but were given a value of type\n `~a' which is always true:~%~%~a"
t
(pp-fragment x))))
f))
@@ -349,11 +349,11 @@
(variable-mark pn '##compiler#predicate)) =>
(lambda (pt)
(cond ((match-argument-types
- (list pt) (cdr args) typeenv #t)
+ (list pt) (cdr args) typeenv #f #t)
(report-notice
loc
(sprintf
- "~athe predicate is called with an argument of type `~a' and will always return true"
+ "~athe predicate is called with an argument of type\n `~a' and will always return true"
(pname) (cadr args)))
(when specialize
(specialize-node!
@@ -363,12 +363,11 @@
((begin
(trail-restore trail0 typeenv)
(match-argument-types
- (list `(not ,pt)) (cdr args) typeenv
- #t))
+ (list `(not ,pt)) (cdr args) typeenv #f #t))
(report-notice
loc
(sprintf
- "~athe predicate is called with an argument of type `~a' and will always return false"
+ "~athe predicate is called with an argument of type\n `~a' and will always return false"
(pname) (cadr args)))
(when specialize
(specialize-node!
@@ -400,7 +399,7 @@
(trail-restore trail0 tenv2)
(loop (cdr specs))))))))))
(when op
- (d " specialized: `~s'" op)
+ (d " specialized: `~s' for ~a" (car op) (cdr op))
(cond ((assoc op specialization-statistics) =>
(lambda (a) (set-cdr! a (add1 (cdr a)))))
(else
@@ -454,7 +453,7 @@
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(class (node-class n)) )
- (dd "walk: ~a ~a (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, e: ~a)"
+ (dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, e: ~a)"
class params loc dest tail flow blist e)
(set! d-depth (add1 d-depth))
(let ((results
@@ -779,9 +778,9 @@
(define (typename t)
(define (argument-string args)
- (let* ((len (length (delete args '#!optional) eq?))
+ (let* ((len (length (delete '#!optional args eq?)))
(m (multiples len)))
- ;;XXX not quite right for test-arguments
+ ;;XXX not quite right for rest/optional arguments
(cond ((memq '#!rest args)
(sprintf "~a or more arguments" len))
((zero? len) "zero arguments")
@@ -841,8 +840,9 @@
;;; Type-matching
;
; - "exact" means: first argument must match second one exactly
+; - "all" means: all elements in `or'-types in second argument must match
-(define (match-types t1 t2 typeenv #!optional exact)
+(define (match-types t1 t2 typeenv #!optional exact all)
(define (match-args args1 args2)
(d "match-args: ~s <-> ~s" args1 args2)
@@ -895,6 +895,7 @@
#f))))
(define (match1 t1 t2)
+ ;; note: the order of determining the type is important
;(dd " match1: ~s <-> ~s" t1 t2)
(cond ((eq? t1 t2))
((and (symbol? t1) (assq t1 typeenv)) =>
@@ -916,11 +917,13 @@
(set-cdr! e t1)
#t))))
((eq? t1 '*))
- ((and (pair? t1) (eq? 'not (car t1))) ; needs to be done before '* check for t2
- (let* ((trail0 trail)
- (m (match1 (cadr t1) t2)))
- (trail-restore trail0 typeenv)
- (not m)))
+ ((and (pair? t1) (eq? 'not (car t1)))
+ (fluid-let ((exact #f)
+ (all #f))
+ (let* ((trail0 trail)
+ (m (match1 (cadr t1) t2)))
+ (trail-restore trail0 typeenv)
+ (not m))))
((and (pair? t2) (eq? 'not (car t2)))
(and (not exact)
(let* ((trail0 trail)
@@ -930,12 +933,12 @@
((and (pair? t1) (eq? 'or (car t1)))
(any (cut match1/restore <> t2) (cdr t1)))
((and (pair? t2) (eq? 'or (car t2)))
- ((if exact every any) (cut match1/restore t1 <>) (cdr t2)))
+ ((if (or exact all) every any) (cut match1/restore t1 <>) (cdr t2)))
((and (pair? t1) (eq? 'forall (car t1)))
(match1 (third t1) t2)) ; assumes typeenv has already been extracted
((and (pair? t2) (eq? 'forall (car t2)))
(match1 t1 (third t2))) ; assumes typeenv has already been extracted
- ((eq? t2 '*) (not exact))
+ ((eq? t2 '*) (and (not exact) (not all)))
((eq? t1 'noreturn) (not exact))
((eq? t2 'noreturn) (not exact))
((eq? t1 'number)
@@ -958,7 +961,7 @@
((eq? t1 'vector) (match1 '(vector *) t2))
((eq? t2 'vector) (match1 t1 '(vector *)))
((eq? t1 'null)
- (and (not exact)
+ (and (not exact) (not all)
(or (memq t2 '(null list))
(and (pair? t2) (eq? 'list (car t2))))))
((eq? t2 'null)
@@ -979,7 +982,7 @@
((list vector) (match1 (second t1) (second t2)))
(else #f) ) )
((and (pair? t1) (eq? 'pair (car t1)))
- (and (not exact)
+ (and (not exact) (not all)
(pair? t2)
(eq? 'list (car t2))
(match1 (second t1) (second t2))
@@ -991,7 +994,7 @@
(match1 (second t1) (second t2))
(match1 t1 (third t2))))
((and (pair? t1) (eq? 'list (car t1)))
- (and (not exact)
+ (and (not exact) (not all)
(or (eq? 'null t2)
(and (pair? t2)
(eq? 'pair (car t2))
@@ -1006,17 +1009,20 @@
(match1 (third t1) t2)))))
(else #f)))
(let ((m (match1 t1 t2)))
- (dd " match~a ~a <-> ~a -> ~a (te: ~s)" (if exact " (exact)" "") t1 t2 m typeenv)
+ (dd " match~a~a ~a <-> ~a -> ~a te: ~s"
+ (if exact " (exact)" "")
+ (if all " (all)" "")
+ t1 t2 m typeenv)
m))
-(define (match-argument-types typelist atypes typeenv #!optional exact)
+(define (match-argument-types typelist atypes typeenv #!optional exact all)
(let loop ((tl typelist) (atypes atypes))
(cond ((null? tl) (null? atypes))
((null? atypes) #f)
((equal? '(#!rest) tl))
((eq? (car tl) '#!rest)
- (every (cute match-types (cadr tl) <> typeenv exact) atypes))
- ((match-types (car tl) (car atypes) typeenv exact)
+ (every (cute match-types (cadr tl) <> typeenv exact all) atypes))
+ ((match-types (car tl) (car atypes) typeenv exact all)
(loop (cdr tl) (cdr atypes)))
(else #f))))
@@ -1446,7 +1452,7 @@
(define (load-type-database name #!optional (path (repository-path)))
(and-let* ((dbfile (file-exists? (make-pathname path name))))
- (debugging 'p (sprintf "loading type database ~a ...~%" dbfile))
+ (debugging 'p (sprintf "loading type database `~a' ...~%" dbfile))
(fluid-let ((scrutiny-debug #f))
(for-each
(lambda (e)
@@ -1485,7 +1491,8 @@
(when specs
;;XXX validate types in specs
(mark-variable name '##compiler#specializations specs)))))
- (read-file dbfile)))))
+ (read-file dbfile))
+ #t)))
(define (emit-type-file filename db)
(with-output-to-file filename
@@ -1614,6 +1621,8 @@
(and (= 2 (length t))
(symbol? (cadr t))
t))
+ ((eq? 'deprecated (car t))
+ (and (= 2 (length t)) (symbol? (second t))))
((memq '-> t) =>
(lambda (p)
(let ((cp (memq ': (cdr p))))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 4f1304f6..2e15b2f4 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -26,6 +26,9 @@ for x in setup-api.so setup-api.import.so setup-download.so \
cp ../$x test-repository
done
+#XXX
+cp ../types.db.new test-repository
+
CHICKEN_REPOSITORY=${TEST_DIR}/test-repository
CHICKEN=../chicken
CHICKEN_INSTALL=${TEST_DIR}/../chicken-install
@@ -57,20 +60,12 @@ echo "======================================== compiler tests (unboxing) ..."
$compile compiler-tests-3.scm -unsafe -unboxing
./a.out
-echo "======================================== compiler tests (specialization) ..."
-$compile fft.scm -O2 -local -d0 -disable-interrupts -b -o fft1
-$compile fft.scm -O2 -local -specialize -debug x -d0 -disable-interrupts -b -o fft2 -specialize
-echo "normal:"
-/usr/bin/time ./fft1 1000 7
-echo "specialized:"
-/usr/bin/time ./fft2 1000 7
-
echo "======================================== compiler inlining tests ..."
$compile inlining-tests.scm -optimize-level 3
./a.out
echo "======================================== scrutiny tests ..."
-$compile typematch-tests.scm -scrutinize
+$compile typematch-tests.scm -specialize -w
./a.out
$compile scrutiny-tests.scm -scrutinize -ignore-repository -types ../types.db 2>scrutiny.out -verbose
@@ -86,7 +81,6 @@ fi
diff -bu scrutiny.expected scrutiny.out
$compile scrutiny-tests-2.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny-2.out -verbose
-./a.out
if test -n "$MSYSTEM"; then
dos2unix scrutiny.out
@@ -108,6 +102,14 @@ $compile specialization-test-2.scm -types foo.types -specialize -debug ox
./a.out
rm -f foo.types foo.import.*
+echo "======================================== specialization benchmark ..."
+$compile fft.scm -O2 -local -d0 -disable-interrupts -b -o fft1
+$compile fft.scm -O2 -local -specialize -debug x -d0 -disable-interrupts -b -o fft2 -specialize
+echo "normal:"
+/usr/bin/time ./fft1 1000 7
+echo "specialized:"
+/usr/bin/time ./fft2 1000 7
+
echo "======================================== callback tests ..."
$compile callback-tests.scm
./a.out
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index b0b64e38..5a7cc085 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -1,69 +1,100 @@
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type `pair' and will always return true
+ in procedure call to `pair?', the predicate is called with an argument of type
+ `(pair fixnum fixnum)' and will always return true
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
+ in procedure call to `pair?', the predicate is called with an argument of type
+ `null' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type `fixnum' and will always return false
+ in procedure call to `pair?', the predicate is called with an argument of type
+ `fixnum' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type `float' and will always return false
+ in procedure call to `pair?', the predicate is called with an argument of type
+ `float' and will always return false
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type `list' and will always return true
+ in procedure call to `list?', the predicate is called with an argument of type
+ `list' and will always return true
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type `fixnum' and will always return false
+ in procedure call to `list?', the predicate is called with an argument of type
+ `(pair fixnum fixnum)' and will always return false
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type `float' and will always return false
+ in procedure call to `list?', the predicate is called with an argument of type
+ `null' and will always return true
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type `null' and will always return true
+ in procedure call to `list?', the predicate is called with an argument of type
+ `fixnum' and will always return false
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type `pair' and will always return false
+ in procedure call to `list?', the predicate is called with an argument of type
+ `float' and will always return false
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type `fixnum' and will always return false
+ in procedure call to `null?', the predicate is called with an argument of type
+ `null' and will always return true
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type `float' and will always return false
+ in procedure call to `null?', the predicate is called with an argument of type
+ `(pair fixnum fixnum)' and will always return false
Note: at toplevel:
- in procedure call to `fixnum?', the predicate is called with an argument of type `fixnum' and will always return true
+ in procedure call to `null?', the predicate is called with an argument of type
+ `fixnum' and will always return false
Note: at toplevel:
- in procedure call to `fixnum?', the predicate is called with an argument of type `float' and will always return false
+ in procedure call to `null?', the predicate is called with an argument of type
+ `float' and will always return false
Note: at toplevel:
- in procedure call to `exact?', the predicate is called with an argument of type `fixnum' and will always return true
+ in procedure call to `fixnum?', the predicate is called with an argument of type
+ `fixnum' and will always return true
Note: at toplevel:
- in procedure call to `exact?', the predicate is called with an argument of type `float' and will always return false
+ in procedure call to `fixnum?', the predicate is called with an argument of type
+ `float' and will always return false
Note: at toplevel:
- in procedure call to `flonum?', the predicate is called with an argument of type `float' and will always return true
+ in procedure call to `exact?', the predicate is called with an argument of type
+ `fixnum' and will always return true
Note: at toplevel:
- in procedure call to `flonum?', the predicate is called with an argument of type `fixnum' and will always return false
+ in procedure call to `exact?', the predicate is called with an argument of type
+ `float' and will always return false
Note: at toplevel:
- in procedure call to `inexact?', the predicate is called with an argument of type `float' and will always return true
+ in procedure call to `flonum?', the predicate is called with an argument of type
+ `float' and will always return true
Note: at toplevel:
- in procedure call to `inexact?', the predicate is called with an argument of type `fixnum' and will always return false
+ in procedure call to `flonum?', the predicate is called with an argument of type
+ `fixnum' and will always return false
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type `fixnum' and will always return true
+ in procedure call to `inexact?', the predicate is called with an argument of type
+ `float' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type `float' and will always return true
+ in procedure call to `inexact?', the predicate is called with an argument of type
+ `fixnum' and will always return false
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type `number' and will always return true
+ in procedure call to `number?', the predicate is called with an argument of type
+ `fixnum' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type `null' and will always return false
+ in procedure call to `number?', the predicate is called with an argument of type
+ `float' and will always return true
+
+Note: at toplevel:
+ in procedure call to `number?', the predicate is called with an argument of type
+ `number' and will always return true
+
+Note: at toplevel:
+ in procedure call to `number?', the predicate is called with an argument of type
+ `null' and will always return false
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 1e469592..23691128 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -5,8 +5,8 @@ Warning: at toplevel:
Note: in local procedure `c',
in local procedure `b',
in toplevel procedure `a':
- expected value of type boolean in conditional but were given a value of
-type `number' which is always true:
+ expected value of type boolean in conditional but were given a value of type
+ `number' which is always true:
(if x3 '1 '2)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 8de1f9b2..43915a11 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -87,11 +87,11 @@
(: ,fname (,type -> *)
((,type) 'ok)
(((not ,type)) 'ok-too))
- (define (,fname x) (bomb))
+ (define (,fname x) 'bomb)
(assert (eq? 'ok (,fname ,val)) "did not specialize" ',val ',type)
(assert (eq? 'ok-too (,fname ,nval)) "did specialize" ',val ',type)
(: ,fname2 (* -> *)
- (((not ,type)) (bomb)))
+ (((not ,type)) 'bomb))
(define (,fname2 x) 'ok)
(print "specialize not " ',type)
(,fname2 ,val))))))
diff --git a/types.db.new b/types.db.new
index 376a5923..06455dd3 100644
--- a/types.db.new
+++ b/types.db.new
@@ -65,8 +65,8 @@
(##sys#cons (forall (a b) (procedure ##sys#cons (a b) (pair a b))))
-(car (forall (a) (procedure! car ((pair a *)) a) ((pair) (##core#inline "C_u_i_car" #(1)))))
-(cdr (forall (a) (procedure! cdr ((pair * a)) a) ((pair) (##core#inline "C_u_i_cdr" #(1)))))
+(car (forall (a) (procedure! car ((pair a *)) a)) ((pair) (##core#inline "C_u_i_car" #(1))))
+(cdr (forall (a) (procedure! cdr ((pair * a)) a)) ((pair) (##core#inline "C_u_i_cdr" #(1))))
(caar (forall (a) (procedure! caar ((pair (pair a *) *)) a)))
@@ -514,8 +514,8 @@
(() ##sys#standard-input))
(current-output-port
- (procedure! current-output-port (#!optional port) port))
- ((port) (let ((#(tmp1) #(1)))
+ (procedure! current-output-port (#!optional port) port)
+ ((port) (let ((#(tmp1) #(1)))
(let ((#(tmp2) (set! ##sys#standard-output #(tmp1))))
#(tmp1))))
(() ##sys#standard-output))
@@ -608,7 +608,7 @@
((float) (float)
(##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) '1.0)))
-(argc+argv (procedure argc+argv () fixnum (list string fixnum)))
+(argc+argv (procedure argc+argv () fixnum (list string) fixnum))
(argv (procedure argv () (list string)))
(arithmetic-shift (procedure! arithmetic-shift (number number) number))
@@ -865,7 +865,7 @@
(ir-macro-transformer
(procedure
ir-macro-transformer
- ((procedure (procedure (* (propcedure * *) *)) *))
+ ((procedure (* (procedure (*) *) (procedure (* *) *)) *))
(struct transformer)))
(keyword->string (procedure! keyword->string (symbol) string))
@@ -1293,7 +1293,7 @@
(mutate-procedure!
(procedure! mutate-procedure (procedure (procedure (procedure) . *)) procedure))
-(mutate-procedure (deprecated mutate-procedure!)
+(mutate-procedure (deprecated mutate-procedure!))
(null-pointer deprecated)
(null-pointer? deprecated)
@@ -1639,7 +1639,7 @@
;; srfi-1
(alist-cons (forall (a b c) (procedure alist-cons (a b (list c)) (pair a (pair b (list c))))))
-(alist-copy (forall (a) (procedure! alist-copy ((list a)) (list a)))
+(alist-copy (forall (a) (procedure! alist-copy ((list a)) (list a))))
(alist-delete (forall (a b) (procedure! alist-delete (a (list b) #!optional (procedure (a b) *)) list)))
(alist-delete! (forall (a b) (procedure! alist-delete! (a (list b) #!optional (procedure (a b) *)) undefined)))
(any (forall (a) (procedure! any ((procedure (a #!rest) *) (list a) #!rest list) *)))
@@ -1668,7 +1668,7 @@
(cons* (forall (a) (procedure cons* (a #!rest) (pair a *))))
(count (forall (a) (procedure! count ((procedure (a #!rest) *) (list a) #!rest list) fixnum)))
(delete (forall (a b) (procedure! delete (a (list b) #!optional (procedure (a *) *)) (list b))))
-(delete! (forall (a b) (procedure! delete! (a (list b) #!optional (procedure (a *) *)) (list b)))
+(delete! (forall (a b) (procedure! delete! (a (list b) #!optional (procedure (a *) *)) (list b))))
(delete-duplicates
(forall (a) (procedure! delete-duplicates ((list a) #!optional (procedure (a *) *)) (list a))))
@@ -1699,8 +1699,8 @@
(first (forall (a) (procedure! first ((pair a *)) a))
((pair) (##core#inline "C_u_i_car" #(1))))
-(fold (procedure! fold ((procedure (* #!rest) *) * #!rest list) *)) ; oh, what the hell...
-(fold-right (procedure! fold-right ((procedure (* #!rest) *) * #!rest list) *))
+(fold (procedure! fold ((procedure (* #!rest) *) * #!rest list) *)) ;XXX
+(fold-right (procedure! fold-right ((procedure (* #!rest) *) * #!rest list) *)) ;XXX
(fourth (forall (a) (procedure! fourth ((pair * (pair * (pair * (pair a *))))) a)))
(iota (procedure! iota (fixnum #!optional fixnum fixnum) (list number)))
@@ -1711,13 +1711,20 @@
(list-index (forall (a) (procedure! list-index ((procedure (a #!rest) *) (list a) #!rest list) *)))
(list-tabulate (forall (a) (procedure! list-tabulate (fixnum (procedure (fixnum) a)) (list a))))
(list= (procedure! list= (#!rest list) boolean))
-(lset-adjoin (foreall (a) (procedure! lset-adjoin ((procedure (a a) *) (list a) #!rest a) (list a))))
+
+(lset-adjoin
+ (forall (a) (procedure! lset-adjoin ((procedure (a a) *) (list a) #!rest a) (list a))))
+
(lset-diff+intersection
- (forall (a) (procedure! lset-diff+intersection ((procedure (a a) *) (list a) #!rest (list a))
- (list a))))
+ (forall (a)
+ (procedure! lset-diff+intersection ((procedure (a a) *) (list a) #!rest (list a))
+ (list a))))
+
(lset-diff+intersection!
- (forall (a) (procedure! lset-diff+intersection! ((procedure (a a) *) (list a) #!rest (list a))
- (list a))))
+ (forall (a)
+ (procedure! lset-diff+intersection! ((procedure (a a) *) (list a) #!rest (list a))
+ (list a))))
+
(lset-difference
(forall (a) (procedure! lset-difference ((procedure (a a) *) (list a) #!rest (list a)) (list a))))
Trap