~ chicken-core (chicken-5) 7ab8030ca16177b719a370f3cde40f2a83a0b95d
commit 7ab8030ca16177b719a370f3cde40f2a83a0b95d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Jan 20 04:56:39 2011 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Jan 20 04:56:39 2011 -0500
-specialize option and scrutinizer changes
diff --git a/batch-driver.scm b/batch-driver.scm
index a9e7f276..87acb498 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -91,6 +91,8 @@
(a-only (memq 'analyze-only options))
(dynamic (memq 'dynamic options))
(unbox (memq 'unboxing options))
+ (do-scrutinize (when (memq 'scrutinize options))
+ (do-specialize (when (memq 'specialize options))
(dumpnodes #f)
(start-time #f)
(upap #f)
@@ -185,8 +187,6 @@
(set! all-import-libraries #t))
(set! enable-module-registration (not (memq 'no-module-registration options)))
(when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
- (when (memq 'scrutinize options)
- (set! do-scrutinize #t))
(when (memq 't debugging-chicken) (##sys#start-timer))
(when (memq 'b debugging-chicken) (set! time-breakdown #t))
(when (memq 'emit-exports options)
@@ -500,8 +500,8 @@
(print-node "initial node tree" '|T| node0)
(initialize-analysis-database)
- (when do-scrutinize
- ;;;*** hardcoded database file name
+ (when (or do-scrutinize do-specialize)
+ ;;;XXX hardcoded database file name
(unless (memq 'ignore-repository options)
(load-type-database "types.db"))
(for-each (cut load-type-database <> #f) (collect-options 'types))
@@ -512,14 +512,14 @@
(end-time "pre-analysis")
(begin-time)
(debugging 'p "performing scrutiny")
- (scrutinize node0 db)
+ (scrutinize node0 db do-scrutinize do-specialize)
(end-time "scrutiny")
(set! first-analysis #t) )
(when do-lambda-lifting
(begin-time)
- (unless do-scrutinize ; no need to do analysis if already done above
- (set! first-analysis #f)
+ (unless do-scrutinize ; no need to do analysis if already done
+ (set! first-analysis #f) ; (and not specialized)
(set! db (analyze 'lift node0))
(print-db "analysis" '|0| db 0)
(end-time "pre-analysis (lambda-lift)"))
diff --git a/c-platform.scm b/c-platform.scm
index c1074bef..1a3e9273 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -85,7 +85,7 @@
profile inline keep-shadowed-macros ignore-repository
fixnum-arithmetic disable-interrupts optimize-leaf-routines
lambda-lift compile-syntax tag-pointers accumulate-profile
- disable-stack-overflow-checks raw
+ disable-stack-overflow-checks raw specialize
emit-external-prototypes-first release local inline-global
analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
no-procedure-checks-for-toplevel-bindings module
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index d4fa6b56..679a62c8 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -98,7 +98,6 @@
display-line-number-database
display-real-name-table
do-lambda-lifting
- do-scrutinize
dump-defined-globals
dump-global-refs
dump-nodes
diff --git a/compiler.scm b/compiler.scm
index a7d08eb5..41d6736c 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -333,7 +333,6 @@
(define local-definitions #f)
(define inline-locally #f)
(define inline-output-file #f)
-(define do-scrutinize #f)
(define enable-inline-files #f)
(define compiler-syntax-enabled #t)
(define unchecked-specialized-arithmetic #f)
@@ -1464,9 +1463,11 @@
((type)
(for-each
(lambda (spec)
- (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
+ (cond ((and (list? spec) (symbol? (car spec)) (>= 2 (length spec)))
(##sys#put! (car spec) '##core#type (cadr spec))
- (##sys#put! (car spec) '##core#declared-type #t))
+ (##sys#put! (car spec) '##core#declared-type #t)
+ (when (pair? (cddr spec))
+ (##sys#put! (car spec) '##core#specializations (cddr spec))))
(else
(warning "illegal `type' declaration item" spec))))
(globalize-all (cdr spec))))
diff --git a/csc.scm b/csc.scm
index e097523d..bc840c79 100644
--- a/csc.scm
+++ b/csc.scm
@@ -138,7 +138,7 @@
-no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
-emit-all-import-libraries -setup-mode -unboxing -no-elevation -no-module-registration
- -no-procedure-checks-for-usual-bindings -module
+ -no-procedure-checks-for-usual-bindings -module -specialize
-no-procedure-checks-for-toplevel-bindings))
(define-constant complex-options
@@ -370,6 +370,7 @@ Usage: #{csc} FILENAME | OPTION ...
-inline-limit LIMIT set inlining threshold
-inline-global enable cross-module inlining
-unboxing use unboxed temporaries if possible
+ -specialize perform type-based specialization of primitive calls
-n -emit-inline-file FILENAME generate file with globally inlinable
procedures (implies -inline -local)
-consult-inline-file FILENAME explicitly load inline file
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 0c2d77ba..87baa8f2 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -24,7 +24,9 @@
; POSSIBILITY OF SUCH DAMAGE.
-(declare (unit scrutinizer))
+(declare
+ (unit scrutinizer)
+ (hide match-specialization specialize-node!))
(include "compiler-namespace")
@@ -59,11 +61,20 @@
;
; ##core#type -> <typespec>
; ##core#declared-type -> <bool>
+; ##core#specializations -> (SPECIALIZATION ...)
+;
+; specialization specifiers:
+;
+; SPECIALIZATION = ((VAL ... [#!rest VAL]) TEMPLATE)
+; TEMPLATE = INTEGER | SYMBOL | STRING
+; | (quote CONSTANT)
+; | (TEMPLATE . TEMPLATE)
+
(define-constant +fragment-max-length+ 5)
(define-constant +fragment-max-depth+ 3)
-(define (scrutinize node db)
+(define (scrutinize node db complain specialize)
(define (constant-result lit)
(cond ((string? lit) 'string)
((symbol? lit) 'symbol)
@@ -394,8 +405,9 @@
what n (multiples n)))
(first tv))))))
(define (report loc desc)
- (warning
- (conc (location-name loc) desc)))
+ (when complain
+ (warning
+ (conc (location-name loc) desc))))
(define (location-name loc)
(define (lname loc1)
(if loc1
@@ -423,7 +435,7 @@
(with-output-to-string
(lambda ()
(pp (fragment x))))))
- (define (call-result args e loc x params)
+ (define (call-result node args e loc params)
(define (pname)
(sprintf "~ain procedure call to `~s', "
(if (and (pair? params) (pair? (cdr params)))
@@ -432,7 +444,7 @@
(sprintf "~a: " n)
""))
"")
- (fragment x)))
+ (fragment (first (node-subexpressions node)))))
(d "call-result: ~a (~a)" args loc)
(let* ((ptype (car args))
(nargs (length (cdr args)))
@@ -446,7 +458,7 @@
(pname)
xptype
ptype)))
- (let-values (((atypes values-rest) (procedure-argument-types ptype (length (cdr args)))))
+ (let-values (((atypes values-rest) (procedure-argument-types ptype nargs)))
(d " argument-types: ~a (~a)" atypes values-rest)
(unless (= (length atypes) nargs)
(let ((alen (length atypes)))
@@ -468,6 +480,15 @@
(pname) i (car atypes) (car args)))))
(let ((r (procedure-result-types ptype values-rest (cdr args))))
(d " result-types: ~a" r)
+ (when specialize
+ ;;XXX we should check whether this is a standard- or extended bindng
+ (and-let* ((pn (procedure-name ptype))
+ (specs (##sys#get pn '##core#specializations)))
+ (for-each
+ (lambda (spec)
+ (when (match-specialization (car spec) (cdr args) match)
+ (specialize-node! node (cadr spec))))
+ specs)))
r))))
(define (procedure-type? t)
(or (eq? 'procedure t)
@@ -475,6 +496,11 @@
(or (eq? 'procedure (car t))
(and (eq? 'or (car t))
(every procedure-type? (cdr t)))))))
+ (define (procedure-name t)
+ (and (pair? t)
+ (eq? 'procedure (car t))
+ (or (string? (cadr t)) (symbol? (cadr t)))
+ (->string (cadr t))))
(define (procedure-argument-types t n)
(cond ((or (memq t '(* procedure))
(not-pair? t)
@@ -620,7 +646,7 @@
f)
(walk n e loc #f #f) loc))
subs (iota (length subs)))))
- (call-result args e loc (first subs) params)))
+ (call-result n args e loc params)))
((##core#switch ##core#cond)
(bomb "unexpected node class: ~a" class))
(else
@@ -638,11 +664,32 @@
(lambda (e)
(let* ((name (car e))
(old (##sys#get name '##core#type))
- (new (cadr e)))
+ (new (cadr e))
+ (specs (and (pair? (cddr e)) (cddr e))))
(when (and old (not (equal? old new)))
(##sys#notice
(sprintf
"type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
name new old)))
- (##sys#put! name '##core#type new)))
+ (##sys#put! name '##core#type new)
+ (when specs
+ (##sys#put! name '##core#specializations specs))))
(read-file dbfile))))
+
+(define (match-specialization typelist atypes match)
+ (let loop ((tl typelist) (atypes atypes))
+ (cond ((null? tl) (null? atypes))
+ ((null? atypes) #f)
+ ((eq? (car tl) '#!rest)
+ (every (cute match (cadr tl) <>) atypes))
+ ((match (car tl) (car atypes)) (loop (cdr tl) (cdr atypes)))
+ (else #f))))
+
+(define (specialize-node! node template)
+ (let ((args (cdr (node-subexpressions node))))
+ (define (subst x)
+ (cond ((fixnum? x) (list-ref args x))
+ ((not (pair? x)) x)
+ ((eq? 'quote (car x)) x)
+ (else (cons (subst (car x)) (subst (cdr x))))))
+ (copy-node! (build-node-graph (subst template)) node)))
diff --git a/support.scm b/support.scm
index 4c84cd99..34cf3400 100644
--- a/support.scm
+++ b/support.scm
@@ -1212,144 +1212,6 @@
[else (loop (sub1 i))] ) ) ) )
-;;; Print version/usage information:
-
-(define (print-version #!optional b)
- (when b (print* +banner+))
- (print (chicken-version #t)) )
-
-(define (print-usage)
- (print-version)
- (newline)
- (display #<<EOF
-Usage: chicken FILENAME OPTION ...
-
- `chicken' is the CHICKEN compiler.
-
- FILENAME should be a complete source file name with extension, or "-" for
- standard input. OPTION may be one of the following:
-
- General options:
-
- -help display this text and exit
- -version display compiler version and exit
- -release print release number and exit
- -verbose display information on compilation progress
-
- File and pathname options:
-
- -output-file FILENAME specifies output-filename, default is 'out.c'
- -include-path PATHNAME specifies alternative path for included files
- -to-stdout write compiled file to stdout instead of file
-
- Language options:
-
- -feature SYMBOL register feature identifier
- -no-feature SYMBOL disable built-in feature identifier
-
- Syntax related options:
-
- -case-insensitive don't preserve case of read symbols
- -keyword-style STYLE allow alternative keyword syntax
- (prefix, suffix or none)
- -no-parentheses-synonyms disables list delimiter synonyms
- -no-symbol-escape disables support for escaped symbols
- -r5rs-syntax disables the Chicken extensions to
- R5RS syntax
- -compile-syntax macros are made available at run-time
- -emit-import-library MODULE write compile-time module information into
- separate file
- -emit-all-import-libraries emit import-libraries for all defined modules
- -no-module-registration do not generate module registration code
- -no-compiler-syntax disable expansion of compiler-macros
- -module wrap compiled code into implicit module
-
- Translation options:
-
- -explicit-use do not use units 'library' and 'eval' by
- default
- -check-syntax stop compilation after macro-expansion
- -analyze-only stop compilation after first analysis pass
-
- Debugging options:
-
- -no-warnings disable warnings
- -debug-level NUMBER set level of available debugging information
- -no-trace disable tracing information
- -profile executable emits profiling information
- -profile-name FILENAME name of the generated profile information file
- -accumulate-profile executable emits profiling information in
- append mode
- -no-lambda-info omit additional procedure-information
- -scrutinize perform local flow analysis for static checks
- -picky perform more static checks (implies -scrutinize)
- -types FILENAME load additional type database
-
- Optimization options:
-
- -optimize-level NUMBER enable certain sets of optimization options
- -optimize-leaf-routines enable leaf routine optimization
- -lambda-lift enable lambda-lifting
- -no-usual-integrations standard procedures may be redefined
- -unsafe disable all safety checks
- -local assume globals are only modified in current
- file
- -block enable block-compilation
- -disable-interrupts disable interrupts in compiled code
- -fixnum-arithmetic assume all numbers are fixnums
- -benchmark-mode equivalent to 'block -optimize-level 4
- -debug-level 0 -fixnum-arithmetic -lambda-lift
- -inline -disable-interrupts'
- -disable-stack-overflow-checks disables detection of stack-overflows
- -inline enable inlining
- -inline-limit LIMIT set inlining threshold
- -inline-global enable cross-module inlining
- -unboxing use unboxed temporaries if possible
- -emit-inline-file FILENAME generate file with globally inlinable
- procedures (implies -inline -local)
- -consult-inline-file FILENAME explicitly load inline file
- -no-argc-checks disable argument count checks
- -no-bound-checks disable bound variable checks
- -no-procedure-checks disable procedure call checks
- -no-procedure-checks-for-usual-bindings
- disable procedure call checks only for usual
- bindings
- -no-procedure-checks-for-toplevel-bindings
- disable procedure call checks for toplevel
- bindings
-
- Configuration options:
-
- -unit NAME compile file as a library unit
- -uses NAME declare library unit as used.
- -heap-size NUMBER specifies heap-size of compiled executable
- -heap-initial-size NUMBER specifies heap-size at startup time
- -heap-growth PERCENTAGE specifies growth-rate of expanding heap
- -heap-shrinkage PERCENTAGE specifies shrink-rate of contracting heap
- -nursery NUMBER -stack-size NUMBER
- specifies nursery size of compiled executable
- -extend FILENAME load file before compilation commences
- -prelude EXPRESSION add expression to front of source file
- -postlude EXPRESSION add expression to end of source file
- -prologue FILENAME include file before main source file
- -epilogue FILENAME include file after main source file
- -dynamic compile as dynamically loadable code
- -require-extension NAME require and import extension NAME
-
- Obscure options:
-
- -debug MODES display debugging output for the given modes
- -raw do not generate implicit init- and exit code
- -emit-external-prototypes-first
- emit prototypes for callbacks before foreign
- declarations
- -ignore-repository do not refer to repository for extensions
- -setup-mode prefer the current directory when locating extensions
-
-EOF
-) )
-
-
;;; Special block-variable literal type:
(define-record-type block-variable-literal
@@ -1563,3 +1425,142 @@ EOF
id '##core#db
(append (or (##sys#get id '##core#db) '()) (list (cdr e))) )))
(read-file dbfile))))
+
+
+;;; Print version/usage information:
+
+(define (print-version #!optional b)
+ (when b (print* +banner+))
+ (print (chicken-version #t)) )
+
+(define (print-usage)
+ (print-version)
+ (newline)
+ (display #<<EOF
+Usage: chicken FILENAME OPTION ...
+
+ `chicken' is the CHICKEN compiler.
+
+ FILENAME should be a complete source file name with extension, or "-" for
+ standard input. OPTION may be one of the following:
+
+ General options:
+
+ -help display this text and exit
+ -version display compiler version and exit
+ -release print release number and exit
+ -verbose display information on compilation progress
+
+ File and pathname options:
+
+ -output-file FILENAME specifies output-filename, default is 'out.c'
+ -include-path PATHNAME specifies alternative path for included files
+ -to-stdout write compiled file to stdout instead of file
+
+ Language options:
+
+ -feature SYMBOL register feature identifier
+ -no-feature SYMBOL disable built-in feature identifier
+
+ Syntax related options:
+
+ -case-insensitive don't preserve case of read symbols
+ -keyword-style STYLE allow alternative keyword syntax
+ (prefix, suffix or none)
+ -no-parentheses-synonyms disables list delimiter synonyms
+ -no-symbol-escape disables support for escaped symbols
+ -r5rs-syntax disables the Chicken extensions to
+ R5RS syntax
+ -compile-syntax macros are made available at run-time
+ -emit-import-library MODULE write compile-time module information into
+ separate file
+ -emit-all-import-libraries emit import-libraries for all defined modules
+ -no-module-registration do not generate module registration code
+ -no-compiler-syntax disable expansion of compiler-macros
+ -module wrap compiled code into implicit module
+
+ Translation options:
+
+ -explicit-use do not use units 'library' and 'eval' by
+ default
+ -check-syntax stop compilation after macro-expansion
+ -analyze-only stop compilation after first analysis pass
+
+ Debugging options:
+
+ -no-warnings disable warnings
+ -debug-level NUMBER set level of available debugging information
+ -no-trace disable tracing information
+ -profile executable emits profiling information
+ -profile-name FILENAME name of the generated profile information file
+ -accumulate-profile executable emits profiling information in
+ append mode
+ -no-lambda-info omit additional procedure-information
+ -scrutinize perform local flow analysis for static checks
+ -picky perform more static checks (implies -scrutinize)
+ -types FILENAME load additional type database
+
+ Optimization options:
+
+ -optimize-level NUMBER enable certain sets of optimization options
+ -optimize-leaf-routines enable leaf routine optimization
+ -lambda-lift enable lambda-lifting
+ -no-usual-integrations standard procedures may be redefined
+ -unsafe disable all safety checks
+ -local assume globals are only modified in current
+ file
+ -block enable block-compilation
+ -disable-interrupts disable interrupts in compiled code
+ -fixnum-arithmetic assume all numbers are fixnums
+ -benchmark-mode equivalent to 'block -optimize-level 4
+ -debug-level 0 -fixnum-arithmetic -lambda-lift
+ -inline -disable-interrupts'
+ -disable-stack-overflow-checks disables detection of stack-overflows
+ -inline enable inlining
+ -inline-limit LIMIT set inlining threshold
+ -inline-global enable cross-module inlining
+ -specialize perform type-based specialization of primitive calls
+ -unboxing use unboxed temporaries if possible
+ -emit-inline-file FILENAME generate file with globally inlinable
+ procedures (implies -inline -local)
+ -consult-inline-file FILENAME explicitly load inline file
+ -no-argc-checks disable argument count checks
+ -no-bound-checks disable bound variable checks
+ -no-procedure-checks disable procedure call checks
+ -no-procedure-checks-for-usual-bindings
+ disable procedure call checks only for usual
+ bindings
+ -no-procedure-checks-for-toplevel-bindings
+ disable procedure call checks for toplevel
+ bindings
+
+ Configuration options:
+
+ -unit NAME compile file as a library unit
+ -uses NAME declare library unit as used.
+ -heap-size NUMBER specifies heap-size of compiled executable
+ -heap-initial-size NUMBER specifies heap-size at startup time
+ -heap-growth PERCENTAGE specifies growth-rate of expanding heap
+ -heap-shrinkage PERCENTAGE specifies shrink-rate of contracting heap
+ -nursery NUMBER -stack-size NUMBER
+ specifies nursery size of compiled executable
+ -extend FILENAME load file before compilation commences
+ -prelude EXPRESSION add expression to front of source file
+ -postlude EXPRESSION add expression to end of source file
+ -prologue FILENAME include file before main source file
+ -epilogue FILENAME include file after main source file
+ -dynamic compile as dynamically loadable code
+ -require-extension NAME require and import extension NAME
+
+ Obscure options:
+
+ -debug MODES display debugging output for the given modes
+ -raw do not generate implicit init- and exit code
+ -emit-external-prototypes-first
+ emit prototypes for callbacks before foreign
+ declarations
+ -ignore-repository do not refer to repository for extensions
+ -setup-mode prefer the current directory when locating extensions
+
+EOF
+) )
Trap