>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