>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