From cf261b826a5af0395d16d15fc2d45f9693dceeea Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Wed, 18 Nov 2015 17:04:57 +0100 Subject: [PATCH] Mark external type declarations as declared. By not being marked as "declared", types loaded from a types database would be considered to be inferred via flow analysis. When scrutinizing procedure definitions, "initial-argument-types" and "variable-result" would simply return '* or '(*) as the type, which doesn't match the loaded declaration. This had the effect of blocking specialization. Because CHICKEN 4 doesn't use modules for its core procedures, we will only do this when building CHICKEN itself. User code may define toplevel procedures which match names from core, if the matching units are not loaded this is okay, but we can't apply the specializations in that case. This fixes the most important part of #1219. --- compiler.scm | 4 ++-- distribution/manifest | 1 + scrutinizer.scm | 12 +++++++++--- tests/runtests.bat | 2 +- tests/runtests.sh | 2 +- tests/specialization-test-2.scm | 6 ++++++ tests/specialization-test-2.types | 3 +++ 7 files changed, 23 insertions(+), 7 deletions(-) create mode 100644 tests/specialization-test-2.types diff --git a/compiler.scm b/compiler.scm index b7bab0c..00d09f0 100644 --- a/compiler.scm +++ b/compiler.scm @@ -91,7 +91,7 @@ ; ##compiler#pure -> BOOL referentially transparent ; ##compiler#clean -> BOOL does not modify local state ; ##compiler#type -> TYPE -; ##compiler#declared-type -> BOOL +; ##compiler#declared-type -> 'from-db | 'local | 'implicit ; - Source language: ; @@ -1568,7 +1568,7 @@ (symbol? (cadr type))) (set-car! (cdr type) name)) (mark-variable name '##compiler#type type) - (mark-variable name '##compiler#declared-type) + (mark-variable name '##compiler#declared-type 'local) (when pure (mark-variable name '##compiler#pure #t)) (when pred diff --git a/distribution/manifest b/distribution/manifest index c2f1553..1dd037f 100644 --- a/distribution/manifest +++ b/distribution/manifest @@ -178,6 +178,7 @@ tests/loopy-loop.scm tests/r5rs_pitfalls.scm tests/specialization-test-1.scm tests/specialization-test-2.scm +tests/specialization-test-2.types tests/test-irregex.scm tests/re-tests.txt tests/lolevel-tests.scm diff --git a/scrutinizer.scm b/scrutinizer.scm index 99da823..c947221 100644 --- a/scrutinizer.scm +++ b/scrutinizer.scm @@ -84,7 +84,7 @@ ; global symbol properties: ; ; ##compiler#type -> TYPESPEC -; ##compiler#declared-type -> BOOL +; ##compiler#declared-type -> 'from-db | 'local | 'implicit ; ##compiler#predicate -> TYPESPEC ; ##compiler#specializations -> (SPECIALIZATION ...) ; ##compiler#local-specializations -> (SPECIALIZATION ...) @@ -643,7 +643,7 @@ ;; [2] sets property, but lambda has already been walked, ;; so no type-checks are generated (see also [1], above) ;; note that implicit declarations are not enforcing - (mark-variable var '##compiler#declared-type) + (mark-variable var '##compiler#declared-type 'implicit) (mark-variable var '##compiler#type rt)))))) (when b (cond ((eq? 'undefined (cdr b)) (set-cdr! b rt)) @@ -1778,6 +1778,11 @@ "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'" name new old))) (mark-variable name '##compiler#type t) + ;; We only allow db-loaded types to affect core code + ;; because core isn't properly namespaced. User code may + ;; unwittingly redefine core procedures, causing issues. + (when (feature? #:chicken-bootstrap) + (mark-variable name '##compiler#declared-type 'from-db)) (when specs (install-specializations name specs))))) (read-file dbfile)) @@ -1791,7 +1796,8 @@ (##sys#hash-table-for-each (lambda (sym plist) (when (and (variable-visible? sym) - (variable-mark sym '##compiler#declared-type)) + (memq (variable-mark sym '##compiler#declared-type) + '(local implicit))) (let ((specs (or (variable-mark sym '##compiler#specializations) '())) (type (variable-mark sym '##compiler#type)) (pred (variable-mark sym '##compiler#predicate)) diff --git a/tests/runtests.bat b/tests/runtests.bat index 9539bd4..be587d4 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -73,7 +73,7 @@ del /f /q foo.types foo.import.* if errorlevel 1 exit /b 1 a.out if errorlevel 1 exit /b 1 -%compile% specialization-test-2.scm -types foo.types -specialize -debug ox +%compile% specialization-test-2.scm -types foo.types -types specialization-test-2.types -feature chicken-bootstrap -specialize -debug ox if errorlevel 1 exit /b 1 a.out if errorlevel 1 exit /b 1 diff --git a/tests/runtests.sh b/tests/runtests.sh index 4bbd171..e3aafdc 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -113,7 +113,7 @@ rm -f foo.types foo.import.* $compile specialization-test-1.scm -emit-type-file foo.types -specialize \ -debug ox -emit-import-library foo ./a.out -$compile specialization-test-2.scm -types foo.types -specialize -debug ox +$compile specialization-test-2.scm -types foo.types -types specialization-test-2.types -feature chicken-bootstrap -specialize -debug ox ./a.out rm -f foo.types foo.import.* diff --git a/tests/specialization-test-2.scm b/tests/specialization-test-2.scm index e24e5cb..9b80922 100644 --- a/tests/specialization-test-2.scm +++ b/tests/specialization-test-2.scm @@ -26,3 +26,9 @@ return n;} (assert (handle-exceptions ex #t (bug855 '(#f)) #f)) +;; #1219: Specializations from databases loaded with "-types" should +;; be applied. +(define (specialize-me x) + (error "Not specialized!")) + +(assert (= (specialize-me 123) 123)) diff --git a/tests/specialization-test-2.types b/tests/specialization-test-2.types new file mode 100644 index 0000000..7ca640d --- /dev/null +++ b/tests/specialization-test-2.types @@ -0,0 +1,3 @@ +;; -*- Scheme -*- +(specialize-me (procedure specialize-me (fixnum) fixnum) + ((fixnum) #(1))) -- 2.1.4