>From a62eeb7a25718b9db8df257b26511cd231a58ae5 Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Wed, 30 Sep 2015 09:01:31 +1300 Subject: [PATCH] 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. --- chicken-syntax.scm | 11 +-- manual/Types | 50 +++++------- scrutinizer.scm | 169 ++++++++++++++++------------------------ tests/scrutiny-tests.scm | 9 +++ tests/scrutiny.expected | 11 ++- tests/specialization-test-1.scm | 11 +++ tests/typematch-tests.scm | 89 +++++++++++++-------- 7 files changed, 175 insertions(+), 175 deletions(-) diff --git a/chicken-syntax.scm b/chicken-syntax.scm index f81fc4b..11ecda2 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 5e7a87d..a275c6b 100644 --- a/manual/Types +++ b/manual/Types @@ -272,36 +272,26 @@ Specializations can also be defined by the user: (define-specialization (NAME ARGUMENT ...) [RESULTS] BODY) -{{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 62378df..99da823 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 1d12b4c..fddeac4 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 ebd272f..914d7d5 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 4570681..2332795 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 930362f..4d841ce 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))) -- 2.5.1