Changeset 12148 in project
- Timestamp:
- 10/13/08 12:07:51 (12 years ago)
- Location:
- chicken/branches/cmi
- Files:
-
- 14 edited
-
Makefile.linux (modified) (1 diff)
-
TODO (modified) (5 diffs)
-
batch-driver.scm (modified) (6 diffs)
-
c-backend.scm (modified) (1 diff)
-
c-platform.scm (modified) (6 diffs)
-
chicken.scm (modified) (3 diffs)
-
compiler.scm (modified) (31 diffs)
-
csc.scm (modified) (2 diffs)
-
defaults.make (modified) (1 diff)
-
manual/Declarations (modified) (1 diff)
-
manual/Using the compiler (modified) (3 diffs)
-
optimizer.scm (modified) (30 diffs)
-
support.scm (modified) (10 diffs)
-
tweaks.scm (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
chicken/branches/cmi/Makefile.linux
r12021 r12148 44 44 endif 45 45 LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared 46 LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$( LIBDIR)47 LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$( LIBDIR)46 LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH) 47 LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH) 48 48 LIBRARIES = -lm -ldl 49 49 NEEDS_RELINKING = yes -
chicken/branches/cmi/TODO
r12134 r12148 7 7 * bugs 8 8 ** compiler 9 *** lambda-lifting breaks in ##sys#read (r-spaces), reported by Joerg Wittenberger10 in rev. 1210311 9 *** pre-optimization 12 10 **** changes call-sites and makes them invalid for later pre-optimization … … 38 36 what MacScheme called "benchmark-mode" (assume self-calls are recursion) 39 37 *** needs declaration or option, >= -O2 38 *** local mode is probably half of it 40 39 ** cross-module inlining 41 *** emit <sourcefile>.inline file with "-inline-global" (?) 42 *** "-inline-global" slurps *.inline files include-path (?) 43 *** would inline in other compilation units, but not in current (sort of confusing) 40 *** emit <sourcefile>.inline file with "-inline-global" 41 *** "-inline-global" slurps *.inline files include-path 44 42 ** remove "custom-declare" + stuff? 45 43 ** when inlining, consing arg-list with "list" may make get-keyword possible foldable 46 ** using plists instead of symbol lists might speed up things 47 standard-bindings48 extended-bindings 49 inline-list 50 not-inline-list 44 45 * benchmarks 46 ** get rid of cscbench, hack together something simpler 47 ** simplify comparing two builds relative to each other 48 ** simplify passing extra options 51 49 52 50 * tests … … 55 53 *** fully compiled ec-tests 56 54 57 * module issues55 * modules 58 56 ** code-duplication in compiler and evaluator for ##core#module 59 57 ** "scheme" module does not include some special forms ("define-syntax", etc.) … … 63 61 ** curried define performs expansion in empty se - problem? 64 62 (as comment in expand.scm indicated (##sys#register-export)) 63 ** checks 64 *** reimport of imported id 65 *** unused defs? 65 66 66 67 * setup/install … … 87 88 ** fluidly keep track of expanded forms (extend meaning of culprit) 88 89 to pprint pruned expr on error 89 90 * modules91 ** checks92 *** reimport of imported id93 *** unused defs? -
chicken/branches/cmi/batch-driver.scm
r12134 r12148 46 46 target-initial-heap-size postponed-initforms 47 47 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables 48 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants48 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 49 49 broken-constant-nodes inline-substitutions-enabled 50 50 emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name … … 65 65 default-declarations units-used-by-default words-per-flonum default-debugging-declarations 66 66 default-profiling-declarations default-optimization-passes 67 inline-max-size file-requirements import-libraries 67 inline-max-size file-requirements import-libraries inline-global 68 68 foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators 69 69 membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument … … 86 86 (define user-pass-2 (make-parameter #f)) 87 87 (define user-post-analysis-pass (make-parameter #f)) 88 (define user-post-optimization-pass (make-parameter #f))89 88 90 89 … … 239 238 (when (memq 'local options) 240 239 (set! local-definitions #t)) 240 (when (memq 'inline-global options) 241 (set! inline-global #t)) 241 242 (set! disabled-warnings (map string->symbol (collect-options 'disable-warning))) 242 243 (when (memq 'no-warnings options) … … 364 365 (let ([acc (eq? 'accumulate-profile (car profile))]) 365 366 (set! emit-profile #t) 366 (set! profiled-procedures #f)367 367 (set! initforms 368 368 (append … … 580 580 (print-node "optimized" '|7| node2) 581 581 582 (let ((proc (user-post-optimization-pass)))583 (when proc584 (when verbose585 (printf "post-optimization user pass...~%"))586 (begin-time)587 (proc node2 db)588 (end-time "post-optimization user pass")))589 590 582 (begin-time) 591 583 (let ([node3 (perform-closure-conversion node2 db)]) -
chicken/branches/cmi/c-backend.scm
r11905 r12148 44 44 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants 45 45 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 46 mutable-constantsencode-literal46 encode-literal 47 47 broken-constant-nodes inline-substitutions-enabled 48 48 direct-call-ids foreign-type-table first-analysis block-variable-literal? -
chicken/branches/cmi/c-platform.scm
r12134 r12148 34 34 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 35 35 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 36 installation-home debugging 36 installation-home debugging intrinsic? 37 37 dump-nodes unlikely-variables 38 38 unit-name insert-timer-checks used-units inlining … … 41 41 default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size 42 42 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables 43 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants43 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 44 44 broken-constant-nodes inline-substitutions-enabled 45 45 direct-call-ids foreign-type-table first-analysis … … 96 96 (define default-profiling-declarations 97 97 '((##core#declare 98 '(uses profiler)99 '(bound-to-procedure98 (uses profiler) 99 (bound-to-procedure 100 100 ##sys#profile-entry ##sys#profile-exit) ) ) ) 101 101 … … 121 121 lambda-lift compile-syntax tag-pointers accumulate-profile 122 122 disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw 123 emit-external-prototypes-first release local 123 emit-external-prototypes-first release local inline-global 124 124 analyze-only dynamic extension) ) 125 125 … … 429 429 (let ([name (car (node-parameters proc))]) 430 430 (and (memq name '(values ##sys#values)) 431 (or (get db name 'standard-binding) 432 (get db name 'extended-binding) ) 431 (intrinsic? name) 433 432 (make-node 434 433 '##core#call '(#t) … … 1045 1044 (and (eq? '##core#variable (node-class arg)) 1046 1045 (let ((sym (car (node-parameters arg)))) 1047 (and (or (get db sym 'standard-binding) 1048 (get db sym 'extended-binding)) 1046 (and (intrinsic? sym) 1049 1047 (and-let* ((a (assq sym setter-map))) 1050 1048 (make-node -
chicken/branches/cmi/chicken.scm
r11792 r12148 44 44 default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size 45 45 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables 46 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants46 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 47 47 broken-constant-nodes inline-substitutions-enabled compiler-warning 48 48 direct-call-ids foreign-type-table first-analysis … … 124 124 [(3) 125 125 (set! options 126 (cons* 'optimize-leaf-routines 'unsafe options) ) ] 126 (cons* 'optimize-leaf-routines 'local options) ) ] 127 [(4) 128 (set! options 129 (cons* 'optimize-leaf-routines 'local 'unsafe options) ) ] 127 130 [else (compiler-warning 'usage "invalid optimization level ~S - ignored" (car rest))] ) 128 131 (loop (cdr rest)) ) ] … … 139 142 (cons* 'fixnum-arithmetic 'disable-interrupts 'no-trace 'unsafe 140 143 'optimize-leaf-routines 'block 'lambda-lift 'no-lambda-info 144 'local 141 145 options) ) 142 146 (loop rest) ] -
chicken/branches/cmi/compiler.scm
r12134 r12148 41 41 ; ([not] standard-bindings {<name>}) 42 42 ; ([not] usual-integrations {<name>}) 43 ; (local {<name> ...}) 43 44 ; ([number-type] <type>) 44 45 ; (always-bound {<name>}) … … 73 74 ; (unused <symbol> ...) 74 75 ; (uses {<unitname>}) 75 ; ([not] local {<name> ...})76 76 ; 77 77 ; <type> = fixnum | generic 78 79 ; - Global symbol properties: 78 80 ; 81 ; ##compiler#always-bound -> BOOL 82 ; ##compiler#always-bound-to-procedure -> BOOL 83 ; ##compiler#local -> BOOL 84 ; ##compiler#visibility -> #f | 'hidden | 'exported 85 ; ##compiler#constant -> BOOL 86 ; ##compiler#intrinsic -> #f | 'standard | 'extended 87 ; ##compiler#inline -> 'no | 'yes 88 ; ##compiler#profile -> BOOL 89 79 90 ; - Source language: 80 91 ; … … 129 140 ; (define-compiled-syntax (<symbol> . <llist>) <expr> ...) 130 141 ; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>) 131 ; 142 132 143 ; - Core language: 133 144 ; … … 155 166 ; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...] 156 167 ; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>] 157 ; 168 158 169 ; - Closure converted/prepared language: 159 170 ; … … 189 200 ; [##core#return <exp>] 190 201 ; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...] 191 ; 192 ; 202 193 203 ; Analysis database entries: 194 204 ; … … 204 214 ; undefined -> <boolean> If true: variable is unknown yet but can be known later 205 215 ; value -> <node> Variable has a known value 216 ; local-value -> <node> Variable is declared local and has value 206 217 ; potential-value -> <node> Global variable was assigned this value 207 218 ; references -> (<node> ...) Nodes that are accesses of this variable (##core#variable nodes) … … 255 266 256 267 (private compiler 257 compiler-arguments process-command-line explicit-use-flag inline-list not-inline-list268 compiler-arguments process-command-line explicit-use-flag 258 269 default-standard-bindings default-extended-bindings side-effecting-standard-bindings 259 270 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings … … 269 280 default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size 270 281 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables 271 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants282 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 272 283 broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda 273 284 profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda … … 295 306 membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument 296 307 make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag 297 location-pointer-map literal-rewrite-hook 298 local-definitions export-variable variable-mark 308 location-pointer-map literal-rewrite-hook inline-global 309 local-definitions export-variable variable-mark intrinsic? 299 310 undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info 300 311 generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration … … 366 377 (define standalone-executable #t) 367 378 (define local-definitions #f) 379 (define inline-global #f) 368 380 369 381 … … 386 398 (define constant-table #f) 387 399 (define constants-used #f) 388 (define mutable-constants '())389 400 (define broken-constant-nodes '()) 390 401 (define inline-substitutions-enabled #f) … … 412 423 (define csc-control-file #f) 413 424 (define data-declarations '()) 414 (define inline-list '())415 (define not-inline-list '())416 425 (define file-requirements #f) 417 426 (define postponed-initforms '()) … … 669 678 (set-real-names! aliases vars) 670 679 (cond ((or (not dest) 671 ( not (assq dest se))) ;global?680 (assq dest se)) ; not global? 672 681 l) 673 ((and (eq? 'lambda name)682 ((and (eq? 'lambda (or (lookup name se) name)) 674 683 emit-profile 675 (or (not profiled-procedures)676 ( memq dest profiled-procedures)))684 (or profiled-procedures 685 (variable-mark dest '##compiler#profile))) 677 686 (expand-profile-lambda dest llist2 body) ) 678 687 (else 679 688 (if (and (> (length body0) 1) 680 689 (symbol? (car body0)) 681 (eq? 'begin ( lookup (car body0) se))690 (eq? 'begin (or (lookup (car body0) se) (car body0))) 682 691 (let ((x1 (cadr body0))) 683 692 (or (string? x1) … … 685 694 (= (length x1) 2) 686 695 (symbol? (car x1)) 687 (eq? 'quote ( lookup (car x1) se))))))696 (eq? 'quote (or (lookup (car x1) se) (car x1))))))) 688 697 (process-lambda-documentation 689 698 dest (cadr body) l) … … 1063 1072 (let ([var (gensym "constant")]) 1064 1073 (##sys#hash-table-set! constant-table name (list var)) 1065 (set! mutable-constants (alist-cons var val mutable-constants))1066 1074 (hide-variable var) 1075 (mark-variable var '##compiler#constant) 1067 1076 (mark-variable var '##compiler#always-bound) 1068 1077 (walk `(define ,var ',val) se #f) ) ] ) ) ) … … 1191 1200 (mapwalk x se) ) 1192 1201 1193 ((and (pair? (car x)) (symbol? (caar x)) (eq? 'lambda (or (lookup (caar x) se) (caar x)))) 1202 ((and (pair? (car x)) 1203 (symbol? (caar x)) 1204 (eq? 'lambda (or (lookup (caar x) se) (caar x)))) 1194 1205 (let ([lexp (car x)] 1195 1206 [args (cdr x)] ) … … 1344 1355 (if (null? (cddr spec)) 1345 1356 (set! inline-max-size -1) 1346 (set! not-inline-list (lset-union eq? not-inline-list 1347 (stripa (cddr spec)))) ) ] 1357 (for-each 1358 (cut mark-variable <> '##compiler#inline 'no) 1359 (stripa (cddr spec)))) ] 1348 1360 [(usual-integrations) 1349 1361 (cond [(null? (cddr spec)) … … 1354 1366 (set! standard-bindings (lset-difference eq? default-standard-bindings syms)) 1355 1367 (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ] 1356 ((local)1357 (if (null? (cddr spec))1358 (set! local-definitions #f)1359 (for-each (cut remprop! <> '##compiler#local) (stripa (cddr spec)))))1360 1368 [else 1361 1369 (check-decl spec 1 1) … … 1381 1389 (unless (> inline-max-size -1) 1382 1390 (set! inline-max-size default-inline-max-size) ) 1383 (set! inline-list (lset-union eq? inline-list (stripa (cdr spec)))) ) ) 1391 (for-each 1392 (cut mark-variable <> '##compiler#inline 'yes) 1393 (stripa (cdr spec))))) 1384 1394 ((inline-limit) 1385 1395 (check-decl spec 1 1) … … 1411 1421 (strip (cdr spec)))))) 1412 1422 ((profile) 1413 (set! profiled-procedures 1414 (append (stripa (cdr spec)) 1415 (or profiled-procedures '())))) 1423 (if (null? (cdr spec)) 1424 (set! profiled-procedures #t) 1425 (for-each 1426 (custom-declare-alist mark-variable <> '##compiler#profile) 1427 (stripa (cdr spec))))) 1416 1428 ((local) 1417 1429 (cond ((null? (cdr spec)) … … 1419 1431 (else 1420 1432 (for-each 1421 (cut ##sys#put! <> '##compiler#local #t)1433 (cut mark-variable <> '##compiler#local) 1422 1434 (stripa (cdr spec)))))) 1435 ((inline-global) 1436 (set! inline-global #t)) 1423 1437 (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) ) 1424 1438 '(##core#undefined) ) ) ) … … 1699 1713 (collect! db name 'call-sites (cons here n)) 1700 1714 ;; If call to standard-binding & optimizable rest-arg operator: decrease access count: 1701 (if (and ( get db name 'standard-binding)1715 (if (and (intrinsic? name) 1702 1716 (memq name optimizable-rest-argument-operators) ) 1703 1717 (for-each … … 1769 1783 [val (car subs)] ) 1770 1784 (when first-analysis 1771 (cond [(get db var 'standard-binding) 1772 (compiler-warning 'redef "redefinition of standard binding `~S'" var) ] 1773 [(get db var 'extended-binding) 1774 (compiler-warning 'redef "redefinition of extended binding `~S'" var) ] ) 1785 (case (variable-mark var '##compiler#intrinsic) 1786 ((standard) 1787 (compiler-warning 'redef "redefinition of standard binding `~S'" var) ) 1788 ((extended) 1789 (compiler-warning 'redef "redefinition of extended binding `~S'" var) ) ) 1775 1790 (put! db var 'potential-value val) ) 1776 1791 (when (and (not (memq var localenv)) … … 1801 1816 ((or block-compilation 1802 1817 (memq var env) 1803 (get db var 'constant) 1804 ;;(memq var inline-list) - would be nice, but might be customized... 1818 (variable-mark var '##compiler#constant) 1805 1819 (not (variable-visible? var))) 1806 1820 (let ((props (get-all db var 'unknown 'value)) … … 1812 1826 (put! db var 'value val) 1813 1827 (put! db var 'unknown #t) ) ) ) ) ) 1828 ((and (or local-definitions 1829 (variable-mark var '##compiler#local)) 1830 (not (get db var 'unknown))) 1831 (let ((home (get db var 'home))) 1832 (if (or (not home) (eq? here home)) 1833 (put! db var 'local-value val) 1834 (put! db var 'unknown #t)))) 1814 1835 (else (put! db var 'unknown #t)) ) ) 1815 1836 … … 1841 1862 (let ([unknown #f] 1842 1863 [value #f] 1864 [local-value #f] 1843 1865 [pvalue #f] 1844 1866 [references '()] … … 1871 1893 [(global) (set! global #t)] 1872 1894 [(value) (set! value (cdr prop))] 1895 [(local-value) (set! local-value (cdr prop))] 1873 1896 [(o-r/access-count) (set! o-r/access-count (cdr prop))] 1874 1897 [(rest-parameter) (set! rest-parameter #t)] ) ) … … 1894 1917 (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) ) 1895 1918 (when (and (not (variable-visible? sym)) 1896 (not ( assq sym mutable-constants)) )1919 (not (variable-mark sym '##compiler#constant)) ) 1897 1920 (compiler-warning 'var "global variable `~S' is never used" sym) ) ) 1898 1921 … … 1904 1927 ;; if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if 1905 1928 ;; use/call count is not 1: 1906 (when value 1907 (let ((valparams (node-parameters value))) 1908 (when (and (eq? '##core#lambda (node-class value)) 1909 (or (not (second valparams)) 1910 (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) ) 1911 (if (and (= 1 nreferences) (= 1 ncall-sites)) 1912 (quick-put! plist 'contractable #t) 1913 (quick-put! plist 'inlinable #t) ) ) ) ) 1929 (cond (value 1930 (let ((valparams (node-parameters value))) 1931 (when (and (eq? '##core#lambda (node-class value)) 1932 (or (not (second valparams)) 1933 (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) ) 1934 (if (and (= 1 nreferences) (= 1 ncall-sites)) 1935 (quick-put! plist 'contractable #t) 1936 (quick-put! plist 'inlinable #t) ) ) ) ) 1937 (local-value 1938 ;; Make 'inlinable, if it is declared local and has a value 1939 (let ((valparams (node-parameters local-value))) 1940 (when (and (eq? '##core#lambda (node-class local-value)) 1941 (or (not (second valparams)) 1942 (every (lambda (v) (get db v 'global)) (scan-free-variables local-value)) ) ) 1943 (quick-put! plist 'inlinable #t) ) ) ) ) 1914 1944 1915 1945 ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only … … 2328 2358 unsafe 2329 2359 (variable-mark var '##compiler#always-bound) 2330 (get db var 'standard-binding) 2331 (get db var 'extended-binding) ) ] 2360 (intrinsic? var))] 2332 2361 [blockvar (and (get db var 'assigned) 2333 2362 (not (variable-visible? var)))]) … … 2474 2503 unsafe 2475 2504 (variable-mark var '##compiler#always-bound) 2476 (get db var 'standard-binding) 2477 (get db var 'extended-binding) ) ) ] 2505 (intrinsic? var)))] 2478 2506 [blockvar (not (variable-visible? var))] 2479 2507 [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val)))) -
chicken/branches/cmi/csc.scm
r12134 r12148 177 177 -lambda-lift -dynamic -disable-stack-overflow-checks -emit-debug-info -local 178 178 -emit-external-prototypes-first -inline -extension -release -static-extensions 179 -analyze-only -keep-shadowed-macros ))179 -analyze-only -keep-shadowed-macros -inline-global)) 180 180 181 181 (define-constant complex-options … … 388 388 -inline enable inlining 389 389 -inline-limit set inlining threshold 390 -inline-global enable cross-module inlining 390 391 391 392 Configuration options: -
chicken/branches/cmi/defaults.make
r12021 r12148 92 92 endif 93 93 94 RUNTIME_LINKER_PATH ?= . 95 94 96 # commands 95 97 -
chicken/branches/cmi/manual/Declarations
r11646 r12148 181 181 182 182 183 === local 184 185 [declaration specifier] (local) 186 [declaration specifier] (local SYMBOL ...) 187 188 Declares that the listed (or all) toplevel variables defined in the 189 current compilation unit are not modified from code outside of this 190 compilation unit. 191 192 183 193 === no-argc-checks 184 194 -
chicken/branches/cmi/manual/Using the compiler
r12086 r12148 27 27 ; -analyze-only : Stop compilation after first analysis pass. 28 28 29 ; -benchmark-mode : Equivalent to {{-no-trace -no-lambda-info -optimize-level 3}} {{-fixnum-arithmetic -disable-interrupts -block -lambda-lift}}.29 ; -benchmark-mode : Equivalent to {{-no-trace -no-lambda-info -optimize-level 4}} {{-fixnum-arithmetic -disable-interrupts -block -lambda-lift}}. 30 30 31 31 ; -block : Enable block-compilation. When this option is specified, the compiler assumes that global variables are not modified outside this compilation-unit. Specifically, toplevel bindings are not seen by {{eval}} and unused toplevel bindings are removed. … … 128 128 ; -lambda-lift : Enable the optimization known as lambda-lifting. 129 129 130 ; -local : Assume toplevel variables defined in the current compilation unit are not externally modified. 131 130 132 ; -no-lambda-info : Don't emit additional information for each {{lambda}} expression (currently the argument-list, after alpha-conversion/renaming). 131 133 … … 144 146 -optimize-level 1 is equivalent to -optimize-leaf-routines 145 147 -optimize-level 2 is currently the same as -optimize-level 1 146 -optimize-level 3 is equivalent to -optimize-leaf-routines -unsafe 148 -optimize-level 3 is equivalent to -optimize-leaf-routines -local 149 -optimize-level 4 is equivalent to -optimize-leaf-routines -local -unsafe 147 150 148 151 ; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}. -
chicken/branches/cmi/optimizer.scm
r12134 r12148 34 34 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 35 35 installation-home decompose-lambda-list external-to-pointer 36 copy-node! inline-list not-inline-list variable-visible? mark-variable36 copy-node! variable-visible? mark-variable intrinsic? 37 37 unit-name insert-timer-checks used-units external-variables hide-variable 38 38 debug-info-index debug-info-vector-name profile-info-vector-name … … 42 42 default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size 43 43 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables 44 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants44 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 45 45 broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda 46 46 profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda … … 193 193 (if (eq? '##core#variable (node-class (car subs))) 194 194 (let ((var (first (node-parameters (car subs))))) 195 (if (and (or (test var 'standard-binding) 196 (test var 'extended-binding) ) 195 (if (and (intrinsic? var) 197 196 (test var 'foldable) 198 197 (every constant-node? (cddr subs)) ) … … 286 285 ;; Call to named procedure: 287 286 (let* ([var (first (node-parameters fun))] 288 [lval (and (not (test var 'unknown)) (test var 'value))] 287 [lval (and (not (test var 'unknown)) 288 (or (test var 'value) 289 (test var 'local-value)))] 289 290 [args (cdr subs)] ) 290 291 (cond [(test var 'contractable) … … 318 319 (lambda (vars argc rest) 319 320 (let ([fid (first lparams)]) 321 #;(pp `(INLINE: ,var ,fid ,(test fid 'simple) 322 ,(test var 'inlinable) 323 ,(variable-mark var '##compiler#inline))) 320 324 (cond [(and (test fid 'simple) 321 325 (test var 'inlinable) 322 (not (memq var not-inline-list)) 323 (or (memq var inline-list) 324 (< (fourth lparams) inline-max-size) ) ) 326 (case (variable-mark var '##compiler#inline) 327 ((yes) #t) 328 ((no) #f) 329 (else 330 (< (fourth lparams) inline-max-size) ) )) 325 331 (debugging 'i "procedure inlinable" var fid (fourth lparams)) 326 332 (check-signature var args llist) … … 443 449 444 450 ;; Handle '(if (not ...) ...)': 445 (if ( test 'not 'standard-binding)451 (if (intrinsic? 'not) 446 452 (for-each 447 453 (lambda (site) … … 484 490 (for-each 485 491 (lambda (varname) 486 (if ( test varname 'standard-binding)492 (if (intrinsic? varname) 487 493 (for-each 488 494 (lambda (site) … … 851 857 ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...) 852 858 ((1) ; classargs = (<argc> <iop>) 853 (and ( test name 'standard-binding)859 (and (intrinsic? name) 854 860 (or (and (= (length callargs) (first classargs)) 855 861 (let ((arg1 (first callargs)) … … 869 875 (and inline-substitutions-enabled 870 876 (= (length callargs) (first classargs)) 871 ( or (test name 'extended-binding) (test name 'standard-binding))877 (intrinsic? name) 872 878 (or (third classargs) unsafe) 873 879 (let ([arg1 (first callargs)] … … 887 893 (and inline-substitutions-enabled 888 894 (null? callargs) 889 ( or (test name 'standard-binding) (test name 'extended-binding))895 (intrinsic? name) 890 896 (make-node '##core#call '(#t) (list cont (varnode (first classargs)))) ) ) 891 897 … … 895 901 unsafe 896 902 (= 2 (length callargs)) 897 ( test name 'standard-binding)903 (intrinsic? name) 898 904 (make-node '##core#call (list #f (first classargs)) 899 905 (list (varnode (first classargs)) … … 907 913 ;; - <numtype> may be #f 908 914 (and inline-substitutions-enabled 909 (or (test name 'extended-binding) 910 (test name 'standard-binding) ) 915 (intrinsic? name) 911 916 (= 1 (length callargs)) 912 917 (let ((ntype (third classargs))) … … 923 928 inline-substitutions-enabled 924 929 (= 1 (length callargs)) 925 ( test name 'standard-binding)930 (intrinsic? name) 926 931 (make-node '##core#call '(#t) 927 932 (list cont … … 935 940 inline-substitutions-enabled 936 941 (= (length callargs) (first classargs)) 937 ( or (test name 'standard-binding) (test name 'extended-binding))942 (intrinsic? name) 938 943 (make-node '##core#call '(#t) 939 944 (list cont … … 945 950 ((8) ; classargs = (<proc> ...) 946 951 (and inline-substitutions-enabled 947 (or (test name 'standard-binding) 948 (test name 'extended-binding) ) 952 (intrinsic? name) 949 953 ((first classargs) db classargs cont callargs) ) ) 950 954 … … 953 957 ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>) 954 958 (and inline-substitutions-enabled 955 ( test name 'standard-binding)959 (intrinsic? name) 956 960 (if (< (length callargs) 2) 957 961 (make-node '##core#call '(#t) (list cont (qnode #t))) … … 980 984 (and inline-substitutions-enabled 981 985 (or (fourth classargs) unsafe) 982 ( test name 'standard-binding)986 (intrinsic? name) 983 987 (let ((n (length callargs))) 984 988 (and (< 0 n 3) … … 997 1001 (and inline-substitutions-enabled 998 1002 (or (third classargs) unsafe) 999 ( or (test name 'standard-binding) (test name 'extended-binding))1003 (intrinsic? name) 1000 1004 (let ([argc (first classargs)]) 1001 1005 (and (or (not argc) … … 1010 1014 ((12) ; classargs = (<primitiveop> <safe> <maxargc>) 1011 1015 (and inline-substitutions-enabled 1012 ( or (test name 'standard-binding) (test name 'extended-binding))1016 (intrinsic? name) 1013 1017 (or (second classargs) unsafe) 1014 1018 (let ((n (length callargs))) … … 1023 1027 ((13) ; classargs = (<primitiveop> <safe>) 1024 1028 (and inline-substitutions-enabled 1025 ( or (test name 'extended-binding) (test name 'standard-binding))1029 (intrinsic? name) 1026 1030 (or (second classargs) unsafe) 1027 1031 (let ((pname (first classargs))) … … 1034 1038 (and inline-substitutions-enabled 1035 1039 (= (second classargs) (length callargs)) 1036 (or (test name 'extended-binding) 1037 (test name 'standard-binding) ) 1040 (intrinsic? name) 1038 1041 (eq? number-type (first classargs)) 1039 1042 (or (fourth classargs) unsafe) … … 1052 1055 (= 1 (length callargs)) 1053 1056 (or unsafe (fourth classargs)) 1054 (or (test name 'extended-binding) 1055 (test name 'standard-binding) ) 1057 (intrinsic? name) 1056 1058 (cond ((eq? number-type (first classargs)) 1057 1059 (make-node '##core#call (list #t (third classargs)) … … 1073 1075 (and inline-substitutions-enabled 1074 1076 (or (not argc) (= rargc argc)) 1075 ( or (test name 'extended-binding) (test name 'standard-binding))1077 (intrinsic? name) 1076 1078 (or (third classargs) unsafe) 1077 1079 (make-node … … 1090 1092 (and inline-substitutions-enabled 1091 1093 (= (length callargs) (first classargs)) 1092 ( or (test name 'extended-binding) (test name 'standard-binding))1094 (intrinsic? name) 1093 1095 (make-node 1094 1096 '##core#call '(#t) … … 1104 1106 (and inline-substitutions-enabled 1105 1107 (null? callargs) 1106 ( or (test name 'extended-binding) (test name 'standard-binding))1108 (intrinsic? name) 1107 1109 (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) ) 1108 1110 … … 1114 1116 ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>) 1115 1117 (and inline-substitutions-enabled 1116 ( or (test name 'standard-binding) (test name 'extended-binding))1118 (intrinsic? name) 1117 1119 (let* ([id (first classargs)] 1118 1120 [fixop (if unsafe (third classargs) (second classargs))] … … 1143 1145 inline-substitutions-enabled 1144 1146 (= n (first classargs)) 1145 ( or (test name 'standard-binding) (test name 'extended-binding))1147 (intrinsic? name) 1146 1148 (make-node 1147 1149 '##core#call '(#t) … … 1161 1163 ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>) 1162 1164 (and inline-substitutions-enabled 1163 ( or (test name 'standard-binding) (test name 'extended-binding))1165 (intrinsic? name) 1164 1166 (let* ([id (first classargs)] 1165 1167 [words (fifth classargs)] … … 1195 1197 (and inline-substitutions-enabled 1196 1198 (= rargc argc) 1197 ( or (test name 'extended-binding) (test name 'standard-binding))1199 (intrinsic? name) 1198 1200 (or (third classargs) unsafe) 1199 1201 (make-node … … 1216 1218 ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...) 1217 1219 (and inline-substitutions-enabled 1218 ( or (test name 'standard-binding) (test name 'extended-binding))1220 (intrinsic? name) 1219 1221 (let ([argc (first classargs)]) 1220 1222 (and (>= (length callargs) (first classargs)) -
chicken/branches/cmi/support.scm
r12134 r12148 37 37 file-io-only banner custom-declare-alist disabled-warnings internal-bindings 38 38 unit-name insert-timer-checks used-units source-filename pending-canonicalizations 39 foreign-declarations block-compilation line-number-database-size 39 foreign-declarations block-compilation line-number-database-size node->sexpr 40 40 target-heap-size target-stack-size variable-visible? hide-variable export-variable 41 41 default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size 42 42 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables 43 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants43 rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used 44 44 dependency-list broken-constant-nodes inline-substitutions-enabled emit-syntax-trace-info 45 45 block-variable-literal? copy-node! valid-c-identifier? tree-copy copy-node-tree-and-rename … … 69 69 foreign-argument-conversion foreign-result-conversion final-foreign-type debugging block-globals 70 70 constant-declarations process-lambda-documentation big-fixnum? 71 export-dump-hook 71 export-dump-hook intrinsic? 72 72 make-random-name foreign-type-convert-result foreign-type-convert-argument process-custom-declaration) 73 73 … … 321 321 ; symbol-keyed hash-tables here. 322 322 323 (define (initialize-analysis-database db) 324 (for-each 325 (lambda (s) 326 (put! db s 'standard-binding #t) 327 (when (memq s side-effecting-standard-bindings) (put! db s 'side-effecting #t)) 328 (when (memq s foldable-standard-bindings) (put! db s 'foldable #t)) ) 329 standard-bindings) 330 (for-each 331 (lambda (s) 332 (put! db s 'extended-binding #t) 333 (when (memq s foldable-extended-bindings) (put! db s 'foldable #t)) ) 334 extended-bindings) 335 (for-each 336 (lambda (s) (put! db (car s) 'constant #t)) 337 mutable-constants) ) 323 (define initialize-analysis-database 324 (let ((initial #t)) 325 (lambda (db) 326 (for-each 327 (lambda (s) 328 (when initial 329 (mark-variable s '##compiler#intrinsic 'standard)) 330 (when (memq s side-effecting-standard-bindings) (put! db s 'side-effecting #t)) 331 (when (memq s foldable-standard-bindings) (put! db s 'foldable #t)) ) 332 standard-bindings) 333 (for-each 334 (lambda (s) 335 (when initial 336 (mark-variable s '##compiler#intrinsic 'extended)) 337 (when (memq s foldable-extended-bindings) (put! db s 'foldable #t)) ) 338 extended-bindings) 339 (set! initial #f)))) 338 340 339 341 (define (get db key prop) … … 418 420 (lambda (sym plist) 419 421 (let ([val #f] 422 (lval #f) 420 423 [pval #f] 421 424 [csites '()] … … 435 438 ((value) 436 439 (unless (eq? val 'unknown) (set! val (cdar es))) ) 440 ((local-value) 441 (unless (eq? val 'unknown) (set! lval (cdar es))) ) 437 442 ((potential-value) 438 443 (set! pval (cdar es)) ) … … 448 453 (cond [(and val (not (eq? val 'unknown))) 449 454 (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ] 450 [(and pval (not (eq? pval 'unknown))) 455 [(and lval (not (eq? val 'unknown))) 456 (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ] 457 [(and pval (not (eq? val 'unknown))) 451 458 (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] ) 452 459 (when (pair? refs) (printf "\trefs=~s" (length refs))) … … 654 661 ((or (fx>= i len-from) (fx>= i len-to))) 655 662 (##sys#setslot to i (##sys#slot from i)) ) ) ) 663 664 (define (node->sexpr n) 665 (let walk ((n n)) 666 `(,(node-class n) 667 ,(node-parameters n) 668 ,@(map walk (node-subexpressions n))))) 656 669 657 670 … … 1211 1224 -inline enable inlining 1212 1225 -inline-limit set inlining threshold 1226 -inline-global enable cross-module inlining 1213 1227 1214 1228 Configuration options: … … 1415 1429 1416 1430 1417 ;;; symbol visibility 1431 ;;; symbol visibility and other global variable properties 1418 1432 1419 1433 (define (hide-variable sym) … … 1435 1449 (define (variable-mark var mark) 1436 1450 (##sys#get var mark) ) 1451 1452 (define intrinsic? (cut variable-mark <> '##compiler#intrinsic)) -
chicken/branches/cmi/tweaks.scm
r8361 r12148 47 47 (define-inline (node-parameters n) (##sys#slot n 2)) 48 48 (define-inline (node-subexpressions n) (##sys#slot n 3)) 49 50 (define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic)) 51 52 (define-inline (mark-variable var mark #!optional (val #t)) 53 (##sys#put! var mark val) ) 54 55 (define-inline (variable-mark var mark) 56 (##sys#get var mark) )
Note: See TracChangeset
for help on using the changeset viewer.
