>From 210baf30a4f9201e6f55abb9ce00803157f6df61 Mon Sep 17 00:00:00 2001
From: Evan Hanson
Date: Sun, 14 Sep 2014 17:48:49 +1200
Subject: [PATCH] Export specializations with generated type database
information
This extends `define-specialization` so that specializations are
exported and included in the type database files generated with the
"-emit-type-file" option. The specialization procedures are numerically
hash-suffixed and exported only when the procedure being specialized is
itself exported. This also allows us to remove the now-unnecessary
`##compiler#local-specializations` property.
Also fixes a tiny issue in one of the specialization-test-1 tests where
a specialization's return type wasn't given properly (i.e. as a list).
---
NEWS | 4 ++++
chicken-syntax.scm | 36 +++++++++++++++++-----------
distribution/manifest | 3 +++
manual/Types | 26 ++++++++++----------
scrutinizer.scm | 9 ++-----
tests/runtests.bat | 5 ++++
tests/runtests.sh | 5 ++++
tests/specialization-export-test.scm | 25 +++++++++++++++++++
tests/specialization-export.scm | 24 +++++++++++++++++++
tests/specialization-export.types.expected | 9 +++++++
tests/specialization-test-1.scm | 6 ++++-
11 files changed, 117 insertions(+), 35 deletions(-)
create mode 100644 tests/specialization-export-test.scm
create mode 100644 tests/specialization-export.scm
create mode 100644 tests/specialization-export.types.expected
diff --git a/NEWS b/NEWS
index 1a1daa0..8b5316a 100644
--- a/NEWS
+++ b/NEWS
@@ -51,6 +51,10 @@
means names from the compiler should not leak out into the compiled
program's (macro) namespace anymore.
+- Scrutinizer
+ - Specializations are now included in generated type database
+ information.
+
- Syntax expander
- define-values, set!-values and letrec-values now support full lambda
lists as binding forms
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 9fcd2bb..5d77f4b 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1219,10 +1219,13 @@
(name (car head))
(gname (##sys#globalize name '())) ;XXX correct?
(args (cdr head))
- (alias (gensym name))
+ (specs (or (chicken.compiler.support#variable-mark gname '##compiler#specializations) '()))
+ (alias (##sys#string->symbol ; specializations get the suffix "#"
+ (string-append (##sys#symbol->string name)
+ "#"
+ (##sys#number->string (##sys#length specs)))))
(galias (##sys#globalize alias '())) ;XXX and this?
(rtypes (and (pair? (cdddr x)) (##sys#strip-syntax (caddr x))))
- (%define (r 'define))
(body (if rtypes (cadddr x) (caddr x))))
(let loop ((args args) (anames '()) (atypes '()))
(cond ((null? args)
@@ -1235,8 +1238,9 @@
(cons (vector i)
(loop2 (cdr anames) (fx+ i 1))))))))
(##sys#put!
- gname '##compiler#local-specializations
+ gname '##compiler#specializations
(##sys#append
+ specs
(list
(cons atypes
(if (and rtypes (pair? rtypes))
@@ -1246,18 +1250,22 @@
'define-specialization)
rtypes)
spec)
- (list spec))))
- (or (chicken.compiler.support#variable-mark
- gname
- '##compiler#local-specializations)
- '())))
+ (list spec))))))
`(##core#begin
- (##core#declare (inline ,alias) (hide ,alias))
- (,%define (,alias ,@anames)
- (##core#let ,(map (lambda (an at)
- (list an `(##core#the ,at #t ,an)))
- anames atypes)
- ,body)))))
+ (##core#declare
+ (inline ,alias)
+ (unused ,alias)
+ ,@(if (chicken.compiler.support#variable-visible?
+ gname
+ chicken.compiler.core#block-compilation)
+ '()
+ `((hide ,alias))))
+ (##core#set! ,alias
+ (##core#lambda ,anames
+ (##core#let ,(map (lambda (an at)
+ (list an `(##core#the ,at #t ,an)))
+ anames atypes)
+ ,body))))))
(else
(let ((arg (car args)))
(cond ((symbol? arg)
diff --git a/distribution/manifest b/distribution/manifest
index 61cbc65..988b84b 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -173,6 +173,9 @@ tests/loopy-loop.scm
tests/r5rs_pitfalls.scm
tests/specialization-test-1.scm
tests/specialization-test-2.scm
+tests/specialization-export.scm
+tests/specialization-export-test.scm
+tests/specialization-export.types.expected
tests/test-irregex.scm
tests/re-tests.txt
tests/lolevel-tests.scm
diff --git a/manual/Types b/manual/Types
index 904a37e..2191cfb 100644
--- a/manual/Types
+++ b/manual/Types
@@ -273,19 +273,19 @@ 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.
+Declares that 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 types
+if they differ 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. When encountered in the
+interpreter, {{define-specialization}} does nothing and returns an
+unspecified result.
+
+{{NAME}} should have a previously declared type (for example by using
+{{:}}), though this is currently not checked.
Note that the exact order of specialization application is not
specified and nested specializations may result in not narrowing down
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 5f61d6a..29a3a83 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -86,7 +86,6 @@
; ##compiler#declared-type -> BOOL
; ##compiler#predicate -> TYPESPEC
; ##compiler#specializations -> (SPECIALIZATION ...)
-; ##compiler#local-specializations -> (SPECIALIZATION ...)
; ##compiler#enforce -> BOOL
; ##compiler#special-result-type -> PROCEDURE
; ##compiler#escape -> #f | 'yes | 'no
@@ -188,7 +187,7 @@
(cond ((blist-type id flow) => list)
((and (not strict)
(db-get db id 'assigned)
- (not (variable-mark id '##compiler#declared-type)))
+ (not (variable-mark id '##compiler#type)))
'(*))
((assq id e) =>
(lambda (a)
@@ -290,10 +289,7 @@
(pp (fragment x))))))
(define (get-specializations name)
- (let* ((a (variable-mark name '##compiler#specializations))
- (b (variable-mark name '##compiler#local-specializations))
- (c (append (or a '()) (or b '()))))
- (and (pair? c) c)))
+ (variable-mark name '##compiler#specializations))
(define (call-result node args e loc params typeenv)
(define (pname)
@@ -642,7 +638,6 @@
;; [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#type rt))))))
(when b
(cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))
diff --git a/tests/runtests.bat b/tests/runtests.bat
index bb3186e..961f6a5 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -79,6 +79,11 @@ a.out
if errorlevel 1 exit /b 1
del /f /q foo.types foo.import.*
+%compile_s% -J specialization-export.scm -emit-type-file specialization-export.types
+%compile% specialization-export-test.scm -types specialization-export.types -specialize -debug ox
+a.out
+del /f /q specialization-export.so specialization-export.types mod.import.scm
+
echo ======================================== specialization benchmark ...
%compile% fft.scm -O2 -local -d0 -disable-interrupts -b -o fft1
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 53389ac..f79c5d2 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -117,6 +117,11 @@ $compile specialization-test-2.scm -types foo.types -specialize -debug ox
./a.out
rm -f foo.types foo.import.*
+$compile_s -J specialization-export.scm -emit-type-file specialization-export.types
+$compile specialization-export-test.scm -types specialization-export.types -specialize -debug ox
+./a.out
+rm -f specialization-export.so specialization-export.types mod.import.scm
+
echo "======================================== specialization benchmark ..."
$compile fft.scm -O2 -local -d0 -disable-interrupts -b -o fft1
$compile fft.scm -O2 -local -specialize -debug x -d0 -disable-interrupts -b -o fft2 -specialize
diff --git a/tests/specialization-export-test.scm b/tests/specialization-export-test.scm
new file mode 100644
index 0000000..f02db2a
--- /dev/null
+++ b/tests/specialization-export-test.scm
@@ -0,0 +1,25 @@
+;;;
+;;; specialization-export-test.scm
+;;;
+;;; Tests a set of (hopefully) exported specializations, defined by
+;;; specialization-export.scm.
+;;;
+
+(load "specialization-export.so")
+
+(use (only srfi-1 lset<=)
+ (only extras read-file))
+
+(assert (lset= equal? (read-file "specialization-export.types.expected")
+ (read-file "specialization-export.types")))
+
+(assert (= (foo 2) -3))
+(assert (= (foo 2.) -1.))
+(assert (compiler-typecase (foo 1) (fixnum #t) (else #f)))
+(assert (compiler-typecase (foo 1.) (float #t) (else #f)))
+
+(import (prefix mod mod:))
+(assert (mod:foo #f))
+(assert (not (mod:foo #t)))
+(assert (compiler-typecase (mod:foo #f) (true #t) (else #f)))
+(assert (compiler-typecase (mod:foo #t) (false #t) (else #f)))
diff --git a/tests/specialization-export.scm b/tests/specialization-export.scm
new file mode 100644
index 0000000..ff2e9bb
--- /dev/null
+++ b/tests/specialization-export.scm
@@ -0,0 +1,24 @@
+;;;
+;;; specialization-export.scm
+;;;
+;;; Defines a set of (hopefully) exported specializations, tested by
+;;; specialization-export-test.scm.
+;;;
+
+(: foo (number -> number))
+(define (foo x) (- x))
+(define-specialization (foo (x fixnum)) (fixnum) (fx- (fxneg x) 1))
+(define-specialization (foo (x float)) (float) (fp+ (fpneg x) 1.))
+
+(define (bar x) (- x))
+(define-specialization (bar x) x)
+(declare (hide bar))
+
+(module mod (foo)
+ (import chicken scheme)
+ (: foo (boolean -> boolean))
+ (define (foo x) x)
+ (define-specialization (foo (x false)) (true) #t)
+ (define-specialization (foo (x true)) (false) #f)
+ (define (bar x) x)
+ (define-specialization (bar x) #t))
diff --git a/tests/specialization-export.types.expected b/tests/specialization-export.types.expected
new file mode 100644
index 0000000..cd6a6ba
--- /dev/null
+++ b/tests/specialization-export.types.expected
@@ -0,0 +1,9 @@
+(foo
+ (#(procedure) foo (number) number)
+ ((fixnum) (fixnum) (foo#0 #(1)))
+ ((float) (float) (foo#1 #(1))))
+
+(mod#foo
+ (#(procedure) mod#foo (boolean) boolean)
+ ((false) (true) (mod#foo#0 #(1)))
+ ((true) (false) (mod#foo#1 #(1))))
diff --git a/tests/specialization-test-1.scm b/tests/specialization-test-1.scm
index 37e8d6b..40ee108 100644
--- a/tests/specialization-test-1.scm
+++ b/tests/specialization-test-1.scm
@@ -31,11 +31,15 @@ return n;}
(: spec (* -> *))
(define (spec x) x)
-(define-specialization (spec (x fixnum)) fixnum
+(define-specialization (spec (x fixnum)) (fixnum)
(+ x 1))
(assert (= 2 (spec 1)))
+(compiler-typecase (spec 1)
+ (fixnum 'ok)
+ (else (error "result type specialization failed")))
+
;; "smash-component-types!" had to convert "list[-of]" types to "pair" (#803)
(let ((x (list 'a)))
(set-cdr! x x)
--
1.7.10.4