~ chicken-core (chicken-5) 5fcf890d6a724da6d7eac2f7beee19aa6832c80f
commit 5fcf890d6a724da6d7eac2f7beee19aa6832c80f
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Wed Nov 18 17:04:57 2015 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon Jan 11 08:48:27 2016 +1300
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.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/compiler.scm b/compiler.scm
index b7bab0cf..00d09f0c 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 c2f1553c..1dd037f4 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 99da8236..c9472211 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 9539bd4d..be587d49 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 4bbd171e..e3aafdcf 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 e24e5cbf..9b80922d 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 00000000..7ca640d9
--- /dev/null
+++ b/tests/specialization-test-2.types
@@ -0,0 +1,3 @@
+;; -*- Scheme -*-
+(specialize-me (procedure specialize-me (fixnum) fixnum)
+ ((fixnum) #(1)))
Trap