~ chicken-core (chicken-5) c467b406f8a1a96269251679198e3df183bbc60d
commit c467b406f8a1a96269251679198e3df183bbc60d
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed Sep 30 09:01:31 2015 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Fri Oct 30 20:12:43 2015 +0100
Standardize specialization and argument type matching
Removes the concept of "exact" matching, making the behaviour of
specializations and `compiler-typecase` more like that of normal
flow-analysis. This makes it possible to specialize on implicit union
types such as `number` where previously such specializations would never
be triggered (because, for example, `number` would never match `fixnum`
or `flonum` "exactly").
Ensures that user-defined specializations take precedence over built-in
ones, and that specializations are prioritized by the order in which
they're defined.
Refactors `match-types` slightly in order to remove some redundant code
and standardize idioms, and adds a handful of scrutinizer tests.
Fixes #1214.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index f81fc4b9..11ecda23 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1231,20 +1231,17 @@
(##sys#put!
gname '##compiler#local-specializations
(##sys#append
+ (##sys#get gname '##compiler#local-specializations '())
(list
(cons atypes
(if (and rtypes (pair? rtypes))
(list
(map (cut ##compiler#check-and-validate-type
- <>
- 'define-specialization)
+ <>
+ 'define-specialization)
rtypes)
spec)
- (list spec))))
- (or (##compiler#variable-mark
- gname
- '##compiler#local-specializations)
- '())))
+ (list spec))))))
`(##core#begin
(##core#declare (inline ,alias) (hide ,alias))
(,%define (,alias ,@anames)
diff --git a/manual/Types b/manual/Types
index 5e7a87d4..a275c6ba 100644
--- a/manual/Types
+++ b/manual/Types
@@ -272,36 +272,26 @@ Specializations can also be defined by the user:
<syntax>(define-specialization (NAME ARGUMENT ...) [RESULTS] BODY)</syntax>
-{{NAME}} should have a declared type (for example by using {{:}})
-(this is currently not checked). Declares the calls to the globally
-defined procedure {{NAME}} with arguments matching the types given in
-{{ARGUMENTS}} should be replaced by {{BODY}} (a single expression). If
-given, {{RESULTS}} (which follows the syntax given above under "Type
-Syntax") narrows the result type(s) if it differs from the result
-types previously declared for {{NAME}}. {{ARGUMENT}} should be an
-identifier naming the formal parameter or a list of the form
-{{(IDENTIFIER TYPE)}}. In the former case, this argument specializes
-on the {{*}} type. User-defined specializations are always local to
-the compilation unit in which they occur and can not be exported. When
-encountered in the interpreter, {{define-specialization}} does nothing
-and returns an unspecified result.
-
-Note that the exact order of specialization application is not
-specified and nested specializations may result in not narrowing down
-the result types to the most specific type, due to the way the
-flow-analysis is implemented. It is recommended to not define "chains"
-of specializations where one variant of a procedure call is
-specialized to another one that is intended to specialize further.
-This can not always be avoided, but should be kept in mind.
-
-Note that the matching of argument types is done "exactly". This
-means, for example, that an argument type specialized for {{list}}
-will not match {{null}}: even though {{null}} is a subtype of {{list}}
-and will match during normal flow-analysis, we want to be able to
-control what happens when a procedure is called with exactly with a
-list argument. To handle the case when it is called with a {{null}}
-argument, define another specialization for exactly that type or
-use an {{(or ...)}} type-specifier.
+Declares that calls to the globally defined procedure {{NAME}} with
+arguments matching the types given by {{ARGUMENT}}s should be replaced
+by {{BODY}} (a single expression). Each {{ARGUMENT}} should be an
+identifier naming a formal parameter, or a list of the form
+{{(IDENTIFIER TYPE)}}. In the former case, this argument specializes on
+the {{*}} type. If given, {{RESULTS}} (which follows the syntax given
+above under "Type Syntax") adjusts the result types from those
+previously declared for {{NAME}}.
+
+{{NAME}} must have a declared type (for example by using {{:}}). If it
+doesn't, the specialization is ignored.
+
+User-defined specializations are always local to the compilation unit in
+which they occur and cannot be exported. When encountered in the
+interpreter, {{define-specialization}} does nothing and returns an
+unspecified result.
+
+When multiple specializations may apply to a given call, they are
+prioritized by the order in which they were defined, with earlier
+specializations taking precedence over later ones.
There is currently no way of ensuring specializations take place. You
can use the {{-debug o}} compiler options to see the total number of
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 62378df1..99da8236 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -292,8 +292,8 @@
(pp (fragment x))))))
(define (get-specializations name)
- (let* ((a (variable-mark name '##compiler#specializations))
- (b (variable-mark name '##compiler#local-specializations))
+ (let* ((a (variable-mark name '##compiler#local-specializations))
+ (b (variable-mark name '##compiler#specializations))
(c (append (or a '()) (or b '()))))
(and (pair? c) c)))
@@ -362,8 +362,7 @@
(cond ((and (fx= 1 nargs)
(variable-mark pn '##compiler#predicate)) =>
(lambda (pt)
- (cond ((match-argument-types
- (list pt) (cdr actualtypes) typeenv #f #t)
+ (cond ((match-argument-types (list pt) (cdr actualtypes) typeenv)
(report-notice
loc
(sprintf
@@ -376,8 +375,7 @@
(set! op (list pn pt))))
((begin
(trail-restore trail0 typeenv)
- (match-argument-types
- (list `(not ,pt)) (cdr actualtypes) typeenv #f #t))
+ (match-argument-types (list `(not ,pt)) (cdr actualtypes) typeenv))
(report-notice
loc
(sprintf
@@ -398,9 +396,7 @@
(tenv2 (append
(append-map type-typeenv stype)
typeenv)))
- (cond ((match-argument-types
- stype (cdr actualtypes) tenv2
- #t)
+ (cond ((match-argument-types stype (cdr actualtypes) tenv2)
(set! op (cons pn (car spec)))
(set! typeenv tenv2)
(let* ((r2 (and (pair? (cddr spec))
@@ -908,10 +904,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 all)
+(define (match-types t1 t2 typeenv #!optional all)
(define (match-args args1 args2)
(d "match args: ~s <-> ~s" args1 args2)
@@ -934,7 +929,7 @@
((match1 (car args1) (car args2))
(loop (cdr args1) (cdr args2) opt1 opt2))
(else #f))))
-
+
(define (match-rest rtype args opt) ;XXX currently ignores `opt'
(let-values (((head tail) (break (cut eq? '#!rest <>) args)))
(and (every
@@ -948,11 +943,9 @@
(memq a '(#!rest #!optional)))
(define (match-results results1 results2)
- (cond ((null? results1)
- (or (null? results2)
- (and (not exact) (eq? '* results2))))
- ((eq? '* results1))
- ((eq? '* results2) (not exact))
+ (cond ((eq? '* results1))
+ ((eq? '* results2) (not all))
+ ((null? results1) (null? results2))
((null? results2) #f)
((and (memq (car results1) '(undefined noreturn))
(memq (car results2) '(undefined noreturn))))
@@ -961,8 +954,7 @@
(else #f)))
(define (rawmatch1 t1 t2)
- (fluid-let ((exact #f)
- (all #f))
+ (fluid-let ((all #f))
(match1 t1 t2)))
(define (match1 t1 t2)
@@ -1007,18 +999,16 @@
#t)
(else #f))))
((eq? t1 '*))
- ((eq? t2 '*) (and (not exact) (not all)))
+ ((eq? t2 '*) (not all))
((eq? t1 'undefined) #f)
((eq? t2 'undefined) #f)
((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))))
+ (let* ((trail0 trail)
+ (m (rawmatch1 (cadr t1) t2)))
+ (trail-restore trail0 typeenv)
+ (not m)))
((and (pair? t2) (eq? 'not (car t2)))
- (and (not exact)
+ (and (not all)
(let* ((trail0 trail)
(m (match1 t1 (cadr t2))))
(trail-restore trail0 typeenv)
@@ -1028,8 +1018,8 @@
((and (pair? t2) (eq? 'or (car t2)))
(over-all-instantiations
(cdr t2)
- typeenv
- (or exact all)
+ typeenv
+ all
(lambda (t) (match1 t1 t))))
;; s.a.
((and (pair? t1) (eq? 'or (car t1)))
@@ -1042,39 +1032,28 @@
(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? t1 'noreturn) (not exact))
- ((eq? t2 'noreturn) (not exact))
- ((eq? t1 'boolean)
- (and (not exact)
- (match1 '(or true false) t2)))
- ((eq? t2 'boolean)
- (and (not exact)
- (match1 t1 '(or true false))))
- ((eq? t1 'number)
- (and (not exact)
- (match1 '(or fixnum float) t2)))
- ((eq? t2 'number)
- (and (not exact)
- (match1 t1 '(or fixnum float))))
- ((eq? 'procedure t1)
- (and (pair? t2)
- (eq? 'procedure (car t2))))
- ((eq? 'procedure t2)
- (and (not exact)
- (pair? t1)
- (eq? 'procedure (car t1))))
+ ((eq? t1 'noreturn))
+ ((eq? t2 'noreturn))
+ ((eq? t1 'boolean) (match1 '(or true false) t2))
+ ((eq? t2 'boolean) (match1 t1 '(or true false)))
+ ((eq? t1 'number) (match1 '(or fixnum float) t2))
+ ((eq? t2 'number) (match1 t1 '(or fixnum float)))
((eq? t1 'pair) (match1 '(pair * *) t2))
((eq? t2 'pair) (match1 t1 '(pair * *)))
((eq? t1 'list) (match1 '(list-of *) t2))
((eq? t2 'list) (match1 t1 '(list-of *)))
((eq? t1 'vector) (match1 '(vector-of *) t2))
((eq? t2 'vector) (match1 t1 '(vector-of *)))
+ ((eq? 'procedure t1)
+ (and (pair? t2) (eq? 'procedure (car t2))))
+ ((eq? 'procedure t2)
+ (and (not all)
+ (pair? t1) (eq? 'procedure (car t1))))
((eq? t1 'null)
- (and (not exact) (not all)
+ (and (not all)
(pair? t2) (eq? 'list-of (car t2))))
((eq? t2 'null)
- (and (not exact)
- (pair? t1) (eq? 'list-of (car t1))))
+ (and (pair? t1) (eq? 'list-of (car t1))))
((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))
(case (car t1)
((procedure)
@@ -1095,8 +1074,7 @@
(and (pair? t2)
(case (car t2)
((list-of)
- (and (not exact)
- (not all)
+ (and (not all)
(match1 (second t1) (second t2))
(match1 (third t1) t2)))
((list)
@@ -1111,7 +1089,7 @@
(and (pair? t1)
(case (car t1)
((list-of)
- (and (not exact)
+ (and (not all)
(match1 (second t1) (second t2))
(match1 t1 (third t2))))
((list)
@@ -1122,61 +1100,46 @@
`(list ,@(cddr t1)))
(third t2))))
(else #f))))
- ((and (pair? t1) (eq? 'list-of (car t1)))
- (or (eq? 'null t2)
- (and (pair? t2)
- (case (car t2)
- ((list)
- (let ((t1 (second t1)))
- (over-all-instantiations
- (cdr t2)
- typeenv
- #t
- (lambda (t) (match1 t1 t)))))
- (else #f)))))
((and (pair? t1) (eq? 'list (car t1)))
- (and (pair? t2)
- (case (car t2)
- ((list-of)
- (and (not exact)
- (not all)
- (let ((t2 (second t2)))
- (over-all-instantiations
- (cdr t1)
- typeenv
- #t
- (lambda (t) (match1 t t2))))))
- (else #f))))
+ (and (not all)
+ (pair? t2) (eq? 'list-of (car t2))
+ (over-all-instantiations
+ (cdr t1)
+ typeenv
+ #t
+ (cute match1 <> (second t2)))))
+ ((and (pair? t1) (eq? 'list-of (car t1)))
+ (and (pair? t2) (eq? 'list (car t2))
+ (over-all-instantiations
+ (cdr t2)
+ typeenv
+ #t
+ (cute match1 (second t1) <>))))
((and (pair? t1) (eq? 'vector (car t1)))
- (and (not exact) (not all)
- (pair? t2)
- (eq? 'vector-of (car t2))
- (let ((t2 (second t2)))
- (over-all-instantiations
- (cdr t1)
- typeenv
- #t
- (lambda (t) (match1 t t2))))))
- ((and (pair? t2) (eq? 'vector (car t2)))
- (and (pair? t1)
- (eq? 'vector-of (car t1))
- (let ((t1 (second t1)))
- (over-all-instantiations
- (cdr t2)
- typeenv
- #t
- (lambda (t) (match1 t1 t))))))
+ (and (not all)
+ (pair? t2) (eq? 'vector-of (car t2))
+ (over-all-instantiations
+ (cdr t1)
+ typeenv
+ #t
+ (cute match1 <> (second t2)))))
+ ((and (pair? t1) (eq? 'vector-of (car t1)))
+ (and (pair? t2) (eq? 'vector (car t2))
+ (over-all-instantiations
+ (cdr t2)
+ typeenv
+ #t
+ (cute match1 (second t1) <>))))
(else #f)))
(let ((m (match1 t1 t2)))
- (dd " match~a~a ~a <-> ~a -> ~a te: ~s"
- (if exact " (exact)" "")
+ (dd " match~a ~a <-> ~a -> ~a te: ~s"
(if all " (all)" "")
t1 t2 m typeenv)
m))
-(define (match-argument-types typelist atypes typeenv #!optional exact all)
+(define (match-argument-types typelist atypes typeenv)
;; this doesn't need optional: it is only used for predicate- and specialization
;; matching
(let loop ((tl typelist) (atypes atypes))
@@ -1186,9 +1149,9 @@
((eq? (car tl) '#!rest)
(every
(lambda (at)
- (match-types (cadr tl) at typeenv exact all))
+ (match-types (cadr tl) at typeenv #t))
atypes))
- ((match-types (car tl) (car atypes) typeenv exact all)
+ ((match-types (car tl) (car atypes) typeenv #t)
(loop (cdr tl) (cdr atypes)))
(else #f))))
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 1d12b4c4..fddeac4b 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -198,3 +198,12 @@
(if (char-or-string? x)
(symbol? x) ; should report with x = (or char string)
(string? x))) ; should report with x = symbol
+
+;; list- and pair-type argument matching
+
+(let ((f (the (pair -> *) _))) (f (list))) ; warning
+(let ((f (the (pair -> *) _))) (f (make-list x))) ; no warning
+(let ((f (the (null -> *) _))) (f (list 1))) ; warning
+(let ((f (the (null -> *) _))) (f (make-list x))) ; no warning
+(let ((f (the (list -> *) _))) (f (cons 1 2))) ; warning
+(let ((f (the (list -> *) _))) (f (cons 1 x))) ; no warning
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index ebd272f4..914d7d52 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -40,7 +40,7 @@ Warning: at toplevel:
(scrutiny-tests.scm:29) 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 `(forall (a179) (procedure car ((pair a179 *)) a179))'
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a191) (procedure car ((pair a191 *)) a191))'
Warning: at toplevel:
expected in `let' binding of `g10' a single result, but were given 2 results
@@ -147,4 +147,13 @@ Note: at toplevel:
(scrutiny-tests.scm:200) in procedure call to `string?', the predicate is called with an argument of type
`symbol' and will always return false
+Warning: at toplevel:
+ (scrutiny-tests.scm:204) in procedure call to `f', expected argument #1 of type `pair', but was given an argument of type `null'
+
+Warning: at toplevel:
+ (scrutiny-tests.scm:206) in procedure call to `f', expected argument #1 of type `null', but was given an argument of type `(list fixnum)'
+
+Warning: at toplevel:
+ (scrutiny-tests.scm:208) in procedure call to `f', expected argument #1 of type `list', but was given an argument of type `(pair fixnum fixnum)'
+
Warning: redefinition of standard binding: car
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 4570681b..23327952 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -61,4 +61,15 @@ return n;}
(compiler-typecase (if #t 'a "a")
(symbol 1))
+;; specializations are prioritized by order of appearance
+(: abc (* -> boolean))
+(define (abc x) #f)
+(define-specialization (abc (x number)) #t)
+(define-specialization (abc (x fixnum)) #f)
+(assert (abc 1))
+
+;; user-defined specializations take precedence over built-ins
+(define-specialization (+) 1)
+(assert (= (+) 1))
+
)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 930362fa..4d841ce8 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -27,55 +27,60 @@
(define (bar) 42)
-(define-syntax m
+(define-syntax type<=
(er-macro-transformer
(lambda (x r c)
(let ((t1 (cadr x))
(t2 (caddr x))
- (foo1 (gensym 'foo1))
- (foo2 (gensym 'foo2)))
+ (foo (gensym 'foo)))
`(begin
(print ',t1 " = " ',t2)
- (: ,foo1 (-> ,t1))
- (: ,foo2 (-> ,t2))
- (define (,foo1) (bar))
- (define (,foo2) (bar))
- (compiler-typecase (,foo1)
- (,t2 'ok))
- (print ',t2 " = " ',t1)
- (compiler-typecase (,foo2)
- (,t1 'ok)))))))
-
-(define-syntax mx
- (syntax-rules ()
- ((_ t x)
- (begin
- (print 'x " = " 't)
- (compiler-typecase
- x
- (t 'ok))))))
+ (: ,foo (-> ,t1))
+ (define (,foo) (bar))
+ (compiler-typecase (,foo)
+ (,t2 'ok)))))))
-(define-syntax mn
+(define-syntax type>
(er-macro-transformer
(lambda (x r c)
(let ((t1 (cadr x))
(t2 (caddr x))
- (foo1 (gensym 'foo1))
- (foo2 (gensym 'foo2)))
+ (foo (gensym 'foo)))
`(begin
(print ',t1 " != " ',t2)
- (: ,foo1 (-> ,t1))
- (: ,foo2 (-> ,t2))
- (define (,foo1) (bar))
- (define (,foo2) (bar))
- (compiler-typecase (,foo1)
+ (: ,foo (-> ,t1))
+ (define (,foo) (bar))
+ (compiler-typecase (,foo)
(,t2 (bomb))
- (else 'ok))
- (print ',t2 " != " ',t1)
- (compiler-typecase (,foo2)
- (,t1 (bomb))
(else 'ok)))))))
+(define-syntax m
+ (er-macro-transformer
+ (lambda (x r c)
+ (let ((t1 (cadr x))
+ (t2 (caddr x)))
+ `(begin
+ (type<= ,t1 ,t2)
+ (type<= ,t2 ,t1))))))
+
+(define-syntax mn
+ (er-macro-transformer
+ (lambda (x r c)
+ (let ((t1 (cadr x))
+ (t2 (caddr x)))
+ `(begin
+ (type> ,t1 ,t2)
+ (type> ,t2 ,t1))))))
+
+(define-syntax mx
+ (syntax-rules ()
+ ((_ t x)
+ (begin
+ (print 'x " = " 't)
+ (compiler-typecase
+ x
+ (t 'ok))))))
+
(define-syntax ms
(er-macro-transformer
(lambda (x r c)
@@ -174,7 +179,14 @@
(checkp pointer-vector? (make-pointer-vector 1) pointer-vector)
(checkp pointer? (address->pointer 1) pointer)
-(mn list null)
+(type<= null list)
+(type<= (list *) list)
+(type<= (vector *) vector)
+
+(type> list null)
+(type> list (list *))
+(type> vector (vector *))
+
(mn pair null)
(mn pair list)
@@ -208,9 +220,14 @@
(mx list (cddr-alike l))
(mx fixnum (cddr-alike p))
+(ms '(1 . 2) '() pair)
(ms '(1 2) '() pair)
+(ms '(1) '() pair)
+(ms '() '(1) (not pair))
(ms '() '(1 2) (not pair))
(ms '() '(1 . 2) (not pair))
+(ms '() '(1 . 2) list)
+(ms '(1 . 2) '() (not list))
(ms '(1 2) '(1 . 2) (pair * pair))
(ms '(1 2) '(1 . 2) (pair * list))
(ms '(1 2) '(1 2 3) (pair * (pair * null)))
@@ -332,3 +349,7 @@
(fixnum 'not-ok)
(else 'ok))))
+(assert ; clause order is respected
+ (compiler-typecase 1
+ (number #t)
+ (fixnum #f)))
Trap