Changeset 12148 in project


Ignore:
Timestamp:
10/13/08 12:07:51 (12 years ago)
Author:
felix winkelmann
Message:
  • fixed broken relinking in makefiles
  • compiler uses global symbol properties (instead of analysis-db and global lists) for some often used global variable attributes
  • fixed broken profiling
  • added support stuff for global inlining, but not implemented yet
  • added "local" mode and the ability to inline those
  • some namespace-related bugfixes in compiler
  • -O3 enableds local mode and inlining, -O4 is unsafe
Location:
chicken/branches/cmi
Files:
14 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/cmi/Makefile.linux

    r12021 r12148  
    4444endif
    4545LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
    46 LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$(LIBDIR)
    47 LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(LIBDIR)
     46LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH)
     47LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
    4848LIBRARIES = -lm -ldl
    4949NEEDS_RELINKING = yes
  • chicken/branches/cmi/TODO

    r12134 r12148  
    77* bugs
    88** compiler
    9 *** lambda-lifting breaks in ##sys#read (r-spaces), reported by Joerg Wittenberger
    10     in rev. 12103
    119*** pre-optimization
    1210**** changes call-sites and makes them invalid for later pre-optimization
     
    3836   what MacScheme called "benchmark-mode" (assume self-calls are recursion)
    3937*** needs declaration or option, >= -O2
     38*** local mode is probably half of it
    4039** 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
    4442** remove "custom-declare" + stuff?
    4543** 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-bindings
    48    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
    5149
    5250* tests
     
    5553*** fully compiled ec-tests
    5654
    57 * module issues
     55* modules
    5856** code-duplication in compiler and evaluator for ##core#module
    5957** "scheme" module does not include some special forms ("define-syntax", etc.)
     
    6361** curried define performs expansion in empty se - problem?
    6462   (as comment in expand.scm indicated (##sys#register-export))
     63** checks
     64*** reimport of imported id
     65*** unused defs?
    6566
    6667* setup/install
     
    8788** fluidly keep track of expanded forms (extend meaning of culprit)
    8889   to pprint pruned expr on error
    89 
    90 * modules
    91 ** checks
    92 *** reimport of imported id
    93 *** unused defs?
  • chicken/branches/cmi/batch-driver.scm

    r12134 r12148  
    4646  target-initial-heap-size postponed-initforms
    4747  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-constants
     48  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    4949  broken-constant-nodes inline-substitutions-enabled
    5050  emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name
     
    6565  default-declarations units-used-by-default words-per-flonum default-debugging-declarations
    6666  default-profiling-declarations default-optimization-passes
    67   inline-max-size file-requirements import-libraries
     67  inline-max-size file-requirements import-libraries inline-global
    6868  foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6969  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
     
    8686(define user-pass-2 (make-parameter #f))
    8787(define user-post-analysis-pass (make-parameter #f))
    88 (define user-post-optimization-pass (make-parameter #f))
    8988
    9089
     
    239238    (when (memq 'local options)
    240239      (set! local-definitions #t))
     240    (when (memq 'inline-global options)
     241      (set! inline-global #t))
    241242    (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
    242243    (when (memq 'no-warnings options)
     
    364365      (let ([acc (eq? 'accumulate-profile (car profile))])
    365366        (set! emit-profile #t)
    366         (set! profiled-procedures #f)
    367367        (set! initforms
    368368          (append
     
    580580                            (print-node "optimized" '|7| node2)
    581581
    582                             (let ((proc (user-post-optimization-pass)))
    583                               (when proc
    584                                 (when verbose
    585                                   (printf "post-optimization user pass...~%"))
    586                                 (begin-time)
    587                                 (proc node2 db)
    588                                 (end-time "post-optimization user pass")))
    589 
    590582                            (begin-time)
    591583                            (let ([node3 (perform-closure-conversion node2 db)])
  • chicken/branches/cmi/c-backend.scm

    r11905 r12148  
    4444  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants
    4545  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    46   mutable-constants encode-literal
     46  encode-literal
    4747  broken-constant-nodes inline-substitutions-enabled
    4848  direct-call-ids foreign-type-table first-analysis block-variable-literal?
  • chicken/branches/cmi/c-platform.scm

    r12134 r12148  
    3434  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
    3535  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
    36   installation-home debugging
     36  installation-home debugging intrinsic?
    3737  dump-nodes unlikely-variables
    3838  unit-name insert-timer-checks used-units inlining
     
    4141  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    4242  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-constants
     43  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    4444  broken-constant-nodes inline-substitutions-enabled
    4545  direct-call-ids foreign-type-table first-analysis
     
    9696(define default-profiling-declarations
    9797  '((##core#declare
    98      '(uses profiler)
    99      '(bound-to-procedure
     98     (uses profiler)
     99     (bound-to-procedure
    100100       ##sys#profile-entry ##sys#profile-exit) ) ) )
    101101
     
    121121    lambda-lift compile-syntax tag-pointers accumulate-profile
    122122    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
    124124    analyze-only dynamic extension) )
    125125
     
    429429                        (let ([name (car (node-parameters proc))])
    430430                          (and (memq name '(values ##sys#values))
    431                                (or (get db name 'standard-binding)
    432                                    (get db name 'extended-binding) )
     431                               (intrinsic? name)
    433432                               (make-node
    434433                                '##core#call '(#t)
     
    10451044          (and (eq? '##core#variable (node-class arg))
    10461045               (let ((sym (car (node-parameters arg))))
    1047                  (and (or (get db sym 'standard-binding)
    1048                           (get db sym 'extended-binding))
     1046                 (and (intrinsic? sym)
    10491047                      (and-let* ((a (assq sym setter-map)))
    10501048                        (make-node
  • chicken/branches/cmi/chicken.scm

    r11792 r12148  
    4444  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    4545  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-constants
     46  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    4747  broken-constant-nodes inline-substitutions-enabled compiler-warning
    4848  direct-call-ids foreign-type-table first-analysis
     
    124124                   [(3)
    125125                    (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) ) ]
    127130                   [else (compiler-warning 'usage "invalid optimization level ~S - ignored" (car rest))] )
    128131                 (loop (cdr rest)) ) ]
     
    139142                 (cons* 'fixnum-arithmetic 'disable-interrupts 'no-trace 'unsafe
    140143                        'optimize-leaf-routines 'block 'lambda-lift 'no-lambda-info
     144                        'local
    141145                        options) )
    142146               (loop rest) ]
  • chicken/branches/cmi/compiler.scm

    r12134 r12148  
    4141; ([not] standard-bindings {<name>})
    4242; ([not] usual-integrations {<name>})
     43; (local {<name> ...})
    4344; ([number-type] <type>)
    4445; (always-bound {<name>})
     
    7374; (unused <symbol> ...)
    7475; (uses {<unitname>})
    75 ; ([not] local {<name> ...})
    7676;
    7777;   <type> = fixnum | generic
     78
     79; - Global symbol properties:
    7880;
     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
    7990; - Source language:
    8091;
     
    129140; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
    130141; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
    131 ;
     142
    132143; - Core language:
    133144;
     
    155166; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
    156167; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
    157 ;
     168
    158169; - Closure converted/prepared language:
    159170;
     
    189200; [##core#return <exp>]
    190201; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
    191 ;
    192 ;
     202
    193203; Analysis database entries:
    194204;
     
    204214;   undefined -> <boolean>                   If true: variable is unknown yet but can be known later
    205215;   value -> <node>                          Variable has a known value
     216;   local-value -> <node>                    Variable is declared local and has value
    206217;   potential-value -> <node>                Global variable was assigned this value
    207218;   references -> (<node> ...)               Nodes that are accesses of this variable (##core#variable nodes)
     
    255266
    256267(private compiler
    257   compiler-arguments process-command-line explicit-use-flag inline-list not-inline-list
     268  compiler-arguments process-command-line explicit-use-flag
    258269  default-standard-bindings default-extended-bindings side-effecting-standard-bindings
    259270  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
     
    269280  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    270281  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-constants
     282  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    272283  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
    273284  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
     
    295306  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    296307  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?
    299310  undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    300311  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
     
    366377(define standalone-executable #t)
    367378(define local-definitions #f)
     379(define inline-global #f)
    368380
    369381
     
    386398(define constant-table #f)
    387399(define constants-used #f)
    388 (define mutable-constants '())
    389400(define broken-constant-nodes '())
    390401(define inline-substitutions-enabled #f)
     
    412423(define csc-control-file #f)
    413424(define data-declarations '())
    414 (define inline-list '())
    415 (define not-inline-list '())
    416425(define file-requirements #f)
    417426(define postponed-initforms '())
     
    669678                                (set-real-names! aliases vars)
    670679                                (cond ((or (not dest)
    671                                            (not (assq dest se))) ; global?
     680                                           (assq dest se)) ; not global?
    672681                                       l)
    673                                       ((and (eq? 'lambda name)
     682                                      ((and (eq? 'lambda (or (lookup name se) name))
    674683                                            emit-profile
    675                                             (or (not profiled-procedures)
    676                                                 (memq dest profiled-procedures)))
     684                                            (or profiled-procedures
     685                                                (variable-mark dest '##compiler#profile)))
    677686                                       (expand-profile-lambda dest llist2 body) )
    678687                                      (else
    679688                                       (if (and (> (length body0) 1)
    680689                                                (symbol? (car body0))
    681                                                 (eq? 'begin (lookup (car body0) se))
     690                                                (eq? 'begin (or (lookup (car body0) se) (car body0)))
    682691                                                (let ((x1 (cadr body0)))
    683692                                                  (or (string? x1)
     
    685694                                                           (= (length x1) 2)
    686695                                                           (symbol? (car x1))
    687                                                            (eq? 'quote (lookup (car x1) se))))))
     696                                                           (eq? 'quote (or (lookup (car x1) se) (car x1)))))))
    688697                                           (process-lambda-documentation
    689698                                            dest (cadr body) l)
     
    10631072                                  (let ([var (gensym "constant")])
    10641073                                    (##sys#hash-table-set! constant-table name (list var))
    1065                                     (set! mutable-constants (alist-cons var val mutable-constants))
    10661074                                    (hide-variable var)
     1075                                    (mark-variable var '##compiler#constant)
    10671076                                    (mark-variable var '##compiler#always-bound)
    10681077                                    (walk `(define ,var ',val) se #f) ) ] ) ) )
     
    11911200           (mapwalk x se) )
    11921201
    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))))
    11941205           (let ([lexp (car x)]
    11951206                 [args (cdr x)] )
     
    13441355           (if (null? (cddr spec))
    13451356               (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)))) ]
    13481360          [(usual-integrations)     
    13491361           (cond [(null? (cddr spec))
     
    13541366                    (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
    13551367                    (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)))))
    13601368          [else
    13611369           (check-decl spec 1 1)
     
    13811389            (unless (> inline-max-size -1)
    13821390              (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)))))
    13841394       ((inline-limit)
    13851395        (check-decl spec 1 1)
     
    14111421                (strip (cdr spec))))))
    14121422       ((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)))))
    14161428       ((local)
    14171429        (cond ((null? (cdr spec))
     
    14191431              (else
    14201432               (for-each
    1421                 (cut ##sys#put! <> '##compiler#local #t)
     1433                (cut mark-variable <> '##compiler#local)
    14221434                (stripa (cdr spec))))))
     1435       ((inline-global)
     1436        (set! inline-global #t))
    14231437       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
    14241438     '(##core#undefined) ) ) )
     
    16991713                   (collect! db name 'call-sites (cons here n))
    17001714                   ;; 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)
    17021716                            (memq name optimizable-rest-argument-operators) )
    17031717                       (for-each
     
    17691783                  [val (car subs)] )
    17701784             (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) ) )
    17751790               (put! db var 'potential-value val) )
    17761791             (when (and (not (memq var localenv))
     
    18011816            ((or block-compilation
    18021817                 (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)
    18051819                 (not (variable-visible? var)))
    18061820             (let ((props (get-all db var 'unknown 'value))
     
    18121826                         (put! db var 'value val)
    18131827                         (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))))
    18141835            (else (put! db var 'unknown #t)) ) )
    18151836   
     
    18411862       (let ([unknown #f]
    18421863             [value #f]
     1864             [local-value #f]
    18431865             [pvalue #f]
    18441866             [references '()]
     
    18711893              [(global) (set! global #t)]
    18721894              [(value) (set! value (cdr prop))]
     1895              [(local-value) (set! local-value (cdr prop))]
    18731896              [(o-r/access-count) (set! o-r/access-count (cdr prop))]
    18741897              [(rest-parameter) (set! rest-parameter #t)] ) )
     
    18941917             (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) )
    18951918           (when (and (not (variable-visible? sym))
    1896                       (not (assq sym mutable-constants)) )
     1919                      (not (variable-mark sym '##compiler#constant)) )
    18971920             (compiler-warning 'var "global variable `~S' is never used" sym) ) )
    18981921
     
    19041927         ;;  if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if
    19051928         ;;  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) ) ) ) )
    19141944
    19151945         ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only
     
    23282358                       unsafe
    23292359                       (variable-mark var '##compiler#always-bound)
    2330                        (get db var 'standard-binding)
    2331                        (get db var 'extended-binding) ) ]
     2360                       (intrinsic? var))]
    23322361             [blockvar (and (get db var 'assigned)
    23332362                            (not (variable-visible? var)))])
     
    24742503                                          unsafe
    24752504                                          (variable-mark var '##compiler#always-bound)
    2476                                           (get db var 'standard-binding)
    2477                                           (get db var 'extended-binding) ) ) ]
     2505                                          (intrinsic? var)))]
    24782506                           [blockvar (not (variable-visible? var))]
    24792507                           [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
  • chicken/branches/cmi/csc.scm

    r12134 r12148  
    177177    -lambda-lift -dynamic -disable-stack-overflow-checks -emit-debug-info -local
    178178    -emit-external-prototypes-first -inline -extension -release -static-extensions
    179     -analyze-only -keep-shadowed-macros))
     179    -analyze-only -keep-shadowed-macros -inline-global))
    180180
    181181(define-constant complex-options
     
    388388    -inline                     enable inlining
    389389    -inline-limit               set inlining threshold
     390    -inline-global              enable cross-module inlining
    390391
    391392  Configuration options:
  • chicken/branches/cmi/defaults.make

    r12021 r12148  
    9292endif
    9393
     94RUNTIME_LINKER_PATH ?= .
     95
    9496# commands
    9597
  • chicken/branches/cmi/manual/Declarations

    r11646 r12148  
    181181
    182182
     183=== local
     184
     185 [declaration specifier] (local)
     186 [declaration specifier] (local SYMBOL ...)
     187
     188Declares that the listed (or all) toplevel variables defined in the
     189current compilation unit are not modified from code outside of this
     190compilation unit.
     191
     192
    183193=== no-argc-checks
    184194
  • chicken/branches/cmi/manual/Using the compiler

    r12086 r12148  
    2727; -analyze-only : Stop compilation after first analysis pass.
    2828
    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}}.
    3030
    3131; -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.
     
    128128; -lambda-lift : Enable the optimization known as lambda-lifting.
    129129
     130; -local : Assume toplevel variables defined in the current compilation unit are not externally modified.
     131
    130132; -no-lambda-info : Don't emit additional information for each {{lambda}} expression (currently the argument-list, after alpha-conversion/renaming).
    131133
     
    144146     -optimize-level 1          is equivalent to -optimize-leaf-routines
    145147     -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
    147150
    148151; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}.
  • chicken/branches/cmi/optimizer.scm

    r12134 r12148  
    3434  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
    3535  installation-home decompose-lambda-list external-to-pointer
    36   copy-node! inline-list not-inline-list variable-visible? mark-variable
     36  copy-node! variable-visible? mark-variable intrinsic?
    3737  unit-name insert-timer-checks used-units external-variables hide-variable
    3838  debug-info-index debug-info-vector-name profile-info-vector-name
     
    4242  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    4343  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-constants
     44  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    4545  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
    4646  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
     
    193193                (if (eq? '##core#variable (node-class (car subs)))
    194194                    (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)
    197196                               (test var 'foldable)
    198197                               (every constant-node? (cddr subs)) )
     
    286285                ;; Call to named procedure:
    287286                (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)))]
    289290                       [args (cdr subs)] )
    290291                  (cond [(test var 'contractable)
     
    318319                            (lambda (vars argc rest)
    319320                              (let ([fid (first lparams)])
     321                                #;(pp `(INLINE: ,var ,fid ,(test fid 'simple)
     322                                              ,(test var 'inlinable)
     323                                              ,(variable-mark var '##compiler#inline)))
    320324                                (cond [(and (test fid 'simple)
    321325                                            (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) ) ))
    325331                                       (debugging 'i "procedure inlinable" var fid (fourth lparams))
    326332                                       (check-signature var args llist)
     
    443449
    444450    ;; Handle '(if (not ...) ...)':
    445     (if (test 'not 'standard-binding)
     451    (if (intrinsic? 'not)
    446452        (for-each
    447453         (lambda (site)
     
    484490    (for-each
    485491     (lambda (varname)
    486        (if (test varname 'standard-binding)
     492       (if (intrinsic? varname)
    487493           (for-each
    488494            (lambda (site)
     
    851857    ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...)
    852858    ((1) ; classargs = (<argc> <iop>)
    853      (and (test name 'standard-binding)
     859     (and (intrinsic? name)
    854860          (or (and (= (length callargs) (first classargs))
    855861                   (let ((arg1 (first callargs))
     
    869875     (and inline-substitutions-enabled
    870876          (= (length callargs) (first classargs))
    871           (or (test name 'extended-binding) (test name 'standard-binding))
     877          (intrinsic? name)
    872878          (or (third classargs) unsafe)
    873879          (let ([arg1 (first callargs)]
     
    887893     (and inline-substitutions-enabled
    888894          (null? callargs)
    889           (or (test name 'standard-binding) (test name 'extended-binding))
     895          (intrinsic? name)
    890896          (make-node '##core#call '(#t) (list cont (varnode (first classargs)))) ) )
    891897
     
    895901          unsafe
    896902          (= 2 (length callargs))
    897           (test name 'standard-binding)
     903          (intrinsic? name)
    898904          (make-node '##core#call (list #f (first classargs))
    899905                     (list (varnode (first classargs))
     
    907913     ;; - <numtype> may be #f
    908914     (and inline-substitutions-enabled
    909           (or (test name 'extended-binding)
    910               (test name 'standard-binding) )
     915          (intrinsic? name)
    911916          (= 1 (length callargs))
    912917          (let ((ntype (third classargs)))
     
    923928           inline-substitutions-enabled
    924929           (= 1 (length callargs))
    925            (test name 'standard-binding)
     930           (intrinsic? name)
    926931           (make-node '##core#call '(#t)
    927932                      (list cont
     
    935940          inline-substitutions-enabled
    936941          (= (length callargs) (first classargs))
    937           (or (test name 'standard-binding) (test name 'extended-binding))
     942          (intrinsic? name)
    938943          (make-node '##core#call '(#t)
    939944                     (list cont
     
    945950    ((8) ; classargs = (<proc> ...)
    946951     (and inline-substitutions-enabled
    947           (or (test name 'standard-binding)
    948               (test name 'extended-binding) )
     952          (intrinsic? name)
    949953          ((first classargs) db classargs cont callargs) ) )
    950954
     
    953957    ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
    954958     (and inline-substitutions-enabled
    955           (test name 'standard-binding)
     959          (intrinsic? name)
    956960          (if (< (length callargs) 2)
    957961              (make-node '##core#call '(#t) (list cont (qnode #t)))
     
    980984     (and inline-substitutions-enabled
    981985          (or (fourth classargs) unsafe)
    982           (test name 'standard-binding)
     986          (intrinsic? name)
    983987          (let ((n (length callargs)))
    984988            (and (< 0 n 3)
     
    9971001     (and inline-substitutions-enabled
    9981002          (or (third classargs) unsafe)
    999           (or (test name 'standard-binding) (test name 'extended-binding))
     1003          (intrinsic? name)
    10001004          (let ([argc (first classargs)])
    10011005            (and (or (not argc)
     
    10101014    ((12) ; classargs = (<primitiveop> <safe> <maxargc>)
    10111015     (and inline-substitutions-enabled
    1012           (or (test name 'standard-binding) (test name 'extended-binding))
     1016          (intrinsic? name)
    10131017          (or (second classargs) unsafe)
    10141018          (let ((n (length callargs)))
     
    10231027    ((13) ; classargs = (<primitiveop> <safe>)
    10241028     (and inline-substitutions-enabled
    1025           (or (test name 'extended-binding) (test name 'standard-binding))
     1029          (intrinsic? name)
    10261030          (or (second classargs) unsafe)
    10271031          (let ((pname (first classargs)))
     
    10341038     (and inline-substitutions-enabled
    10351039          (= (second classargs) (length callargs))
    1036           (or (test name 'extended-binding)
    1037               (test name 'standard-binding) )
     1040          (intrinsic? name)
    10381041          (eq? number-type (first classargs))
    10391042          (or (fourth classargs) unsafe)
     
    10521055          (= 1 (length callargs))
    10531056          (or unsafe (fourth classargs))
    1054           (or (test name 'extended-binding)
    1055               (test name 'standard-binding) )
     1057          (intrinsic? name)
    10561058          (cond ((eq? number-type (first classargs))
    10571059                 (make-node '##core#call (list #t (third classargs))
     
    10731075       (and inline-substitutions-enabled
    10741076            (or (not argc) (= rargc argc))
    1075             (or (test name 'extended-binding) (test name 'standard-binding))
     1077            (intrinsic? name)
    10761078            (or (third classargs) unsafe)
    10771079            (make-node
     
    10901092     (and inline-substitutions-enabled
    10911093          (= (length callargs) (first classargs))
    1092           (or (test name 'extended-binding) (test name 'standard-binding))
     1094          (intrinsic? name)
    10931095          (make-node
    10941096           '##core#call '(#t)
     
    11041106     (and inline-substitutions-enabled
    11051107          (null? callargs)
    1106           (or (test name 'extended-binding) (test name 'standard-binding))
     1108          (intrinsic? name)
    11071109          (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) )
    11081110
     
    11141116    ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
    11151117     (and inline-substitutions-enabled
    1116           (or (test name 'standard-binding) (test name 'extended-binding))
     1118          (intrinsic? name)
    11171119          (let* ([id (first classargs)]
    11181120                 [fixop (if unsafe (third classargs) (second classargs))]
     
    11431145            inline-substitutions-enabled
    11441146            (= n (first classargs))
    1145             (or (test name 'standard-binding) (test name 'extended-binding))
     1147            (intrinsic? name)
    11461148            (make-node
    11471149             '##core#call '(#t)
     
    11611163    ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
    11621164     (and inline-substitutions-enabled
    1163           (or (test name 'standard-binding) (test name 'extended-binding))
     1165          (intrinsic? name)
    11641166          (let* ([id (first classargs)]
    11651167                 [words (fifth classargs)]
     
    11951197       (and inline-substitutions-enabled
    11961198            (= rargc argc)
    1197             (or (test name 'extended-binding) (test name 'standard-binding))
     1199            (intrinsic? name)
    11981200            (or (third classargs) unsafe)
    11991201            (make-node
     
    12161218    ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
    12171219     (and inline-substitutions-enabled
    1218           (or (test name 'standard-binding) (test name 'extended-binding))
     1220          (intrinsic? name)
    12191221          (let ([argc (first classargs)])
    12201222            (and (>= (length callargs) (first classargs))
  • chicken/branches/cmi/support.scm

    r12134 r12148  
    3737  file-io-only banner custom-declare-alist disabled-warnings internal-bindings
    3838  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
    4040  target-heap-size target-stack-size variable-visible? hide-variable export-variable
    4141  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    4242  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-constants
     43  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    4444  dependency-list broken-constant-nodes inline-substitutions-enabled emit-syntax-trace-info
    4545  block-variable-literal? copy-node! valid-c-identifier? tree-copy copy-node-tree-and-rename
     
    6969  foreign-argument-conversion foreign-result-conversion final-foreign-type debugging block-globals
    7070  constant-declarations process-lambda-documentation big-fixnum?
    71   export-dump-hook
     71  export-dump-hook intrinsic?
    7272  make-random-name foreign-type-convert-result foreign-type-convert-argument process-custom-declaration)
    7373
     
    321321;   symbol-keyed hash-tables here.
    322322
    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))))
    338340
    339341(define (get db key prop)
     
    418420       (lambda (sym plist)
    419421         (let ([val #f]
     422               (lval #f)
    420423               [pval #f]
    421424               [csites '()]
     
    435438                       ((value)
    436439                        (unless (eq? val 'unknown) (set! val (cdar es))) )
     440                       ((local-value)
     441                        (unless (eq? val 'unknown) (set! lval (cdar es))) )
    437442                       ((potential-value)
    438443                        (set! pval (cdar es)) )
     
    448453             (cond [(and val (not (eq? val 'unknown)))
    449454                    (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)))
    451458                    (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
    452459             (when (pair? refs) (printf "\trefs=~s" (length refs)))
     
    654661        ((or (fx>= i len-from) (fx>= i len-to)))
    655662      (##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)))))
    656669
    657670
     
    12111224    -inline                     enable inlining
    12121225    -inline-limit               set inlining threshold
     1226    -inline-global              enable cross-module inlining
    12131227
    12141228  Configuration options:
     
    14151429
    14161430
    1417 ;;; symbol visibility
     1431;;; symbol visibility and other global variable properties
    14181432
    14191433(define (hide-variable sym)
     
    14351449(define (variable-mark var mark)
    14361450  (##sys#get var mark) )
     1451
     1452(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
  • chicken/branches/cmi/tweaks.scm

    r8361 r12148  
    4747(define-inline (node-parameters n) (##sys#slot n 2))
    4848(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.