>From b98203c1f2ef4e5e5cf8e9658fd1c70031abf1a1 Mon Sep 17 00:00:00 2001
From: Peter Bex
Date: Sun, 17 Aug 2014 17:39:58 +0200
Subject: [PATCH 15/19] compiler-modules: Reduce coupling between components
by passing around more options.
The options in question are used in a lot of places, but it is only
necessary to set them in batch-driver, and export them from compiler.
When invoking a subcomponent of the compiler, batch-driver can pass
the various options to that component. This is inspired by the fact
that the scrutinizer's "scrutinize" procedure already received
"specialize" as an argument. This corresponds to a global
"enable-specialization" option defined in compiler. This idea has
been taken further, with the following options:
- enable-specialization (wasn't passed to load-type-database)
- block-compilation
- inline-locally
- inline-substitutions-enabled
- inline-max-size
- strict-variable-types
---
batch-driver.scm | 24 ++++---
compiler-namespace.scm | 7 +--
compiler.scm | 35 ++++++-----
optimizer.scm | 162 +++++++++++++++++++++++++-----------------------
scrutinizer.scm | 32 +++++-----
support.scm | 13 ++--
6 files changed, 142 insertions(+), 131 deletions(-)
diff --git a/batch-driver.scm b/batch-driver.scm
index e951e3c..fd52bb9 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -557,17 +557,20 @@
(when (or do-scrutinize enable-specialization)
;;XXX hardcoded database file name
(unless (memq 'ignore-repository options)
- (unless (load-type-database "types.db")
+ (unless (load-type-database "types.db"
+ enable-specialization)
(quit-compiling
"default type-database `types.db' not found")))
(for-each
(lambda (fn)
- (or (load-type-database fn #f)
+ (or (load-type-database fn enable-specialization #f)
(quit-compiling "type-database `~a' not found" fn)))
(collect-options 'types))
(for-each
(lambda (id)
- (load-type-database (make-pathname #f (symbol->string id) "types")))
+ (load-type-database
+ (make-pathname #f (symbol->string id) "types")
+ enable-specialization))
mreq)
(begin-time)
(set! first-analysis #f)
@@ -576,7 +579,9 @@
(end-time "pre-analysis (scrutiny)")
(begin-time)
(debugging 'p "performing scrutiny")
- (scrutinize node0 db do-scrutinize enable-specialization)
+ (scrutinize node0 db
+ do-scrutinize enable-specialization
+ strict-variable-types block-compilation)
(end-time "scrutiny")
(when enable-specialization
(print-node "specialization" '|P| node0))
@@ -615,7 +620,7 @@
;; do this here, because we must make sure we have a db
(when type-output-file
(dribble "generating type file `~a' ..." type-output-file)
- (emit-type-file filename type-output-file db)))
+ (emit-type-file filename type-output-file db block-compilation)))
(set! first-analysis #f)
(end-time "analysis")
(print-db "analysis" '|4| db i)
@@ -630,7 +635,10 @@
(receive (node2 progress-flag)
(if l/d
(determine-loop-and-dispatch node2 db)
- (perform-high-level-optimizations node2 db))
+ (perform-high-level-optimizations
+ node2 db block-compilation
+ inline-locally inline-max-size
+ inline-substitutions-enabled))
(end-time "optimization")
(print-node "optimized-iteration" '|5| node2)
(cond (progress-flag
@@ -671,7 +679,9 @@
(when (and inline-output-file insert-timer-checks)
(let ((f inline-output-file))
(dribble "generating global inline file `~a' ..." f)
- (emit-global-inline-file filename f db) ) )
+ (emit-global-inline-file
+ filename f db block-compilation
+ inline-max-size) ) )
(begin-time)
;; Closure conversion
(set! node2 (perform-closure-conversion node2 db))
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index a07df6b..de60046 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -26,10 +26,8 @@
(private
compiler
- block-compilation
default-extended-bindings
default-standard-bindings
- enable-specialization
extended-bindings
foldable-bindings
foreign-callback-stubs
@@ -39,11 +37,8 @@
foreign-callback-stub-qualifiers
foreign-callback-stub-return-type
foreign-type-table
- inline-locally
- inline-max-size
- inline-substitutions-enabled
+ around more options.
internal-bindings
number-type
standard-bindings
- strict-variable-types
unsafe)
diff --git a/compiler.scm b/compiler.scm
index 74ad41a..9b6cf35 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -287,7 +287,8 @@
emit-closure-info emit-profile enable-inline-files explicit-use-flag
first-analysis no-bound-checks enable-module-registration
optimize-leaf-routines standalone-executable undefine-shadowed-macros
- verbose-mode local-definitions
+ verbose-mode local-definitions enable-specialization block-compilation
+ inline-locally inline-substitutions-enabled strict-variable-types
;; These are set by the (batch) driver, and read by the (c) backend
disable-stack-overflow-checking emit-trace-info external-protos-first
@@ -295,7 +296,7 @@
no-global-procedure-checks no-procedure-checks
;; Other, non-boolean, flags set by (batch) driver
- profiled-procedures import-libraries
+ profiled-procedures import-libraries inline-max-size
;; non-booleans set by the (batch) driver, and read by the (c) backend
target-heap-size target-stack-size unit-name used-units
@@ -2046,7 +2047,7 @@
(eq? var (first (node-parameters val))) ) )
((or (memq var env)
(variable-mark var '##compiler#constant)
- (not (variable-visible? var)))
+ (not (variable-visible? var block-compilation)))
(let ((props (db-get-all db var 'unknown 'value))
(home (db-get db var 'home)) )
(unless (assq 'unknown props)
@@ -2137,7 +2138,7 @@
global
(null? references)
(not (variable-mark sym '##compiler#unused))
- (not (variable-visible? sym))
+ (not (variable-visible? sym block-compilation))
(not (variable-mark sym '##compiler#constant)) )
(##sys#notice
(sprintf "global variable `~S' is only locally visible and never used"
@@ -2157,7 +2158,8 @@
(or (not (second valparams))
(every
(lambda (v) (db-get db v 'global))
- (nth-value 0 (scan-free-variables value)) ) ) )
+ (nth-value 0 (scan-free-variables
+ value block-compilation)) ) ) )
(if (and (= 1 nreferences) (= 1 ncall-sites))
(quick-put! plist 'contractable #t)
(quick-put! plist 'inlinable #t) ) ) ) )
@@ -2165,7 +2167,8 @@
;; Make 'inlinable, if it is declared local and has a value
(let ((valparams (node-parameters local-value)))
(when (eq? '##core#lambda (node-class local-value))
- (let-values (((vars hvars) (scan-free-variables local-value)))
+ (let-values (((vars hvars) (scan-free-variables
+ local-value block-compilation)))
(when (and (db-get db sym 'global)
(pair? hvars))
(quick-put! plist 'hidden-refs #t))
@@ -2261,7 +2264,8 @@
(= 1 (length nrefs))
(not assigned)
(not (db-get db name 'assigned))
- (or (not (variable-visible? name))
+ (or (not (variable-visible?
+ name block-compilation))
(not (db-get db name 'global))) ) ))
(quick-put! plist 'replacable name)
(db-put! db name 'replacing #t) ) ) ) )
@@ -2622,7 +2626,7 @@
(variable-mark var '##compiler#always-bound)
(intrinsic? var))]
[blockvar (and (db-get db var 'assigned)
- (not (variable-visible? var)))])
+ (not (variable-visible? var block-compilation)))])
(when blockvar (set! fastrefs (add1 fastrefs)))
(make-node
'##core#global
@@ -2771,18 +2775,19 @@
(walk (second subs) e e-count here boxes) ) ) ) )
((set!)
- (let ([var (first params)]
- [val (first subs)] )
+ (let ((var (first params))
+ (val (first subs)) )
(cond ((posq var e)
=> (lambda (i)
(make-node '##core#setlocal
(list (fx- e-count (fx+ i 1)))
(list (walk val e e-count here boxes)) ) ) )
(else
- (let* ([cval (node-class val)]
- [blockvar (not (variable-visible? var))]
- [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
- (eq? '##core#undefined cval) ) ] )
+ (let* ((cval (node-class val))
+ (blockvar (not (variable-visible?
+ var block-compilation)))
+ (immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
+ (eq? '##core#undefined cval) ) ) )
(when blockvar (set! fastsets (add1 fastsets)))
(make-node
(if immf '##core#setglobal_i '##core#setglobal)
@@ -2794,7 +2799,7 @@
(list (walk (car subs) e e-count here boxes)) ) ) ) ) ) )
((##core#call)
- (let ([len (length (cdr subs))])
+ (let ((len (length (cdr subs))))
(set! signatures (lset-adjoin = signatures len))
(when (and (>= (length params) 3) (eq? here (third params)))
(set! looping (add1 looping)) )
diff --git a/optimizer.scm b/optimizer.scm
index 7f8baae..bc68df0 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -149,7 +149,8 @@
(define simplified-ops '())
(define broken-constant-nodes '())
-(define (perform-high-level-optimizations node db)
+(define (perform-high-level-optimizations
+ node db block-compilation may-inline inline-limit may-rewrite)
(let ((removed-lets 0)
(removed-ifs 0)
(replaced-vars 0)
@@ -166,14 +167,15 @@
(for-each (cut set-cdr! <> #f) gae))
(define (simplify n)
- (or (and-let* ([entry (##sys#hash-table-ref simplifications (node-class n))])
+ (or (and-let* ((entry (##sys#hash-table-ref
+ simplifications (node-class n))))
(any (lambda (s)
- (and-let* ([vars (second s)]
- [env (match-node n (first s) vars)]
- [n2 (apply (third s) db
- (map (lambda (v) (cdr (assq v env))) vars) ) ] )
- (let* ([name (caar s)]
- [counter (assq name simplified-classes)] )
+ (and-let* ((vars (second s))
+ (env (match-node n (first s) vars))
+ (n2 (apply (third s) db may-rewrite
+ (map (lambda (v) (cdr (assq v env))) vars) ) ) )
+ (let* ((name (caar s))
+ (counter (assq name simplified-classes)) )
(if counter
(set-cdr! counter (add1 (cdr counter)))
(set! simplified-classes (alist-cons name 1 simplified-classes)) )
@@ -379,14 +381,14 @@
(lambda (vars argc rest)
(let ((ifid (first lparams))
(external (node? (variable-mark var '##compiler#inline-global))))
- (cond ((and inline-locally
+ (cond ((and may-inline
(test var 'inlinable)
(not (test ifid 'inline-target)) ; inlinable procedure has changed
(not (test ifid 'explicit-rest))
(case (variable-mark var '##compiler#inline)
((no) #f)
(else
- (or external (< (fourth lparams) inline-max-size)))))
+ (or external (< (fourth lparams) inline-limit)))))
(debugging
'i
(if external
@@ -498,7 +500,7 @@
(touch)
(make-node '##core#undefined '() '()) )
((and (or (not (test var 'global))
- (not (variable-visible? var)))
+ (not (variable-visible? var block-compilation)))
(not (test var 'inline-transient))
(not (test var 'references))
(not (expression-has-side-effects? (first subs) db)) )
@@ -627,10 +629,11 @@
;; ( ...) -> ( ...)
`((##core#call d (##core#variable (a)) b . c)
(a b c d)
- ,(lambda (db a b c d)
+ ,(lambda (db may-rewrite a b c d)
(let loop ((entries (or (##sys#hash-table-ref substitution-table a) '())))
(cond ((null? entries) #f)
- ((simplify-named-call db d a b (caar entries) (cdar entries) c)
+ ((simplify-named-call db may-rewrite d a b
+ (caar entries) (cdar entries) c)
=> (lambda (r)
(let ((as (assq a simplified-ops)))
(if as
@@ -658,7 +661,7 @@
body2
rest) ) ) )
(var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
- ,(lambda (db var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
+ ,(lambda (db may-rewrite var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
(and (equal? op (eq-inline-operator))
(immediate? const1)
(immediate? const2)
@@ -685,7 +688,7 @@
body
(##core#switch (n) (##core#variable (var0)) . clauses) ) )
(var op var0 const d body n clauses)
- ,(lambda (db var op var0 const d body n clauses)
+ ,(lambda (db may-rewrite var op var0 const d body n clauses)
(and (equal? op (eq-inline-operator))
(immediate? const)
(= 1 (length (db-get-list db var 'references)))
@@ -709,7 +712,7 @@
`((let (var1) (##core#undefined ())
more)
(var1 more)
- ,(lambda (db var1 more)
+ ,(lambda (db may-rewrite var1 more)
(let loop1 ((vars (list var1))
(body more) )
(let ((c (node-class body))
@@ -759,7 +762,7 @@
`((let (var1) (##core#variable (var2))
(##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
(var1 var2 p more)
- ,(lambda (db var1 var2 p more)
+ ,(lambda (db may-rewrite var1 var2 p more)
(and (= 1 (length (db-get-list db var1 'references)))
(make-node
'##core#call p
@@ -776,7 +779,7 @@
x
y) )
(var op args d x y)
- ,(lambda (db var op args d x y)
+ ,(lambda (db may-rewrite var op args d x y)
(and (not (equal? op (eq-inline-operator)))
(= 1 (length (db-get-list db var 'references)))
(make-node
@@ -797,8 +800,8 @@
(##core#call d2 (##core#variable (var)) y)
(##core#call d3 (##core#variable (var)) z) )
(d1 d2 d3 x y z var)
- ,(lambda (db d1 d2 d3 x y z var)
- (and inline-substitutions-enabled
+ ,(lambda (db may-rewrite d1 d2 d3 x y z var)
+ (and may-rewrite
(make-node
'##core#call d2
(list (varnode var)
@@ -812,7 +815,7 @@
y
z)
(d1 op x clist y z)
- ,(lambda (db d1 op x clist y z)
+ ,(lambda (db may-rewrite d1 op x clist y z)
(and-let* ([opa (assoc op (membership-test-operators))]
[(proper-list? clist)]
[(< (length clist) (membership-unfold-limit))] )
@@ -934,7 +937,8 @@
(let ((old (or (##sys#hash-table-ref substitution-table name) '())))
(##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )
-(define (simplify-named-call db params name cont class classargs callargs)
+(define (simplify-named-call db may-rewrite params name cont
+ class classargs callargs)
(define (test sym prop) (db-get db sym prop))
(define (defarg x)
(cond ((symbol? x) (varnode x))
@@ -954,7 +958,7 @@
(eq? '##core#variable (node-class arg2))
(equal? (node-parameters arg1) (node-parameters arg2))
(make-node '##core#call (list #t) (list cont (qnode #t))) ) ) )
- (and inline-substitutions-enabled
+ (and may-rewrite
(make-node
'##core#call (list #t)
(list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
@@ -962,7 +966,7 @@
;; ( ...) -> (##core#inline ...)
((2) ; classargs = ( )
;; - by be 'specialized (see rule #16 below)
- (and inline-substitutions-enabled
+ (and may-rewrite
(= (length callargs) (first classargs))
(intrinsic? name)
(or (third classargs) unsafe)
@@ -976,7 +980,7 @@
;; ( ...) ->
((3) ; classargs = ( )
;; - may be #f
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(or (not (second classargs)) (= (length callargs) (second classargs)))
(fold-right
@@ -987,7 +991,7 @@
;; ( a b) -> ( a (quote ) b)
((4) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
unsafe
(= 2 (length callargs))
(intrinsic? name)
@@ -1001,7 +1005,7 @@
;; ( a) -> (##core#inline a (quote ))
((5) ; classargs = ( )
;; - may be #f
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(= 1 (length callargs))
(let ((ntype (third classargs)))
@@ -1015,7 +1019,7 @@
;; ( a) -> (##core#inline (##core#inline a))
((6) ; classargs = ( )
(and (or (third classargs) unsafe)
- inline-substitutions-enabled
+ may-rewrite
(= 1 (length callargs))
(intrinsic? name)
(make-node '##core#call (list #t)
@@ -1027,7 +1031,7 @@
;; ( ...) -> (##core#inline ... (quote ))
((7) ; classargs = ( )
(and (or (fourth classargs) unsafe)
- inline-substitutions-enabled
+ may-rewrite
(= (length callargs) (first classargs))
(intrinsic? name)
(make-node '##core#call (list #t)
@@ -1038,32 +1042,32 @@
;; ( ...) -> < with , and >>
((8) ; classargs = ( ...)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
((first classargs) db classargs cont callargs) ) )
;; ( ...) -> (##core#inline "C_and" (##core#inline ) ...)
;; ( []) -> (quote #t)
((9) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(if (< (length callargs) 2)
(make-node '##core#call (list #t) (list cont (qnode #t)))
(and (or (and unsafe (not (eq? number-type 'generic)))
(and (eq? number-type 'fixnum) (third classargs))
(and (eq? number-type 'flonum) (fourth classargs)) )
- (let* ([names (map (lambda (z) (gensym)) callargs)]
- [vars (map varnode names)] )
+ (let* ((names (map (lambda (z) (gensym)) callargs))
+ (vars (map varnode names)) )
(fold-right
(lambda (x n y) (make-node 'let (list n) (list x y)))
(make-node
'##core#call (list #t)
(list
cont
- (let ([op (list
+ (let ((op (list
(if (eq? number-type 'fixnum)
(first classargs)
- (second classargs) ) ) ] )
+ (second classargs) ) ) ) )
(fold-boolean
(lambda (x y) (make-node '##core#inline op (list x y)))
vars) ) ) )
@@ -1071,7 +1075,7 @@
;; ( a [b]) -> ( a (quote ) b)
((10) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(or (fourth classargs) unsafe)
(intrinsic? name)
(let ((n (length callargs)))
@@ -1088,10 +1092,10 @@
;; ( ...) -> ( ...)
((11) ; classargs = ( )
;; may be #f.
- (and inline-substitutions-enabled
+ (and may-rewrite
(or (third classargs) unsafe)
(intrinsic? name)
- (let ([argc (first classargs)])
+ (let ((argc (first classargs)))
(and (or (not argc)
(= (length callargs) (first classargs)) )
(make-node '##core#call (list #t (second classargs))
@@ -1102,7 +1106,7 @@
;; ( a) -> a
;; ( ...) -> ( ...)
((12) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(or (second classargs) unsafe)
(let ((n (length callargs)))
@@ -1115,7 +1119,7 @@
;; ( ...) -> ((##core#proc ) ...)
((13) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(or (second classargs) unsafe)
(let ((pname (first classargs)))
@@ -1125,7 +1129,7 @@
;; ( ...) -> (##core#inline / ...)
((14) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(= (second classargs) (length callargs))
(intrinsic? name)
(eq? number-type (first classargs))
@@ -1141,7 +1145,7 @@
;; ( ) -> ( ) - if numtype1
;; | - if numtype2
((15) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(= 1 (length callargs))
(or unsafe (fourth classargs))
(intrinsic? name)
@@ -1166,7 +1170,7 @@
(safe (third classargs))
(w (fourth classargs))
(counted (and (pair? (cddddr classargs)) (fifth classargs))))
- (and inline-substitutions-enabled
+ (and may-rewrite
(or (not argc) (= rargc argc))
(intrinsic? name)
(or unsafe safe)
@@ -1178,14 +1182,14 @@
(list (if (and counted (positive? rargc) (<= rargc 8))
(conc (second classargs) rargc)
(second classargs) )
- (cond [(eq? #t w) (add1 rargc)]
- [(pair? w) (* rargc (car w))]
- [else w] ) )
+ (cond ((eq? #t w) (add1 rargc))
+ ((pair? w) (* rargc (car w)))
+ (else w) ) )
callargs) ) ) ) ) )
;; ( ...) -> (##core#inline / ...)
((17) ; classargs = ( [])
- (and inline-substitutions-enabled
+ (and may-rewrite
(= (length callargs) (first classargs))
(intrinsic? name)
(make-node
@@ -1199,7 +1203,7 @@
;; () -> (quote )
((18) ; classargs = ()
- (and inline-substitutions-enabled
+ (and may-rewrite
(null? callargs)
(intrinsic? name)
(make-node '##core#call (list #t) (list cont (qnode (first classargs))) ) ) )
@@ -1210,20 +1214,20 @@
;; ( ...) -> (##core#inline (##core#inline ...)) [fixnum-mode + unsafe]
;; - Remove "" from arguments.
((19) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
- (let* ([id (first classargs)]
- [fixop (if unsafe (third classargs) (second classargs))]
- [callargs
+ (let* ((id (first classargs))
+ (fixop (if unsafe (third classargs) (second classargs)))
+ (callargs
(remove
(lambda (x)
(and (eq? 'quote (node-class x))
(eq? id (first (node-parameters x))) ) )
- callargs) ] )
- (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode id)))]
- [(null? (cdr callargs))
- (make-node '##core#call (list #t) (list cont (first callargs))) ]
- [(or (fourth classargs) (eq? number-type 'fixnum))
+ callargs) ) )
+ (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode id))))
+ ((null? (cdr callargs))
+ (make-node '##core#call (list #t) (list cont (first callargs))) )
+ ((or (fourth classargs) (eq? number-type 'fixnum))
(make-node
'##core#call (list #t)
(list
@@ -1231,14 +1235,14 @@
(fold-inner
(lambda (x y)
(make-node '##core#inline (list fixop) (list x y)) )
- callargs) ) ) ]
- [else #f] ) ) ) )
+ callargs) ) ) )
+ (else #f) ) ) ) )
;; ( ...) -> (##core#inline ... (quote ) )
((20) ; classargs = ( )
- (let ([n (length callargs)])
+ (let ((n (length callargs)))
(and (or (fourth classargs) unsafe)
- inline-substitutions-enabled
+ may-rewrite
(= n (first classargs))
(intrinsic? name)
(make-node
@@ -1246,7 +1250,7 @@
(list cont
(make-node
'##core#inline (list (second classargs))
- (let-values ([(head tail) (split-at callargs (sub1 n))])
+ (let-values (((head tail) (split-at callargs (sub1 n))))
(append head
(list (qnode (third classargs)))
tail) ) ) ) ) ) ) )
@@ -1257,22 +1261,22 @@
;; ( ...) -> (##core#inline <[u]fixop> (##core#inline <[u]fixop> ...)) [fixnum-mode (perhaps unsafe)]
;; - Remove "" from arguments.
((21) ; classargs = ( )
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
- (let* ([id (first classargs)]
- [words (fifth classargs)]
- [genop (fourth classargs)]
- [fixop (if unsafe (third classargs) (second classargs))]
- [callargs
+ (let* ((id (first classargs))
+ (words (fifth classargs))
+ (genop (fourth classargs))
+ (fixop (if unsafe (third classargs) (second classargs)))
+ (callargs
(remove
(lambda (x)
(and (eq? 'quote (node-class x))
(eq? id (first (node-parameters x))) ) )
- callargs) ] )
- (cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode id)))]
- [(null? (cdr callargs))
- (make-node '##core#call (list #t) (list cont (first callargs))) ]
- [else
+ callargs) ) )
+ (cond ((null? callargs) (make-node '##core#call (list #t) (list cont (qnode id))))
+ ((null? (cdr callargs))
+ (make-node '##core#call (list #t) (list cont (first callargs))) )
+ (else
(make-node
'##core#call (list #t)
(list
@@ -1282,15 +1286,15 @@
(if (eq? number-type 'fixnum)
(make-node '##core#inline (list fixop) (list x y))
(make-node '##core#inline_allocate (list genop words) (list x y)) ) )
- callargs) ) ) ] ) ) ) )
+ callargs) ) ) ) ) ) ) )
;; ( ...) -> (##core#inline_allocate ( ) ...)
;; ( ...) -> (##core#inline ...) [fixnum mode]
((22) ; classargs = ( )
- (let ([argc (first classargs)]
- [rargc (length callargs)]
- [w (fourth classargs)] )
- (and inline-substitutions-enabled
+ (let ((argc (first classargs))
+ (rargc (length callargs))
+ (w (fourth classargs)) )
+ (and may-rewrite
(= rargc argc)
(intrinsic? name)
(or (third classargs) unsafe)
@@ -1312,7 +1316,7 @@
;; - default args in classargs should be either symbol or (optionally)
;; quoted literal
((23) ; classargs = ( | ...)
- (and inline-substitutions-enabled
+ (and may-rewrite
(intrinsic? name)
(let ([argc (first classargs)])
(and (>= (length callargs) (first classargs))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 0595a75..3dc03f5 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -126,7 +126,7 @@
(first (node-parameters n))) ; assumes ##core#the/result node
-(define (scrutinize node db complain specialize)
+(define (scrutinize node db complain specialize strict block-compilation)
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
(aliased '())
(noreturn #f)
@@ -190,7 +190,7 @@
(define (variable-result id e loc flow)
(cond ((blist-type id flow) => list)
- ((and (not strict-variable-types)
+ ((and (not strict)
(db-get db id 'assigned)
(not (variable-mark id '##compiler#declared-type)))
'(*))
@@ -445,8 +445,7 @@
(loop (cdr a))))))
(define (initial-argument-types dest vars argc)
- (if (and dest
- strict-variable-types
+ (if (and dest strict
(variable-mark dest '##compiler#declared-type))
(let* ((ptype (variable-mark dest '##compiler#type))
(typeenv (type-typeenv ptype)))
@@ -624,7 +623,7 @@
(and (pair? type)
(eq? (car type) 'deprecated))))
(not (match-types type rt typeenv)))
- ((if strict-variable-types report-error report)
+ ((if strict report-error report)
loc
(sprintf
"assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
@@ -637,7 +636,7 @@
(and-let* ((val (or (db-get db var 'value)
(db-get db var 'local-value))))
(when (and (eq? val (first subs))
- (or (not (variable-visible? var))
+ (or (not (variable-visible? var block-compilation))
(not (eq? (variable-mark var '##compiler#inline)
'no))))
(let ((rtlst (list (cons #f (tree-copy rt)))))
@@ -651,7 +650,7 @@
(mark-variable var '##compiler#type rt))))))
(when b
(cond ((eq? 'undefined (cdr b)) (set-cdr! b rt))
- #;(strict-variable-types
+ #;(strict
(let ((ot (or (blist-type var flow) (cdr b))))
;;XXX compiler-syntax for "map" will introduce
;; assignments that trigger this warning, so this
@@ -664,8 +663,7 @@
var ot rt)
#t)))))
;; don't use "add-to-blist" since the current operation does not affect aliases
- (let ((t (if (or strict-variable-types
- (not (db-get db var 'captured)))
+ (let ((t (if (or strict (not (db-get db var 'captured)))
rt
'*))
(fl (car flow)))
@@ -711,7 +709,7 @@
(let-values (((r specialized?)
(call-result n args e loc params typeenv)))
(define (smash)
- (when (and (not strict-variable-types)
+ (when (and (not strict)
(or (not pn)
(and
(not (variable-mark pn '##compiler#pure))
@@ -810,7 +808,7 @@
(length rt))))
(when (and (second params)
(not (type<=? t (first rt))))
- ((if strict-variable-types report-error report-notice)
+ ((if strict report-error report-notice)
loc
(sprintf
"expression returns a result of type `~a', but is declared to return `~a', which is not a subtype"
@@ -1811,13 +1809,11 @@
;;; type-db processing
-(define (load-type-database name #!optional (path (repository-path)))
+(define (load-type-database name specialize #!optional (path (repository-path)))
(define (clean! name)
- (when enable-specialization
- (mark-variable name '##compiler#clean #t)))
+ (when specialize (mark-variable name '##compiler#clean #t)))
(define (pure! name)
- (when enable-specialization
- (mark-variable name '##compiler#pure #t)))
+ (when specialize (mark-variable name '##compiler#pure #t)))
(and-let* ((dbfile (file-exists? (make-pathname path name))))
(debugging 'p (sprintf "loading type database `~a' ...~%" dbfile))
(fluid-let ((scrutiny-debug #f))
@@ -1871,14 +1867,14 @@
(read-file dbfile))
#t)))
-(define (emit-type-file source-file type-file db)
+(define (emit-type-file source-file type-file db block-compilation)
(with-output-to-file type-file
(lambda ()
(print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
source-file "\n")
(##sys#hash-table-for-each
(lambda (sym plist)
- (when (and (variable-visible? sym)
+ (when (and (variable-visible? sym block-compilation)
(variable-mark sym '##compiler#declared-type))
(let ((specs (or (variable-mark sym '##compiler#specializations) '()))
(type (variable-mark sym '##compiler#type))
diff --git a/support.scm b/support.scm
index 215ee3c..4f7ab90 100644
--- a/support.scm
+++ b/support.scm
@@ -828,12 +828,13 @@
(make-node (car x) (cadr x) (map walk (cddr x)))))
;; Only used in batch-driver.scm
-(define (emit-global-inline-file source-file inline-file db)
+(define (emit-global-inline-file source-file inline-file db
+ block-compilation inline-limit)
(let ((lst '())
(out '()))
(##sys#hash-table-for-each
(lambda (sym plist)
- (when (variable-visible? sym)
+ (when (variable-visible? sym block-compilation)
(and-let* ((val (assq 'local-value plist))
((not (node? (variable-mark sym '##compiler#inline-global))))
((let ((val (assq 'value plist)))
@@ -846,7 +847,7 @@
((yes) #t)
((no) #f)
(else
- (< (fourth lparams) inline-max-size) ) ) ) )
+ (< (fourth lparams) inline-limit) ) ) ) )
(set! lst (cons sym lst))
(set! out (cons (list sym (node->sexpr (cdr val))) out)))))
db)
@@ -1328,7 +1329,7 @@
;;; Scan expression-node for free variables (that are not in env):
-(define (scan-free-variables node)
+(define (scan-free-variables node block-compilation)
(let ((vars '())
(hvars '()))
@@ -1341,7 +1342,7 @@
(let ((var (first params)))
(unless (memq var e)
(set! vars (lset-adjoin eq? vars var))
- (unless (variable-visible? var)
+ (unless (variable-visible? var block-compilation)
(set! hvars (lset-adjoin eq? hvars var))))))
((set!)
(let ((var (first params)))
@@ -1584,7 +1585,7 @@
(define (export-variable sym) ; Used only in compiler.scm
(mark-variable sym '##compiler#visibility 'exported))
-(define (variable-visible? sym)
+(define (variable-visible? sym block-compilation)
(let ((p (##sys#get sym '##compiler#visibility)))
(case p
((hidden) #f)
--
1.7.10.4