~ chicken-core (chicken-5) 77e53c7e8648a6ec9a3a605fa131626fd7a31be9
commit 77e53c7e8648a6ec9a3a605fa131626fd7a31be9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 22 01:13:06 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Aug 22 01:13:06 2011 +0200
if it goes on like this, I'll go mad
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 766c21d4..b1929b17 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -182,6 +182,7 @@
inline-table-used
inlining
insert-timer-checks
+ install-specializations
installation-home
internal-bindings
intrinsic?
diff --git a/compiler.scm b/compiler.scm
index 0edf2b3c..b0e04381 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1516,8 +1516,8 @@
(when pred
(mark-variable name '##compiler#predicate pred))
(when (pair? (cddr spec))
- (mark-variable
- name '##compiler#specializations
+ (install-specializations
+ name
(##sys#strip-syntax (cddr spec)))))
(else
(warning
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 5d997ef7..2978cc00 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -297,7 +297,7 @@
""))
"")
(fragment (first (node-subexpressions node)))))
- (d " call-result: ~a " args)
+ (d " call: ~a " args)
(let* ((ptype (car args))
(pptype? (procedure-type? ptype))
(nargs (length (cdr args)))
@@ -382,21 +382,21 @@
(let* ((spec (car specs))
(stype (first spec))
(tenv2 (append (append-map type-typeenv stype) typeenv)))
- (cond ((match-argument-types
- stype (cdr args) tenv2
- #t)
- (set! op (cons pn (car spec)))
- (set! typeenv tenv2)
- (let* ((r2 (and (pair? (cddr spec))
- (second spec)))
- (rewrite (if r2
- (third spec)
- (second spec))))
- (specialize-node! node rewrite)
- (when r2 (set! r r2))))
- (else
- (trail-restore trail0 tenv2)
- (loop (cdr specs))))))))))
+ (cond ((match-argument-types
+ stype (cdr args) tenv2
+ #t)
+ (set! op (cons pn (car spec)))
+ (set! typeenv tenv2)
+ (let* ((r2 (and (pair? (cddr spec))
+ (second spec)))
+ (rewrite (if r2
+ (third spec)
+ (second spec))))
+ (specialize-node! node rewrite)
+ (when r2 (set! r r2))))
+ (else
+ (trail-restore trail0 tenv2)
+ (loop (cdr specs))))))))))
(when op
(d " specialized: `~s' for ~a" (car op) (cdr op))
(cond ((assoc op specialization-statistics) =>
@@ -845,9 +845,8 @@
(define (match-types t1 t2 typeenv #!optional exact all)
(define (match-args args1 args2)
- (d "match-args: ~s <-> ~s" args1 args2)
+ (d "match args: ~s <-> ~s" args1 args2)
(let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
- (dd " args ~a ~a ~a ~a" args1 args2 opt1 opt2)
(cond ((null? args1)
(or opt2
(null? args2)
@@ -1199,7 +1198,7 @@
((memq t1 '(vector list)) (type<=? `(,t1 *) t2))
((and (eq? 'null t1)
(pair? t2)
- (memq (car t2) '(pair list))))
+ (eq? (car t2) 'list)))
((and (pair? t1) (eq? 'forall (car t1)))
(set! typeenv (append (map (cut cons <> #f) (second t1)) typeenv))
(type<=? (third t1) t2))
@@ -1520,8 +1519,7 @@
name new old)))
(mark-variable name '##compiler#type t)
(when specs
- ;;XXX validate types in specs
- (mark-variable name '##compiler#specializations specs)))))
+ (install-specializations name specs)))))
(read-file dbfile))
#t)))
@@ -1636,6 +1634,9 @@
(set! usedvars (cons t usedvars))
t)
(else #f)))
+ ((eq? 'not (car t))
+ (and (= 2 (length t))
+ `(not ,(validate (second t)))))
((eq? 'forall (car t))
(and (= 3 (length t))
(list? (second t))
@@ -1714,6 +1715,51 @@
(values type (and ptype (eq? (car ptype) type) (cdr ptype))))))
(else (values #f #f)))))
+(define (install-specializations name specs)
+ (define (fail spec)
+ (error "invalid specialization format" spec name))
+ (mark-variable
+ name '##compiler#specializations
+ ;;XXX it would be great if result types could refer to typevars
+ ;; bound in the argument types, like this:
+ ;;
+ ;; (: with-input-from-file ((-> . *) -> . *)
+ ;; (((forall (a) (-> a))) (a) ...code that does it single-valued-ly...))
+ ;;
+ ;; This would make it possible to propagate the (single) result type from
+ ;; the thunk to the enclosing expression. Unfortunately the simplification in
+ ;; the first validation renames typevars, so the second validation will have
+ ;; non-matching names.
+ (map (lambda (spec)
+ (if (and (list? spec) (list? (first spec)))
+ (let* ((args
+ (map (lambda (t)
+ (let-values (((t2 _) (validate-type t #f)))
+ (or t2
+ (error "invalid argument type in specialization"
+ t spec name))))
+ (first spec)))
+ (typevars (unzip1 (append-map type-typeenv args))))
+ (cons
+ args
+ (case (length spec)
+ ((2) (cdr spec))
+ ((3)
+ (cond ((list? (second spec))
+ (cons
+ (map (lambda (t)
+ (let-values (((t2 _) (validate-type t #f)))
+ (or t2
+ (error "invalid result type in specialization"
+ t spec name))))
+ (second spec))
+ (cddr spec)))
+ ((eq? '* (second spec)) (cdr spec))
+ (else (fail spec))))
+ (else (fail spec)))))
+ (fail spec)))
+ specs)))
+
;;; hardcoded result types for certain primitives
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 2e15b2f4..31bdf6d5 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -4,6 +4,7 @@
# - Note: this needs a proper shell, so it will not work with plain mingw
# (just the compiler and the Windows shell, without MSYS)
+
set -e
TEST_DIR=`pwd`
OS_NAME=`uname -s`
@@ -13,22 +14,6 @@ export LIBRARY_PATH=${TEST_DIR}/..:${LIBRARY_PATH}
mkdir -p test-repository
-# copy files into test-repository (by hand to avoid calling `chicken-install'):
-
-for x in setup-api.so setup-api.import.so setup-download.so \
- setup-download.import.so chicken.import.so lolevel.import.so \
- srfi-1.import.so srfi-4.import.so data-structures.import.so \
- ports.import.so files.import.so posix.import.so \
- srfi-13.import.so srfi-69.import.so extras.import.so \
- irregex.import.so srfi-14.import.so tcp.import.so \
- foreign.import.so scheme.import.so srfi-18.import.so \
- utils.import.so csi.import.so irregex.import.so types.db; do
- 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
@@ -38,6 +23,11 @@ FAST_OPTIONS="-O5 -d0 -b -disable-interrupts"
$CHICKEN_INSTALL -init ${TEST_DIR}/test-repository
+#TYPESDB=../types.db
+#XXX
+TYPESDB=../types.db.new
+cp $TYPESDB test-repository/types.db
+
if test -n "$MSYSTEM"; then
CHICKEN="..\\chicken.exe"
ASMFLAGS=-Wa,-w
@@ -67,7 +57,7 @@ $compile inlining-tests.scm -optimize-level 3
echo "======================================== scrutiny tests ..."
$compile typematch-tests.scm -specialize -w
./a.out
-$compile scrutiny-tests.scm -scrutinize -ignore-repository -types ../types.db 2>scrutiny.out -verbose
+$compile scrutiny-tests.scm -scrutinize -ignore-repository -types $TYPESDB 2>scrutiny.out -verbose
if test -n "$MSYSTEM"; then
dos2unix scrutiny.out
@@ -80,7 +70,7 @@ 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
+$compile scrutiny-tests-2.scm -scrutinize -analyze-only -ignore-repository -types $TYPESDB 2>scrutiny-2.out -verbose
if test -n "$MSYSTEM"; then
dos2unix scrutiny.out
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 23691128..f60ccdbe 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -6,7 +6,7 @@ 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:
+ `number' which is always true:
(if x3 '1 '2)
@@ -37,7 +37,7 @@ Warning: at toplevel:
scrutiny-tests.scm:28: in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(procedure car (pair) *)'
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a99) (procedure car ((pair a99 *)) a99))'
Warning: at toplevel:
expected in `let' binding of `g8' a single result, but were given 2 results
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 43915a11..1b5ce750 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -89,7 +89,7 @@
(((not ,type)) 'ok-too))
(define (,fname x) 'bomb)
(assert (eq? 'ok (,fname ,val)) "did not specialize" ',val ',type)
- (assert (eq? 'ok-too (,fname ,nval)) "did specialize" ',val ',type)
+ (assert (eq? 'ok-too (,fname ,nval)) "did specialize" ',nval ',type)
(: ,fname2 (* -> *)
(((not ,type)) 'bomb))
(define (,fname2 x) 'ok)
diff --git a/types.db.new b/types.db.new
index ee6f5eeb..2870bfe7 100644
--- a/types.db.new
+++ b/types.db.new
@@ -57,7 +57,7 @@
(equal? (procedure equal? (* *) boolean)
(((or fixnum symbol char eof null undefined) *) (eq? #(1) #(2)))
- ((* (or fixnum symbol char eof null undefined) (eq? #(1) #(2)))))
+ ((* (or fixnum symbol char eof null undefined)) (eq? #(1) #(2))))
(pair? (procedure? pair pair? (*) boolean))
@@ -227,6 +227,7 @@
((float float) (##core#inline "C_i_flonum_min" #(1) #(2))))
(+ (procedure! + (#!rest number) number)
+ (() (fixnum) '0)
((fixnum) (fixnum) #(1))
((float) (float) #(1))
((number) #(1))
@@ -263,6 +264,7 @@
(##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1))))
(* (procedure! * (#!rest number) number)
+ (() (fixnum) '1)
((fixnum) (fixnum) #(1))
((float) (float) #(1))
((number) (number) #(1))
@@ -534,7 +536,7 @@
(##sys#apply (procedure! ##sys#apply (procedure #!rest) . *))
(force (procedure force (*) *)
- ((not (struct promise)) #(1)))
+ (((not (struct promise))) #(1)))
(call-with-current-continuation
(procedure! call-with-current-continuation ((procedure (procedure) . *)) . *))
@@ -607,10 +609,10 @@
(char-ready? (procedure! char-ready? (#!optional port) boolean))
(imag-part (procedure! imag-part (number) number)
- ((or fixnum float number) (let ((#(tmp) #(1))) '0)))
+ (((or fixnum float number)) (let ((#(tmp) #(1))) '0)))
(real-part (procedure! real-part (number) number)
- ((or fixnum float number) #(1)))
+ (((or fixnum float number)) #(1)))
(magnitude (procedure! magnitude (number) number)
((fixnum) (fixnum)
@@ -722,7 +724,7 @@
(equal=? (procedure equal=? (* *) boolean)
(((or fixnum symbol char eof null undefined) *) (eq? #(1) #(2)))
- ((* (or fixnum symbol char eof null undefined) (eq? #(1) #(2))))
+ ((* (or fixnum symbol char eof null undefined)) (eq? #(1) #(2)))
(((or float number) (or float number)) (= #(1) #(2))))
(er-macro-transformer
@@ -1028,7 +1030,7 @@
(((or null pair list) *) (let ((#(tmp) #(1))) '#t)))
(##sys#check-string (procedure! ##sys#check-string (string #!optional *) *)
((string) (let ((#(tmp) #(1))) '#t))
- ((string) * (let ((#(tmp) #(1))) '#t)))
+ ((string) * (let ((#(tmp) #(1))) '#t)))
(##sys#check-number (procedure! ##sys#check-number (number #!optional *) *)
((number) (let ((#(tmp) #(1))) '#t))
((number *) (let ((#(tmp) #(1))) '#t)))
@@ -1738,7 +1740,13 @@
(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)))
+(fourth (forall (a) (procedure! fourth ((pair * (pair * (pair * (pair a *))))) a))
+ (((pair * (pair * (pair * (pair * *)))))
+ (##core#inline "C_u_i_car"
+ (##core#inline "C_u_i_cdr"
+ (##core#inline "C_u_i_cdr"
+ (##core#inline "C_u_i_cdr" #(1)))))))
+
(iota (procedure! iota (fixnum #!optional fixnum fixnum) (list number)))
(last (procedure! last (pair) *))
(last-pair (procedure! last-pair (pair) *))
Trap