~ chicken-core (chicken-5) dc683fc0601acad13a66d1fe1a327fd3ac143219
commit dc683fc0601acad13a66d1fe1a327fd3ac143219
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Mar 23 07:06:54 2011 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 23 07:06:54 2011 -0400
various specialization fixes; improved tests
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 5e8879d7..998f5874 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1119,15 +1119,14 @@
(##sys#check-syntax ': x '(_ symbol _ . _))
(if (memq #:csi ##sys#features)
'(##core#undefined)
- (let* ((name (cadr x))
- (type1 (##sys#strip-syntax (caddr x)))
- (name1 (##sys#strip-syntax (cadr x)))
- (type (##compiler#validate-type type1 name1)))
+ (let* ((type1 (##sys#strip-syntax (caddr x)))
+ (name1 (cadr x))
+ (type (##compiler#validate-type type1 (##sys#strip-syntax name1))))
(cond ((not type)
(syntax-error ': "invalid type syntax" name1 type1))
(else
`(##core#declare
- (type (,name ,type ,@(cdddr x)))))))))))
+ (type (,name1 ,type ,@(cdddr x)))))))))))
(##sys#macro-subset me0 ##sys#default-macro-environment)))
diff --git a/compiler.scm b/compiler.scm
index 593026dc..2c0e50f5 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1467,12 +1467,19 @@
(for-each
(lambda (spec)
(if (not (and (list? spec)
- (>= 2 (length spec))
+ (>= (length spec) 2)
(symbol? (car spec))))
(warning "illegal type declaration" (##sys#strip-syntax spec))
(let ((name (##sys#globalize (car spec) se))
(type (##sys#strip-syntax (cadr spec))))
(cond ((validate-type type name)
+ ;; HACK: since `:' doesn't have access to the SE, we
+ ;; fixup the procedure name if type is a named procedure type
+ ;; (We only have access to the SE for ##sys#globalize in here).
+ ;; Quote terrible.
+ (when (and (pair? type) (eq? 'procedure (car type)) (symbol? (cadr type)))
+ (set-car! (cdr type) name))
+ (print "mark: " name " -> " type)
(mark-variable name '##core#type type)
(mark-variable name '##core#declared-type)
(when (pair? (cddr spec))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 5daffaef..e70cd013 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -59,8 +59,8 @@
; global symbol properties:
;
-; ##core#type -> <typespec>
-; ##core#declared-type -> <bool>
+; ##core#type -> TYPESPEC
+; ##core#declared-type -> BOOL
; ##core#specializations -> (SPECIALIZATION ...)
;
; specialization specifiers:
@@ -105,11 +105,7 @@
(define (global-result id loc)
(cond ((##sys#get id '##core#type) =>
(lambda (a)
- (cond #;((and (get db id 'assigned) ; remove assigned global from type db
- (not (##sys#get id '##core#declared-type)))
- (##sys#put! id '##core#type #f)
- '*)
- ((eq? a 'deprecated)
+ (cond ((eq? a 'deprecated)
(report
loc
(sprintf "use of deprecated library procedure `~a'" id) )
@@ -125,7 +121,7 @@
(else '*)))
(define (variable-result id e loc)
(cond ((and (get db id 'assigned)
- (not (##sys#get id '##core#declared-type)) )
+ (not (##sys#get id '##core#declared-type)))
'*)
((assq id e) =>
(lambda (a)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index acdc988a..a0e4a39e 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -58,8 +58,8 @@ $compile compiler-tests-3.scm -unsafe -unboxing
./a.out
echo "======================================== compiler tests (specialization) ..."
-$compile fft.scm -O3 -d0 -disable-interrupts -b -o fft1
-$compile fft.scm -O3 -d0 -disable-interrupts -b -o fft2 -specialize
+$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
/usr/bin/time fft1 1000 7
/usr/bin/time fft2 1000 7
@@ -82,12 +82,13 @@ fi
diff -bu scrutiny.out scrutiny.expected
echo "======================================== specialization tests ..."
-rm foo.types
+rm -f foo.types foo.import.*
$compile specialization-test-1.scm -emit-type-file foo.types -specialize \
- -debug ox
+ -debug ox -emit-import-library foo
./a.out
$compile specialization-test-2.scm -types foo.types -specialize -debug ox
./a.out
+rm -f foo.types foo.import.*
echo "======================================== callback tests ..."
$compile callback-tests.scm
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index cd3a5bc4..d919b18b 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -16,10 +16,10 @@ Warning: in toplevel procedure `foo':
(if x5 (values '1 '2) (values '1 '2 (+ ...)))
Warning: at toplevel:
- scrutiny-tests.scm:18: in procedure call to `bar6', expected argument #2 of type `number', but where given an argument of type `symbol'
+ scrutiny-tests.scm:18: in procedure call to `bar6', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- scrutiny-tests.scm:20: in procedure call to `pp', expected 1 argument, but where given 0 arguments
+ scrutiny-tests.scm:20: in procedure call to `pp', expected 1 argument, but was given 0 arguments
Warning: at toplevel:
expected in argument #1 of procedure call `(print (cpu-time))' a single result, but were given 2 results
@@ -28,13 +28,13 @@ Warning: at toplevel:
expected in argument #1 of procedure call `(print (values))' a single result, but were given zero results
Warning: at toplevel:
- scrutiny-tests.scm:26: in procedure call to `x7', expected a value of type `(procedure () *)', but were given a value of type `fixnum'
+ scrutiny-tests.scm:26: in procedure call to `x7', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
Warning: at toplevel:
- scrutiny-tests.scm:28: in procedure call to `+', expected argument #1 of type `number', but where given an argument of type `symbol'
+ scrutiny-tests.scm:28: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- scrutiny-tests.scm:28: in procedure call to `+', expected argument #2 of type `number', but where given an argument of type `symbol'
+ 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) *)'
@@ -43,6 +43,6 @@ Warning: at toplevel:
expected in `let' binding of `g8' a single result, but were given 2 results
Warning: at toplevel:
- g89: in procedure call to `g89', expected a value of type `(procedure () *)', but were given a value of type `fixnum'
+ g89: in procedure call to `g89', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
Warning: redefinition of standard binding: car
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 41e7ea37..5e79327f 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -1,7 +1,7 @@
;;;; specialization-test-1.scm
-(module main ()
+(module foo (foo)
(import scheme chicken foreign)
#>
@@ -13,6 +13,7 @@ return n;}
(: foo (fixnum -> fixnum)
((fixnum) (##core#inline "inlined" #(1))))
+
(define (foo i)
(print "foo: " i)
0)
diff --git a/tests/specialization-test-2.scm b/tests/specialization-test-2.scm
index 82763f40..dafb7774 100644
--- a/tests/specialization-test-2.scm
+++ b/tests/specialization-test-2.scm
@@ -2,7 +2,7 @@
(module main ()
-(import scheme chicken foreign)
+(import scheme chicken foreign foo)
#>
static int inlined(int i) {
@@ -11,11 +11,6 @@ n += i;
return n;}
<#
-(define (foo i)
- (print "foo: " i)
- 0)
-
-(assert (zero? (foo 1.0)))
(assert (= 1 (foo 1)))
)
Trap