On Sun, Jul 24, 2016 at 08:32:31PM +0200, Peter Bex wrote: > The attached patch fixes this by only allowing this specialisation > for lists that are known to be proper. This means anything that > ends with a smashed component, which is (or pair null), it will not > be considered to be a known proper list, so the optimisation is skipped.
And here's another improvement, to track types of "append"'s arguments into its return type. It needs to be applied after the fix for the list-ref specialisation, because it adds test cases that would otherwise conflict (I think). I'm having good hopes that this is a useful improvement, particularly because quasiquoted forms will expand to "append" calls, so there will be quite a few cases where semi-constant lists will get their types known, which they didn't before. There's one limitation: It doesn't know what to do when you append an unknown (or smashed) list to something else. I tried to come up with something that's smart enough to merge a nested (pair ...) type with a subsequent list argument, but I failed. We can add this later, though. Cheers, Peter
From c5691539d01b47625dfbb278bc4372dee03cc1b5 Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Sun, 24 Jul 2016 20:04:20 +0200 Subject: [PATCH] Add special-case scrutiny handling for "append". Type derivation works perfectly for arguments known to be proper lists, but for (pair ...) structures it will punt. However, it can emit warnings when the arguments (except for the last one) are known to be non-lists or improper lists. --- scrutinizer.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/scrutiny-tests.scm | 16 +++++++++++++++ tests/scrutiny.expected | 6 ++++++ types.db | 1 + 4 files changed, 75 insertions(+) diff --git a/scrutinizer.scm b/scrutinizer.scm index b143b0c..51bf9ad 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -2332,6 +2332,58 @@ `((list ,@(reverse (cdr arg1))))) rtypes))) +(let () + ;; See comment in vector (let) + (define (report loc msg . args) + (warning + (conc (location-name loc) + (sprintf "~?" msg (map type-name args))))) + + (define (append-special-case node args loc rtypes) + (define (potentially-proper-list? l) (match-types l 'list '())) + + (define (derive-result-type) + (let lp ((arg-types (cdr args)) + (index 1)) + (if (null? arg-types) + 'null + (let ((arg1 (walked-result (car arg-types)))) + (cond + ((and (pair? arg1) (eq? (car arg1) 'list)) + (and-let* ((rest-t (lp (cdr arg-types) (add1 index)))) + ;; decanonicalize, then recanonicalize to make it + ;; easy to append a variety of types. + (canonicalize-list-type + (foldl (lambda (rest t) `(pair ,t ,rest)) + rest-t (reverse (cdr arg1)))))) + + ((and (pair? arg1) (eq? (car arg1) 'list-of)) + (and-let* ((rest-t (lp (cdr arg-types) (add1 index)))) + ;; list-of's length unsurety is "contagious" + (simplify-type `(or ,arg1 ,rest-t)))) + + ;; TODO: (append (pair x (pair y z)) lst) => + ;; (pair x (pair y (or z lst))) + ;; This is trickier than it sounds! + + (else + ;; The final argument may be an atom or improper list + (unless (or (null? (cdr arg-types)) + (potentially-proper-list? arg1)) + (report + loc "~ain procedure call to `~s', argument #~a is \ + of type ~a but expected a proper list" + (node-source-prefix node) + (first (node-parameters + (first (node-subexpressions node)))) + index arg1)) + #f)))))) + (cond ((derive-result-type) => list) + (else rtypes))) + + (define-special-case append append-special-case) + (define-special-case ##sys#append append-special-case)) + ;;; Special cases for make-list/make-vector with a known size ; ; e.g. (make-list 3 #\a) => (list char char char) diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm index a9f1942..546c523 100644 --- a/tests/scrutiny-tests.scm +++ b/tests/scrutiny-tests.scm @@ -295,3 +295,19 @@ (define (list-ref-type-nowarn2) (add1 (list-ref l2 1)))) (let ((l3 (the (list-of fixnum) '(1 2 3)))) (define (list-ref-type-nowarn3) (add1 (list-ref l3 1)))) + +;; Test type preservation of append (TODO: decouple from list-ref) +(let ((l1 (append (list 'x 'y) (list 1 2 (eval '(list)))))) + (define (append-result-type-warn1) (add1 (list-ref l1 1)))) +;; This currently doesn't warn because pair types aren't joined yet +#;(let ((l2 (append (cons 'x (cons 'y (eval '(list)))) (list 'x 'y)))) + (define (append-result-type-warn2) (add1 (list-ref l2 1)))) +(let ((l3 (append (the (list-of symbol) '(x y)) '(a b)))) + (define (append-result-type-warn2) (add1 (list-ref l3 3)))) + +(let ((l1 (append (list 1 2) (list 'x 'y (eval '(list)))))) + (define (append-result-type-nowarn1) (add1 (list-ref l1 1)))) +(let ((l2 (append (cons 1 (cons 2 (eval '(list)))) (list 'x)))) + (define (append-result-type-nowarn2) (add1 (list-ref l2 1)))) +(let ((l3 (append (the (list-of fixnum) '(1 2)) '(x y)))) + (define (append-result-type-nowarn3) (add1 (list-ref l3 1)))) diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected index 7d02af3..ef9befd 100644 --- a/tests/scrutiny.expected +++ b/tests/scrutiny.expected @@ -206,4 +206,10 @@ Warning: in toplevel procedure `list-ref-type-warn2': Warning: in toplevel procedure `list-ref-type-warn3': (scrutiny-tests.scm:289) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' +Warning: in toplevel procedure `append-result-type-warn1': + (scrutiny-tests.scm:301) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + +Warning: in toplevel procedure `append-result-type-warn2': + (scrutiny-tests.scm:306) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + Warning: redefinition of standard binding: car diff --git a/types.db b/types.db index c22d981..c9640d9 100644 --- a/types.db +++ b/types.db @@ -174,6 +174,7 @@ (list-tail (forall (a) (#(procedure #:clean #:enforce #:foldable) list-tail ((list-of a) fixnum) (list-of a)))) (list-ref (forall (a) (#(procedure #:clean #:enforce #:foldable) list-ref ((list-of a) fixnum) a))) +;; special cased (see scrutinizer.scm) (append (#(procedure #:clean) append (#!rest *) *)) ; sic (##sys#append (#(procedure #:clean) ##sys#append (#!rest *) *)) -- 2.1.4
From fc9539bda29d06dfe6192ead249747c9d983559f Mon Sep 17 00:00:00 2001 From: Peter Bex <[email protected]> Date: Sun, 24 Jul 2016 20:04:20 +0200 Subject: [PATCH] Add special-case scrutiny handling for "append". Type derivation works perfectly for arguments known to be proper lists, but for (pair ...) structures it will punt. However, it can emit warnings when the arguments (except for the last one) are known to be non-lists or improper lists. --- scrutinizer.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/scrutiny-tests.scm | 16 +++++++++++++++ tests/scrutiny.expected | 6 ++++++ types.db | 1 + 4 files changed, 75 insertions(+) diff --git a/scrutinizer.scm b/scrutinizer.scm index 3502106..8738aef 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -2388,6 +2388,58 @@ `((list ,@(reverse (cdr arg1))))) rtypes))) +(let () + ;; See comment in vector (let) + (define (report loc msg . args) + (warning + (conc (location-name loc) + (sprintf "~?" msg (map unrename-type args))))) + + (define (append-special-case node args loc rtypes) + (define (potentially-proper-list? l) (match-types l 'list '())) + + (define (derive-result-type) + (let lp ((arg-types (cdr args)) + (index 1)) + (if (null? arg-types) + 'null + (let ((arg1 (walked-result (car arg-types)))) + (cond + ((and (pair? arg1) (eq? (car arg1) 'list)) + (and-let* ((rest-t (lp (cdr arg-types) (add1 index)))) + ;; decanonicalize, then recanonicalize to make it + ;; easy to append a variety of types. + (canonicalize-list-type + (foldl (lambda (rest t) `(pair ,t ,rest)) + rest-t (reverse (cdr arg1)))))) + + ((and (pair? arg1) (eq? (car arg1) 'list-of)) + (and-let* ((rest-t (lp (cdr arg-types) (add1 index)))) + ;; list-of's length unsurety is "contagious" + (simplify-type `(or ,arg1 ,rest-t)))) + + ;; TODO: (append (pair x (pair y z)) lst) => + ;; (pair x (pair y (or z lst))) + ;; This is trickier than it sounds! + + (else + ;; The final argument may be an atom or improper list + (unless (or (null? (cdr arg-types)) + (potentially-proper-list? arg1)) + (report + loc "~ain procedure call to `~s', argument #~a is \ + of type ~a but expected a proper list" + (node-source-prefix node) + (first (node-parameters + (first (node-subexpressions node)))) + index arg1)) + #f)))))) + (cond ((derive-result-type) => list) + (else rtypes))) + + (define-special-case append append-special-case) + (define-special-case ##sys#append append-special-case)) + ;;; Special cases for make-list/make-vector with a known size ; ; e.g. (make-list 3 #\a) => (list char char char) diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm index 30c7460..5fac5ba 100644 --- a/tests/scrutiny-tests.scm +++ b/tests/scrutiny-tests.scm @@ -295,3 +295,19 @@ (define (list-ref-type-nowarn2) (add1 (list-ref l2 1)))) (let ((l3 (the (list-of fixnum) '(1 2 3)))) (define (list-ref-type-nowarn3) (add1 (list-ref l3 1)))) + +;; Test type preservation of append (TODO: decouple from list-ref) +(let ((l1 (append (list 'x 'y) (list 1 2 (eval '(list)))))) + (define (append-result-type-warn1) (add1 (list-ref l1 1)))) +;; This currently doesn't warn because pair types aren't joined yet +#;(let ((l2 (append (cons 'x (cons 'y (eval '(list)))) (list 'x 'y)))) + (define (append-result-type-warn2) (add1 (list-ref l2 1)))) +(let ((l3 (append (the (list-of symbol) '(x y)) '(a b)))) + (define (append-result-type-warn2) (add1 (list-ref l3 3)))) + +(let ((l1 (append (list 1 2) (list 'x 'y (eval '(list)))))) + (define (append-result-type-nowarn1) (add1 (list-ref l1 1)))) +(let ((l2 (append (cons 1 (cons 2 (eval '(list)))) (list 'x)))) + (define (append-result-type-nowarn2) (add1 (list-ref l2 1)))) +(let ((l3 (append (the (list-of fixnum) '(1 2)) '(x y)))) + (define (append-result-type-nowarn3) (add1 (list-ref l3 1)))) diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected index 31871de..98ac177 100644 --- a/tests/scrutiny.expected +++ b/tests/scrutiny.expected @@ -201,4 +201,10 @@ Warning: in toplevel procedure `list-ref-type-warn2': Warning: in toplevel procedure `list-ref-type-warn3': (scrutiny-tests.scm:289) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' +Warning: in toplevel procedure `append-result-type-warn1': + (scrutiny-tests.scm:301) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + +Warning: in toplevel procedure `append-result-type-warn2': + (scrutiny-tests.scm:306) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol' + Warning: redefinition of standard binding: car diff --git a/types.db b/types.db index 4d0b88d..12014e8 100644 --- a/types.db +++ b/types.db @@ -169,6 +169,7 @@ (list-tail (forall (a) (#(procedure #:clean #:enforce) list-tail ((list-of a) fixnum) (list-of a)))) (list-ref (forall (a) (#(procedure #:clean #:enforce) list-ref ((list-of a) fixnum) a))) +;; special cased (see scrutinizer.scm) (append (#(procedure #:clean) append (#!rest *) *)) ; sic (##sys#append (#(procedure #:clean) ##sys#append (#!rest *) *)) -- 2.1.4
signature.asc
Description: Digital signature
_______________________________________________ Chicken-hackers mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-hackers
