Changeset 12301 in project


Ignore:
Timestamp:
10/29/08 12:08:07 (12 years ago)
Author:
felix winkelmann
Message:

merged changes from cmi branch

Location:
chicken/trunk
Files:
4 added
1 deleted
26 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/Makefile

    r12021 r12301  
    7979bootstrap:
    8080        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bootstrap
     81bench:
     82        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
    8183endif
  • chicken/trunk/Makefile.bsd

    r12021 r12301  
    4141endif
    4242LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
    43 LINKER_LINK_DLOADABLE_OPTIONS = -shared -Wl,-R$(LIBDIR) -Wl,-L.
    44 LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(LIBDIR)
     43LINKER_LINK_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH) -Wl,-L.
     44LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
    4545LIBRARIES = -lm
    4646NEEDS_RELINKING = yes
  • chicken/trunk/Makefile.linux

    r12021 r12301  
    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/trunk/Makefile.solaris

    r12021 r12301  
    3030# platform configuration
    3131
    32 ARCH = $(shell sh $SRCDIR/config-arch.sh)
     32ARCH = $(shell sh $(SRCDIR)/config-arch.sh)
    3333
    3434# options
     
    4141endif
    4242LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
    43 LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(LIBDIR)
     43LINKER_LINK_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH) -Wl,-L.
     44LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
    4445LIBRARIES = -lrt -lsocket -lnsl -lm -ldl
     46NEEDS_RELINKING = yes
    4547
    4648# special files
  • chicken/trunk/NEWS

    r12112 r12301  
    3434    define-macro
    3535    define-extension
     36- "local" mode, in which locally defined exported toplevel variables can
     37  be inlined
     38- new options and declarations "[-]local", "[-]inline-global" and "-emit-inline-file"
     39- optimization levels changed to use inlining:
     40  -optimize-level 3: enables -inline -local (but *not* -unsafe)
     41  -optimize-level 4: enables -inline -local -unsafe
     42- increased default inlining-limit to 20
     43- support for cross-module inlining
     44- "make <VARIABLES> bench" runs the benchmark suite
    3645
    37463.4.0
  • chicken/trunk/TODO

    r12300 r12301  
    8888** read-mark list should be stored in read-table
    8989
     90* runtime
     91** pre-hashed symbols (extra symbol slot)
     92   The memory usage should be acceptable, performance gain is hard to guess.
     93   Some experiments indicate that hashing the string is cheaper than it appears,
     94   but low-level hashtables should get the most of this (and thus speed up
     95   the compiler)
     96
     97* benchmarks
     98** add more realistic benchmarks
     99
    90100* documentation
    91101** document ("HI/LO") expander (-> wiki, internals)
  • chicken/trunk/batch-driver.scm

    r12227 r12301  
    3737  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
    3838  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
    39   compiler-cleanup-hook disabled-warnings
     39  compiler-cleanup-hook disabled-warnings local-definitions inline-output-file
    4040  file-io-only undefine-shadowed-macros profiled-procedures
    41   unit-name insert-timer-checks used-units inline-max-size
     41  unit-name insert-timer-checks used-units inline-max-size inline-locally
    4242  debugging perform-lambda-lifting! disable-stack-overflow-checking
    4343  foreign-declarations emit-trace-info block-compilation line-number-database-size
     
    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  file-requirements import-libraries inline-globally
    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
    7070  chop-separator chop-extension display-real-name-table display-line-number-database explicit-use-flag
    7171  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    72   export-list do-lambda-lifting compiler-warning export-file-name
     72  do-lambda-lifting compiler-warning emit-global-inline-file load-inline-file
    7373  foreign-argument-conversion foreign-result-conversion)
    7474
     
    7777
    7878(define-constant default-profile-name "PROFILE")
    79 (define-constant default-inline-max-size 10)
    8079(define-constant funny-message-timeout 60000)
    8180
     
    8685(define user-pass-2 (make-parameter #f))
    8786(define user-post-analysis-pass (make-parameter #f))
    88 (define user-post-optimization-pass (make-parameter #f))
    8987
    9088
     
    237235    (when (memq 'no-lambda-info options)
    238236      (set! emit-closure-info #f) )
    239     (when (memq 'check-imports options) ;***
    240       (compiler-warning 'usage "deprecated compiler option: -check-imports")) ;***
    241     (when (memq 'import options)        ;***
    242       (compiler-warning 'usage "deprecated compiler option: -import")) ;***
     237    (when (memq 'local options)
     238      (set! local-definitions #t))
     239    (when (memq 'inline-global options)
     240      (set! inline-globally #t))
    243241    (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
    244242    (when (memq 'no-warnings options)
     
    253251    (when (memq 'fixnum-arithmetic options) (set! number-type 'fixnum))
    254252    (when (memq 'block options) (set! block-compilation #t))
    255     (when (memq 'emit-external-prototypes-first options) (set! external-protos-first #t))
    256     (when (memq 'inline options) (set! inline-max-size default-inline-max-size))
     253    (when (memq 'emit-external-prototypes-first options)
     254      (set! external-protos-first #t))
     255    (when (memq 'inline options) (set! inline-locally #t))
     256    (and-let* ((ifile (memq 'emit-inline-file options)))
     257      (set! inline-locally #t)          ; otherwise this option makes no sense
     258      (set! local-definitions #t)
     259      (set! inline-output-file (option-arg ifile)))
    257260    (and-let* ([inlimit (memq 'inline-limit options)])
    258261      (set! inline-max-size
     
    370373      (let ([acc (eq? 'accumulate-profile (car profile))])
    371374        (set! emit-profile #t)
    372         (set! profiled-procedures #f)
    373375        (set! initforms
    374376          (append
     
    503505                 (end-time "user pass") ) )
    504506
     507             (let ((req (concatenate (vector->list file-requirements))))
     508               (when (debugging 'M "; requirements:")
     509                 (pp req))
     510               (when inline-globally
     511                 (for-each
     512                  (lambda (id)
     513                    (and-let* ((ifile (##sys#resolve-include-filename
     514                                       (make-pathname #f (symbol->string id) "inline")
     515                                       #f #t))
     516                               ((file-exists? ifile)))
     517                      (when verbose
     518                        (print "Loading inline file " ifile " ..."))
     519                      (load-inline-file ifile)))
     520                  (concatenate (map cdr req)))))
     521
    505522             (let* ([node0 (make-node
    506523                            'lambda '(())
     
    508525                                   (canonicalize-begin-body exps) ) ) ) ]
    509526                    [proc (user-pass-2)] )
    510                (when (debugging 'M "; requirements:")
    511                  (pretty-print (concatenate (vector->list file-requirements))))
    512527               (when proc
    513528                 (when verbose (printf "Secondary user pass...~%"))
     
    564579
    565580                            (begin-time)
    566                             (receive (node2 progress-flag) (perform-high-level-optimizations node2 db)
     581                            (receive (node2 progress-flag)
     582                                (perform-high-level-optimizations node2 db)
    567583                              (end-time "optimization")
    568584                              (print-node "optimized-iteration" '|5| node2)
     
    586602                            (print-node "optimized" '|7| node2)
    587603
    588                             (let ((proc (user-post-optimization-pass)))
    589                               (when proc
     604                            (when (and inline-globally inline-output-file)
     605                              (let ((f inline-output-file))
    590606                                (when verbose
    591                                   (printf "post-optimization user pass...~%"))
    592                                 (begin-time)
    593                                 (proc node2 db)
    594                                 (end-time "post-optimization user pass")))
     607                                  (printf "Generating global inline file `~a' ...~%" f))
     608                                (emit-global-inline-file f db) ) )
    595609
    596610                            (begin-time)
  • chicken/trunk/c-backend.scm

    r11905 r12301  
    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/trunk/c-platform.scm

    r12086 r12301  
    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
     
    118118    check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info
    119119    profile inline keep-shadowed-macros
    120     fixnum-arithmetic disable-interrupts optimize-leaf-routines check-imports
     120    fixnum-arithmetic disable-interrupts optimize-leaf-routines
    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
     123    emit-external-prototypes-first release local inline-global
    124124    analyze-only dynamic extension) )
    125125
    126126(define valid-compiler-options-with-argument
    127127  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension
    128           inline-limit profile-name disable-warning emit-exports import
     128          inline-limit profile-name disable-warning
    129129    prelude postlude prologue epilogue nursery extend feature
    130     emit-import-library
     130    emit-import-library emit-inline-file
    131131    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
    132132
     
    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/trunk/chicken.1

    r10952 r12301  
    131131the a Scheme program has to access the callbacks. By default the prototypes are emitted
    132132after foreign declarations.
     133
     134.TP
     135.I \-emit\-inline\-file\ FILENAME
     136Write procedures that can be globally inlined in internal form to FILENAME,
     137if global inlining is enabled. Implies "-inline -local".
    133138
    134139.TP
     
    216221
    217222.TP
     223.B \-inline\-global
     224Enable cross-module inlining.
     225
     226.TP
    218227.BI \-inline\-limit threshold
    219228Sets the maximum size of potentially inlinable procedures.
     
    236245.B \-lambda\-lift
    237246Enable the optimization known as lambda-lifting.
     247
     248.TP
     249.B \-local
     250Assume toplevel variables defined in the current compilation unit are
     251not externally modified.
    238252
    239253.TP
  • chicken/trunk/chicken.scm

    r11792 r12301  
    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
     
    118118                   [(0) #f]
    119119                   [(1)
    120                     (set! options (cons* 'optimize-leaf-routines options)) ]
     120                    (set! options (cons 'optimize-leaf-routines options)) ]
    121121                   [(2)
    122                     (set! options
    123                       (cons 'optimize-leaf-routines options) ) ]
     122                    (set! options (cons 'optimize-leaf-routines options)) ]
    124123                   [(3)
    125124                    (set! options
    126                       (cons* 'optimize-leaf-routines 'unsafe options) ) ]
     125                      (cons* 'optimize-leaf-routines 'local 'inline options) ) ]
     126                   [(4)
     127                    (set! options
     128                      (cons* 'optimize-leaf-routines 'local 'inline 'unsafe options) ) ]
    127129                   [else (compiler-warning 'usage "invalid optimization level ~S - ignored" (car rest))] )
    128130                 (loop (cdr rest)) ) ]
     
    139141                 (cons* 'fixnum-arithmetic 'disable-interrupts 'no-trace 'unsafe
    140142                        'optimize-leaf-routines 'block 'lambda-lift 'no-lambda-info
     143                        'inline
    141144                        options) )
    142145               (loop rest) ]
  • chicken/trunk/compiler.scm

    r12227 r12301  
    4141; ([not] standard-bindings {<name>})
    4242; ([not] usual-integrations {<name>})
     43; (local {<name> ...})
     44; ([not] inline-global {<name>})
    4345; ([number-type] <type>)
    4446; (always-bound {<name>})
     
    5658; (foreign-declare {<string>})
    5759; (hide {<name>})
    58 ; (import <symbol-or-string> ...)
    5960; (inline-limit <limit>)
    6061; (keep-shadowed-macros)
     
    7576;
    7677;   <type> = fixnum | generic
     78
     79; - Global symbol properties:
    7780;
     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#inline-global -> 'yes | 'no | <node>
     89;   ##compiler#profile -> BOOL
     90;   ##compiler#unused -> BOOL
     91
    7892; - Source language:
    7993;
     
    128142; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
    129143; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
    130 ;
     144
    131145; - Core language:
    132146;
     
    154168; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
    155169; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
    156 ;
     170
    157171; - Closure converted/prepared language:
    158172;
     
    189203; [##core#return <exp>]
    190204; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
    191 ;
    192 ;
     205
    193206; Analysis database entries:
    194207;
     
    204217;   undefined -> <boolean>                   If true: variable is unknown yet but can be known later
    205218;   value -> <node>                          Variable has a known value
     219;   local-value -> <node>                    Variable is declared local and has value
    206220;   potential-value -> <node>                Global variable was assigned this value
    207221;   references -> (<node> ...)               Nodes that are accesses of this variable (##core#variable nodes)
     
    221235;   o-r/access-count -> <n>                  Contains number of references as arguments of optimizable rest operators
    222236;   constant -> <boolean>                    If true: variable has fixed value
     237;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
    223238;
    224239; <lambda-id>:
     
    255270
    256271(private compiler
    257   compiler-arguments process-command-line explicit-use-flag inline-list not-inline-list
     272  compiler-arguments process-command-line explicit-use-flag
    258273  default-standard-bindings default-extended-bindings side-effecting-standard-bindings
    259274  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
     
    264279  profile-info-vector-name finish-foreign-result pending-canonicalizations
    265280  foreign-declarations emit-trace-info block-compilation line-number-database-size
    266   always-bound-to-procedure block-globals make-block-variable-literal block-variable-literal? block-variable-literal-name
     281  make-block-variable-literal block-variable-literal? block-variable-literal-name
    267282  target-heap-size target-stack-size valid-c-identifier? profiled-procedures standalone-executable
    268283  target-initial-heap-size internal-bindings source-filename dump-nodes source-info->string
    269284  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    270285  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
     286  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    272287  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
    273288  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
    274289  direct-call-ids foreign-type-table first-analysis callback-names disabled-warnings
    275290  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
    276   compiler-warning
     291  compiler-warning variable-visible? hide-variable mark-variable inline-locally
    277292  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
    278293  reorganize-recursive-bindings substitution-table simplify-named-call inline-max-size
     
    288303  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list
    289304  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
    290   topological-sort print-version print-usage initialize-analysis-database export-list csc-control-file
    291   estimate-foreign-result-location-size unused-variables
     305  topological-sort print-version print-usage initialize-analysis-database csc-control-file
     306  estimate-foreign-result-location-size inline-output-file
    292307  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    293308  units-used-by-default words-per-flonum disable-stack-overflow-checking
     
    295310  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    296311  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
    297   location-pointer-map literal-rewrite-hook
     312  location-pointer-map literal-rewrite-hook inline-globally
     313  local-definitions export-variable variable-mark intrinsic?
    298314  undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    299315  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
     
    325341(define-constant file-requirements-size 301)
    326342(define-constant real-name-table-size 997)
    327 (define-constant default-inline-max-size 10)
     343(define-constant default-inline-max-size 20)
    328344
    329345
     
    337353(define used-units '())
    338354(define unsafe #f)
    339 (define always-bound '())
    340 (define always-bound-to-procedure '())
    341355(define foreign-declarations '())
    342356(define emit-trace-info #f)
     
    351365(define no-argc-checks #f)
    352366(define no-procedure-checks #f)
    353 (define block-globals '())
    354367(define source-filename #f)
    355 (define export-list #f)
    356368(define safe-globals-flag #f)
    357369(define explicit-use-flag #f)
     
    361373(define external-protos-first #f)
    362374(define do-lambda-lifting #f)
    363 (define inline-max-size -1)
     375(define inline-max-size default-inline-max-size)
    364376(define emit-closure-info #t)
    365377(define undefine-shadowed-macros #t)
     
    368380(define import-libraries '())
    369381(define standalone-executable #t)
     382(define local-definitions #f)
     383(define inline-globally #f)
     384(define inline-locally #f)
     385(define inline-output-file #f)
    370386
    371387
     
    388404(define constant-table #f)
    389405(define constants-used #f)
    390 (define mutable-constants '())
    391406(define broken-constant-nodes '())
    392407(define inline-substitutions-enabled #f)
     
    414429(define csc-control-file #f)
    415430(define data-declarations '())
    416 (define inline-list '())
    417 (define not-inline-list '())
    418431(define file-requirements #f)
    419432(define postponed-initforms '())
    420 (define unused-variables '())
    421433(define literal-rewrite-hook #f)
    422434
     
    577589                                  (let ([var (gensym 'c)])
    578590                                    (set! immutable-constants (alist-cons c var immutable-constants))
    579                                     (set! always-bound (cons var always-bound))
    580                                     (set! block-globals (cons var block-globals))
     591                                    (mark-variable var '##compiler#always-bound)
     592                                    (hide-variable var)
    581593                                    var) ] ) ) )
    582594
     
    596608                           (apply ##sys#require ids)
    597609                           (##sys#hash-table-update!
    598                             file-requirements 'syntax-requirements (cut lset-union eq? <> ids)
     610                            file-requirements 'dynamic/syntax
     611                            (cut lset-union eq? <> ids)
    599612                            (lambda () ids) )
    600613                           '(##core#undefined) ) )
     
    671684                                (set-real-names! aliases vars)
    672685                                (cond ((or (not dest)
    673                                            (not (assq dest se))) ; global?
     686                                           (assq dest se)) ; not global?
    674687                                       l)
    675                                       ((and (eq? 'lambda name)
     688                                      ((and (eq? 'lambda (or (lookup name se) name))
    676689                                            emit-profile
    677                                             (or (not profiled-procedures)
    678                                                 (memq dest profiled-procedures)))
     690                                            (or profiled-procedures
     691                                                (variable-mark dest '##compiler#profile)))
    679692                                       (expand-profile-lambda dest llist2 body) )
    680693                                      (else
    681694                                       (if (and (> (length body0) 1)
    682695                                                (symbol? (car body0))
    683                                                 (eq? 'begin (lookup (car body0) se))
     696                                                (eq? 'begin (or (lookup (car body0) se) (car body0)))
    684697                                                (let ((x1 (cadr body0)))
    685698                                                  (or (string? x1)
     
    687700                                                           (= (length x1) 2)
    688701                                                           (symbol? (car x1))
    689                                                            (eq? 'quote (lookup (car x1) se))))))
     702                                                           (eq? 'quote (or (lookup (car x1) se) (car x1)))))))
    690703                                           (process-lambda-documentation
    691704                                            dest (cadr body) l)
     
    894907                                    (set! var (##sys#alias-global-hook var #t))
    895908                                    (when safe-globals-flag
    896                                       (set! always-bound-to-procedure
    897                                         (lset-adjoin eq? always-bound-to-procedure var))
    898                                       (set! always-bound (lset-adjoin eq? always-bound var)) )
     909                                      (mark-variable var '##compiler#always-bound-to-procedure)
     910                                      (mark-variable var '##compiler#always-bound))
    899911                                    (when (macro? var)
    900912                                      (compiler-warning
     
    985997                                        [ret (gensym)] )
    986998                                    (##sys#hash-table-set! foreign-type-table name (vector type arg ret))
    987                                     (set! always-bound (cons* arg ret always-bound))
    988                                     (set! block-globals (cons* arg ret block-globals))
     999                                    (mark-variable arg '##compiler#always-bound)
     1000                                    (mark-variable ret '##compiler#always-bound)
     1001                                    (hide-variable arg)
     1002                                    (hide-variable ret)
    9891003                                    (walk
    9901004                                     `(,(macro-alias 'begin se)
     
    10651079                                  (let ([var (gensym "constant")])
    10661080                                    (##sys#hash-table-set! constant-table name (list var))
    1067                                     (set! mutable-constants (alist-cons var val mutable-constants))
    1068                                     (set! block-globals (cons var block-globals))
    1069                                     (set! always-bound (cons var always-bound))
     1081                                    (hide-variable var)
     1082                                    (mark-variable var '##compiler#constant)
     1083                                    (mark-variable var '##compiler#always-bound)
    10701084                                    (walk `(define ,var ',val) se #f) ) ] ) ) )
    10711085
     
    11931207           (mapwalk x se) )
    11941208
    1195           ((and (pair? (car x)) (symbol? (caar x)) (eq? 'lambda (or (lookup (caar x) se) (caar x))))
     1209          ((and (pair? (car x))
     1210                (symbol? (caar x))
     1211                (eq? 'lambda (or (lookup (caar x) se) (caar x))))
    11961212           (let ([lexp (car x)]
    11971213                 [args (cdr x)] )
     
    12501266          (apply register-feature! us)
    12511267          (when (pair? us)
    1252             (##sys#hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us))
     1268            (##sys#hash-table-update!
     1269             file-requirements 'static
     1270             (cut lset-union eq? us <>)
     1271             (lambda () us))
    12531272            (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
    12541273              (set! used-units (append used-units units)) ) ) ) )
     
    12571276        (let* ([u (strip (cadr spec))]
    12581277               [un (string->c-identifier (stringify u))] )
    1259           (##sys#hash-table-set! file-requirements 'unit u)
    12601278          (when (and unit-name (not (string=? unit-name un)))
    12611279            (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
     
    12931311          (append (strip (cdr spec)) disabled-warnings)))
    12941312       ((always-bound)
    1295         (set! always-bound (append (stripa (cdr spec)) always-bound)))
     1313        (for-each (cut mark-variable <> '##compiler#always-bound) (stripa (cdr spec))))
    12961314       ((safe-globals) (set! safe-globals-flag #t))
    12971315       ((no-procedure-checks-for-usual-bindings)
    1298         (set! always-bound-to-procedure
    1299           (append default-standard-bindings default-extended-bindings always-bound-to-procedure))
    1300         (set! always-bound
    1301           (append default-standard-bindings default-extended-bindings always-bound)) )
     1316        (for-each
     1317         (cut mark-variable <> '##compiler#always-bound-to-procedure)
     1318         (append default-standard-bindings default-extended-bindings))
     1319        (for-each
     1320         (cut mark-variable <> '##compiler#always-bound)
     1321         (append default-standard-bindings default-extended-bindings)))
    13021322       ((bound-to-procedure)
    13031323        (let ((vars (stripa (cdr spec))))
    1304           (set! always-bound-to-procedure (append vars always-bound-to-procedure))
    1305           (set! always-bound (append vars always-bound)) ) )
     1324          (for-each (cut mark-variable <> '##compiler#always-bound-to-procedure) vars)
     1325          (for-each (cut mark-variable <> '##compiler#always-bound) vars)))
    13061326       ((foreign-declare)
    13071327        (let ([fds (cdr spec)])
     
    13251345       ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
    13261346       ((unused)
    1327         (set! unused-variables (append (cdr spec) unused-variables)))
     1347        (for-each (cut mark-variable <> '##compiler#unused) (stripa (cdr spec))))
    13281348       ((not)
    13291349        (check-decl spec 1)
     
    13431363          [(inline)
    13441364           (if (null? (cddr spec))
    1345                (set! inline-max-size -1)
    1346                (set! not-inline-list (lset-union eq? not-inline-list
    1347                                                  (stripa (cddr spec)))) ) ]
     1365               (set! inline-locally #f)
     1366               (for-each
     1367                (cut mark-variable <> '##compiler#inline 'no)
     1368                (stripa (cddr spec)))) ]
    13481369          [(usual-integrations)     
    13491370           (cond [(null? (cddr spec))
     
    13541375                    (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
    13551376                    (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
     1377          ((inline-global)
     1378           (if (null? (cddr spec))
     1379               (set! inline-globally #f)
     1380               (for-each
     1381                (cut mark-variable <> '##compiler#inline-global 'no)
     1382                (stripa (cddr spec)))))
    13561383          [else
    13571384           (check-decl spec 1 1)
     
    13661393       ((block-global hide)
    13671394        (let ([syms (stripa (cdr spec))])
    1368           (when export-list
    1369             (set! export-list (lset-difference eq? export-list syms)) )
    1370           (set! block-globals (lset-union eq? syms block-globals)) ) )
     1395          (if (null? syms)
     1396              (set! block-compilation #t)
     1397              (for-each hide-variable syms))))
    13711398       ((export)
    13721399        (let ((syms (stripa (cdr spec))))
    1373           (set! block-globals (lset-difference eq? block-globals syms))
    1374           (set! export-list (lset-union eq? syms (or export-list '())))))
     1400          (for-each export-variable syms)))
    13751401       ((emit-external-prototypes-first)
    13761402        (set! external-protos-first #t) )
     
    13781404       ((inline)
    13791405        (if (null? (cdr spec))
    1380             (unless (> inline-max-size -1)
    1381               (set! inline-max-size default-inline-max-size) )
    1382             (set! inline-list (lset-union eq? inline-list (stripa (cdr spec)))) ) )
     1406            (set! inline-locally #t)
     1407            (for-each
     1408             (cut mark-variable <> '##compiler#inline 'yes)
     1409             (stripa (cdr spec)))))
    13831410       ((inline-limit)
    13841411        (check-decl spec 1 1)
     
    14101437                (strip (cdr spec))))))
    14111438       ((profile)
    1412         (set! profiled-procedures
    1413           (append (stripa (cdr spec))
    1414                   (or profiled-procedures '()))))
     1439        (if (null? (cdr spec))
     1440            (set! profiled-procedures #t)
     1441            (for-each
     1442             (cut mark-variable <> '##compiler#profile)
     1443             (stripa (cdr spec)))))
     1444       ((local)
     1445        (cond ((null? (cdr spec))
     1446               (set! local-definitions #t) )
     1447              (else
     1448               (for-each
     1449                (cut mark-variable <> '##compiler#local)
     1450                (stripa (cdr spec))))))
     1451       ((inline-global)
     1452        (if (null? (cdr spec))
     1453            (set! inline-globally #t)
     1454            (for-each
     1455             (cut mark-variable <> '##compiler#inline-global 'yes)
     1456             (stripa (cdr spec)))))
    14151457       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
    14161458     '(##core#undefined) ) ) )
     
    16911733                   (collect! db name 'call-sites (cons here n))
    16921734                   ;; If call to standard-binding & optimizable rest-arg operator: decrease access count:
    1693                    (if (and (get db name 'standard-binding)
     1735                   (if (and (intrinsic? name)
    16941736                            (memq name optimizable-rest-argument-operators) )
    16951737                       (for-each
     
    17611803                  [val (car subs)] )
    17621804             (when first-analysis
    1763                (cond [(get db var 'standard-binding)
    1764                       (compiler-warning 'redef "redefinition of standard binding `~S'" var) ]
    1765                      [(get db var 'extended-binding)
    1766                       (compiler-warning 'redef "redefinition of extended binding `~S'" var) ] )
     1805               (case (variable-mark var '##compiler#intrinsic)
     1806                 ((standard)
     1807                  (compiler-warning 'redef "redefinition of standard binding `~S'" var) )
     1808                 ((extended)
     1809                  (compiler-warning 'redef "redefinition of extended binding `~S'" var) ) )
    17671810               (put! db var 'potential-value val) )
    17681811             (when (and (not (memq var localenv))
    17691812                        (not (memq var env)) )
    17701813               (grow 1)
    1771                (when first-analysis
    1772                  (when (or block-compilation (and export-list (not (memq var export-list))))
    1773                    (set! block-globals (lset-adjoin eq? block-globals var)) ) )
    17741814               (put! db var 'global #t) )
    17751815             (assign var val (append localenv env) here)
     
    17961836            ((or block-compilation
    17971837                 (memq var env)
    1798                  (get db var 'constant)
    1799                  ;;(memq var inline-list)       - would be nice, but might be customized...
    1800                  (memq var block-globals) )
     1838                 (variable-mark var '##compiler#constant)
     1839                 (not (variable-visible? var)))
    18011840             (let ((props (get-all db var 'unknown 'value))
    18021841                   (home (get db var 'home)) )
     
    18071846                         (put! db var 'value val)
    18081847                         (put! db var 'unknown #t) ) ) ) ) )
     1848            ((and (or local-definitions
     1849                      (variable-mark var '##compiler#local))
     1850                  (not (get db var 'unknown)))
     1851             (let ((home (get db var 'home)))
     1852               (if (or (not home) (eq? here home))
     1853                   (put! db var 'local-value val)             
     1854                   (put! db var 'unknown #t))))
    18091855            (else (put! db var 'unknown #t)) ) )
    18101856   
     
    18361882       (let ([unknown #f]
    18371883             [value #f]
     1884             [local-value #f]
    18381885             [pvalue #f]
    18391886             [references '()]
     
    18661913              [(global) (set! global #t)]
    18671914              [(value) (set! value (cdr prop))]
     1915              [(local-value) (set! local-value (cdr prop))]
    18681916              [(o-r/access-count) (set! o-r/access-count (cdr prop))]
    18691917              [(rest-parameter) (set! rest-parameter #t)] ) )
     
    18851933                    global
    18861934                    (null? references)
    1887                     (not (memq sym unused-variables)))
     1935                    (not (variable-mark sym '##compiler#unused)))
    18881936           (when assigned-locally
    18891937             (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) )
    1890            (when (and (or block-compilation
    1891                           (and export-list (not (memq sym export-list))) )
    1892                       (not (assq sym mutable-constants)) )
     1938           (when (and (not (variable-visible? sym))
     1939                      (not (variable-mark sym '##compiler#constant)) )
    18931940             (compiler-warning 'var "global variable `~S' is never used" sym) ) )
    18941941
     
    19001947         ;;  if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if
    19011948         ;;  use/call count is not 1:
    1902          (when value
    1903            (let ((valparams (node-parameters value)))
    1904              (when (and (eq? '##core#lambda (node-class value))
    1905                         (or (not (second valparams))
    1906                             (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) )
    1907                (if (and (= 1 nreferences) (= 1 ncall-sites))
    1908                    (quick-put! plist 'contractable #t)
    1909                    (quick-put! plist 'inlinable #t) ) ) ) )
     1949         (cond (value
     1950                (let ((valparams (node-parameters value)))
     1951                  (when (and (eq? '##core#lambda (node-class value))
     1952                             (or (not (second valparams))
     1953                                 (every
     1954                                  (lambda (v) (get db v 'global))
     1955                                  (nth-value 0 (scan-free-variables value)) ) ) )
     1956                    (if (and (= 1 nreferences) (= 1 ncall-sites))
     1957                        (quick-put! plist 'contractable #t)
     1958                        (quick-put! plist 'inlinable #t) ) ) ) )
     1959               (local-value
     1960                ;; Make 'inlinable, if it is declared local and has a value
     1961                (let ((valparams (node-parameters local-value)))
     1962                  (when (eq? '##core#lambda (node-class local-value))
     1963                    (let-values (((vars hvars) (scan-free-variables local-value)))
     1964                      (when (and (get db sym 'global)
     1965                                 (pair? hvars))
     1966                        (quick-put! plist 'hidden-refs #t))
     1967                      (when (or (not (second valparams))
     1968                                (every
     1969                                 (lambda (v) (get db v 'global))
     1970                                 vars))
     1971                        (quick-put! plist 'inlinable #t) ) ) ) ) )
     1972               ((variable-mark sym '##compiler#inline-global) =>
     1973                (lambda (n)
     1974                  (when (node? n)
     1975                    (cond (assigned
     1976                           (debugging
     1977                            'i "global inline candidate was assigned and will not be inlined"
     1978                            sym)
     1979                           (mark-variable sym '##compiler#inline-global 'no))
     1980                          (else
     1981                           (let ((lparams (node-parameters n)))
     1982                             (put! db (first lparams) 'simple #t)
     1983                             (quick-put! plist 'inlinable #t)
     1984                             (quick-put! plist 'local-value n))))))))
    19101985
    19111986         ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only
     
    23232398                       no-bound-checks
    23242399                       unsafe
    2325                        (memq var always-bound)
    2326                        (get db var 'standard-binding)
    2327                        (get db var 'extended-binding) ) ]
    2328              [blockvar (memq var block-globals)] )
     2400                       (variable-mark var '##compiler#always-bound)
     2401                       (intrinsic? var))]
     2402             [blockvar (and (get db var 'assigned)
     2403                            (not (variable-visible? var)))])
    23292404        (when blockvar (set! fastrefs (add1 fastrefs)))
    23302405        (make-node
     
    24682543                           [safe (not (or no-bound-checks
    24692544                                          unsafe
    2470                                           (memq var always-bound)
    2471                                           (get db var 'standard-binding)
    2472                                           (get db var 'extended-binding) ) ) ]
    2473                            [blockvar (memq var block-globals)]
     2545                                          (variable-mark var '##compiler#always-bound)
     2546                                          (intrinsic? var)))]
     2547                           [blockvar (not (variable-visible? var))]
    24742548                           [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
    24752549                                     (eq? '##core#undefined cval) ) ] )
  • chicken/trunk/csc.scm

    r12086 r12301  
    175175    -block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile
    176176    -check-syntax -case-insensitive -benchmark-mode -shared -compile-syntax -no-lambda-info
    177     -lambda-lift -dynamic -disable-stack-overflow-checks -emit-debug-info
     177    -lambda-lift -dynamic -disable-stack-overflow-checks -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
     
    183183    -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue
    184184    -inline-limit -profile-name -disable-warning
    185     -require-static-extension
     185    -require-static-extension -emit-inline-file
    186186    -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size
    187187    -emit-import-library))
     
    203203    (-u "-unsafe")
    204204    (-j "-emit-import-library")
     205    (-n "-emit-inline-file")
    205206    (-b "-block") ) )
    206207
     
    367368    -accumulate-profile         executable emits profiling information in append mode
    368369    -profile-name FILENAME      name of the generated profile information file
    369     -emit-debug-info            emit additional debug-information
    370370
    371371  Optimization options:
    372372
    373     -O -O1 -O2 -O3 -optimize-level NUMBER
     373    -O -O1 -O2 -O3 -O4 -optimize-level NUMBER
    374374                                enable certain sets of optimization options
    375375    -optimize-leaf-routines     enable leaf routine optimization
    376376    -N  -no-usual-integrations  standard procedures may be redefined
    377377    -u  -unsafe                 disable safety checks
     378    -local                      assume globals are only modified in current file
    378379    -b  -block                  enable block-compilation
    379380    -disable-interrupts         disable interrupts in compiled code
    380381    -f  -fixnum-arithmetic      assume all numbers are fixnums
    381     -Ob  -benchmark-mode        equivalent to '-block -optimize-level 3
     382    -Ob  -benchmark-mode        equivalent to '-block -optimize-level 4
    382383                                 -debug-level 0 -fixnum-arithmetic -lambda-lift
    383                                  -disable-interrupts'
     384                                 -disable-interrupts -inline'
    384385    -lambda-lift                perform lambda-lifting
    385386    -unsafe-libraries           link with unsafe runtime system
     
    387388    -inline                     enable inlining
    388389    -inline-limit               set inlining threshold
     390    -inline-global              enable cross-module inlining
     391    -n -emit-inline-file FILENAME 
     392                                generate file with globally inlinable procedures
     393                                (implies -inline -local)
    389394
    390395  Configuration options:
     
    630635               [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]
    631636               [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]
     637               [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]
    632638               [(-d0) (set! rest (cons* "-debug-level" "0" rest))]
    633639               [(-d1) (set! rest (cons* "-debug-level" "1" rest))]
  • chicken/trunk/defaults.make

    r12021 r12301  
    9292endif
    9393
     94RUNTIME_LINKER_PATH ?= .
     95
    9496# commands
    9597
     
    316318endif
    317319CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use
    318 CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info
     320CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -inline -local
    319321CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
    320322CHICKEN_UNSAFE_OPTIONS = -unsafe -no-lambda-info
  • chicken/trunk/distribution/manifest

    r12117 r12301  
    99banner.scm
    1010batch-driver.scm
     11benchmarks/0.scm
     12benchmarks/cscbench.scm
     13benchmarks/nbody.scm
     14benchmarks/binarytrees.scm
    1115benchmarks/boyer.scm
    1216benchmarks/browse.scm
     
    110114csc.1
    111115csc.scm
    112 cscbench.scm
    113116csi.1
    114117csi.scm
  • chicken/trunk/eval.scm

    r12247 r12301  
    11841184  (let ((vector->list vector->list))
    11851185    (lambda (id comp? imp?)
    1186       (define (add-req id)
     1186      (define (add-req id syntax?)
    11871187        (when comp?
    1188           (##sys#hash-table-update!             ; assumes compiler has extras available - will break in the interpreter
     1188          (##sys#hash-table-update! ; assumes compiler has extras available - will break in the interpreter
    11891189           ##compiler#file-requirements
    1190            'syntax-requirements
     1190           (if syntax? 'dynamic/syntax 'dynamic)
    11911191           (cut lset-adjoin eq? <> id)
    11921192           (lambda () (list id)))))
     
    12281228                        (let ((s (assq 'syntax info))
    12291229                              (rr (assq 'require-at-runtime info)) )
    1230                           (when s (add-req id))
     1230                          (when s (add-req id #t))
    12311231                          (values
    12321232                           (impform
     
    12421242                           #t) ) )
    12431243                       (else
    1244                         (add-req id)
     1244                        (add-req id #f)
    12451245                        (values
    12461246                         (impform
  • chicken/trunk/library.scm

    r11989 r12301  
    32493249                   (if (##sys#fudge 32) " gchooks" "")
    32503250                   (if (##sys#fudge 35) " applyhook" "")
    3251                    (if (##sys#fudge 22) " lockts" "")
    32523251                   (if (##sys#fudge 37) " hostpcre" "")
    32533252                   (if (##sys#fudge 39) " cross" "") ) ) )
  • chicken/trunk/manual/Declarations

    r11646 r12301  
    4444should not be accessible from code in other compilation units or by
    4545{{eval}}. Access to toplevel bindings declared as block global is
    46 also more efficient.
     46also more efficient. {{(declare (hide))}} is equivalent to {{(declare (block))}}.
    4747
    4848
     
    142142
    143143
     144=== inline-global
     145
     146  [declaration specifier] (inline-global)
     147  [declaration specifier] (not inline-global)
     148  [declaration specifier] (inline-global IDENTIFIER ...)
     149  [declaration specifier] (not inline-global IDENTIFIER ...)
     150
     151Declare that then given toplevel procedures (or all) are subject to
     152cross-module inlining. Potentially inlinable procedures in the current
     153compilation unit will be written to an external
     154{{<source-filename>.inline}} file in the current directory. Globally
     155inlinable procedures from other compilation units referred to via
     156{{(declare (uses ...))}} or {{require-extension}} are loaded from
     157{{.inline}} files (if available in the current include path) and inlined
     158in the current compilation unit.
     159
     160
    144161=== inline-limit
    145162
    146163 [declaration specifier] (inline-limit THRESHOLD)
    147164
    148 Sets the maximum size of procedures which may potentially be inlined. The default threshold is {{10}}.
     165Sets the maximum size of procedures which may potentially be inlined. The default threshold is {{20}}.
    149166
    150167
     
    179196This declaration will only work if the source file is compiled
    180197with the {{csc}} compiler driver.
     198
     199
     200=== local
     201
     202 [declaration specifier] (local)
     203 [declaration specifier] (local SYMBOL ...)
     204
     205Declares that the listed (or all) toplevel variables defined in the
     206current compilation unit are not modified from code outside of this
     207compilation unit.
    181208
    182209
  • chicken/trunk/manual/Using the compiler

    r12086 r12301  
    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 -inline -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.
     
    5555     0          show database before lambda-lifting pass
    5656     L          show expressions after lambda-lifting
    57      M          show unit-information and syntax-/runtime-requirements
     57     M          show syntax-/runtime-requirements
    5858     1          show source expressions
    5959     2          show canonicalized expressions
     
    9696; -emit-import-library MODULE : Specifies that an import library named {{MODULE.import.scm}} for the named module should be generated (equivalent to using the {{emit-import-library}} declaration).
    9797
     98; -emit-inline-file FILENAME : Write procedures that can be globally inlined in internal form to {{FILENAME}}, if global inlining is enabled. Implies {{-inline -local}}.
     99
    98100; -explicit-use : Disables automatic use of the units {{library, eval}} and {{extras}}. Use this option if compiling a library unit instead of an application unit.
    99101
     
    120122; -inline : Enable procedure inlining for known procedures of a size below the threshold (which can be set through the {{-inline-limit}} option).
    121123
    122 ; -inline-limit THRESHOLD : Sets the maximum size of a potentially inlinable procedure. The default threshold is {{10}}.
     124; -inline-global : Enable cross-module inlining.
     125
     126; -inline-limit THRESHOLD : Sets the maximum size of a potentially inlinable procedure. The default threshold is {{20}}.
    123127
    124128; -keyword-style STYLE : Enables alternative keyword syntax, where {{STYLE}} may be either {{prefix}} (as in Common Lisp), {{suffix}} (as in DSSSL) or {{none}}. Any other value is ignored. The default is {{suffix}}.
     
    127131
    128132; -lambda-lift : Enable the optimization known as lambda-lifting.
     133
     134; -local : Assume toplevel variables defined in the current compilation unit are not externally modified.
    129135
    130136; -no-lambda-info : Don't emit additional information for each {{lambda}} expression (currently the argument-list, after alpha-conversion/renaming).
     
    144150     -optimize-level 1          is equivalent to -optimize-leaf-routines
    145151     -optimize-level 2          is currently the same as -optimize-level 1
    146      -optimize-level 3          is equivalent to -optimize-leaf-routines -unsafe
     152     -optimize-level 3          is equivalent to -optimize-leaf-routines -local -inline
     153     -optimize-level 4          is equivalent to -optimize-leaf-routines -local -inline -unsafe
    147154
    148155; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}.
  • chicken/trunk/optimizer.scm

    r12101 r12301  
    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! export-list inline-list not-inline-list
    37   unit-name insert-timer-checks used-units external-variables
     36  copy-node! variable-visible? mark-variable intrinsic?
     37  unit-name insert-timer-checks used-units external-variables hide-variable
    3838  debug-info-index debug-info-vector-name profile-info-vector-name
    3939  foreign-declarations emit-trace-info block-compilation line-number-database-size
    40   always-bound-to-procedure block-globals make-block-variable-literal block-variable-literal? block-variable-literal-name
    41   target-heap-size target-stack-size constant-declarations
     40  make-block-variable-literal block-variable-literal? block-variable-literal-name
     41  target-heap-size target-stack-size constant-declarations variable-mark
    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
     
    6060  topological-sort print-version print-usage initialize-analysis-database
    6161  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    62   units-used-by-default words-per-flonum rewrite
     62  units-used-by-default words-per-flonum rewrite inline-locally
    6363  parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6464  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
     
    120120       (scan node '()) ) )
    121121    (debugging 'o "safe globals" safe)
    122     (set! always-bound (append safe always-bound)) ) )
     122    (for-each (cut mark-variable <> '##compiler#always-bound) safe)))
    123123
    124124
     
    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)
     
    311312                                (list k (make-node '##core#undefined '() '())) ) )
    312313                             (walk-generic n class params subs)) ]
    313                         [(and lval (eq? '##core#lambda (node-class lval)))
     314                        [(and lval
     315                              (eq? '##core#lambda (node-class lval)))
    314316                         (let* ([lparams (node-parameters lval)]
    315317                                [llist (third lparams)] )
     
    318320                            (lambda (vars argc rest)
    319321                              (let ([fid (first lparams)])
    320                                 (cond [(and (test fid 'simple)
     322                                (cond [(and inline-locally
     323                                            (test fid 'simple)
    321324                                            (test var 'inlinable)
    322                                             (not (memq var not-inline-list))
    323                                             (or (memq var inline-list)
    324                                                 (< (fourth lparams) inline-max-size) ) )
    325                                        (debugging 'i "procedure inlinable" var fid (fourth lparams))
     325                                            (case (variable-mark var '##compiler#inline)
     326                                              ((yes) #t)
     327                                              ((no) #f)
     328                                              (else
     329                                               (< (fourth lparams) inline-max-size) ) ))
     330                                       (debugging
     331                                        'i
     332                                        (if (node? (variable-mark var '##compiler#inline-global))
     333                                            "procedure can be inlined (globally)"
     334                                            "procedure can be inlined")
     335                                        var fid (fourth lparams))
    326336                                       (check-signature var args llist)
    327337                                       (debugging 'o "inlining procedure" var)
     
    390400                    (make-node '##core#undefined '() '()) ]
    391401                   [(and (or (not (test var 'global))
    392                              block-compilation
    393                              (and export-list (not (memq var export-list)))
    394                              (memq var block-globals))
     402                             (not (variable-visible? var)))
    395403                         (not (test var 'references))
    396404                         (not (expression-has-side-effects? (first subs) db)) )
     
    445453
    446454    ;; Handle '(if (not ...) ...)':
    447     (if (test 'not 'standard-binding)
     455    (if (intrinsic? 'not)
    448456        (for-each
    449457         (lambda (site)
     
    486494    (for-each
    487495     (lambda (varname)
    488        (if (test varname 'standard-binding)
     496       (if (intrinsic? varname)
    489497           (for-each
    490498            (lambda (site)
     
    853861    ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...)
    854862    ((1) ; classargs = (<argc> <iop>)
    855      (and (test name 'standard-binding)
     863     (and (intrinsic? name)
    856864          (or (and (= (length callargs) (first classargs))
    857865                   (let ((arg1 (first callargs))
     
    871879     (and inline-substitutions-enabled
    872880          (= (length callargs) (first classargs))
    873           (or (test name 'extended-binding) (test name 'standard-binding))
     881          (intrinsic? name)
    874882          (or (third classargs) unsafe)
    875883          (let ([arg1 (first callargs)]
     
    889897     (and inline-substitutions-enabled
    890898          (null? callargs)
    891           (or (test name 'standard-binding) (test name 'extended-binding))
     899          (intrinsic? name)
    892900          (make-node '##core#call '(#t) (list cont (varnode (first classargs)))) ) )
    893901
     
    897905          unsafe
    898906          (= 2 (length callargs))
    899           (test name 'standard-binding)
     907          (intrinsic? name)
    900908          (make-node '##core#call (list #f (first classargs))
    901909                     (list (varnode (first classargs))
     
    909917     ;; - <numtype> may be #f
    910918     (and inline-substitutions-enabled
    911           (or (test name 'extended-binding)
    912               (test name 'standard-binding) )
     919          (intrinsic? name)
    913920          (= 1 (length callargs))
    914921          (let ((ntype (third classargs)))
     
    925932           inline-substitutions-enabled
    926933           (= 1 (length callargs))
    927            (test name 'standard-binding)
     934           (intrinsic? name)
    928935           (make-node '##core#call '(#t)
    929936                      (list cont
     
    937944          inline-substitutions-enabled
    938945          (= (length callargs) (first classargs))
    939           (or (test name 'standard-binding) (test name 'extended-binding))
     946          (intrinsic? name)
    940947          (make-node '##core#call '(#t)
    941948                     (list cont
     
    947954    ((8) ; classargs = (<proc> ...)
    948955     (and inline-substitutions-enabled
    949           (or (test name 'standard-binding)
    950               (test name 'extended-binding) )
     956          (intrinsic? name)
    951957          ((first classargs) db classargs cont callargs) ) )
    952958
     
    955961    ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
    956962     (and inline-substitutions-enabled
    957           (test name 'standard-binding)
     963          (intrinsic? name)
    958964          (if (< (length callargs) 2)
    959965              (make-node '##core#call '(#t) (list cont (qnode #t)))
     
    982988     (and inline-substitutions-enabled
    983989          (or (fourth classargs) unsafe)
    984           (test name 'standard-binding)
     990          (intrinsic? name)
    985991          (let ((n (length callargs)))
    986992            (and (< 0 n 3)
     
    9991005     (and inline-substitutions-enabled
    10001006          (or (third classargs) unsafe)
    1001           (or (test name 'standard-binding) (test name 'extended-binding))
     1007          (intrinsic? name)
    10021008          (let ([argc (first classargs)])
    10031009            (and (or (not argc)
     
    10121018    ((12) ; classargs = (<primitiveop> <safe> <maxargc>)
    10131019     (and inline-substitutions-enabled
    1014           (or (test name 'standard-binding) (test name 'extended-binding))
     1020          (intrinsic? name)
    10151021          (or (second classargs) unsafe)
    10161022          (let ((n (length callargs)))
     
    10251031    ((13) ; classargs = (<primitiveop> <safe>)
    10261032     (and inline-substitutions-enabled
    1027           (or (test name 'extended-binding) (test name 'standard-binding))
     1033          (intrinsic? name)
    10281034          (or (second classargs) unsafe)
    10291035          (let ((pname (first classargs)))
     
    10361042     (and inline-substitutions-enabled
    10371043          (= (second classargs) (length callargs))
    1038           (or (test name 'extended-binding)
    1039               (test name 'standard-binding) )
     1044          (intrinsic? name)
    10401045          (eq? number-type (first classargs))
    10411046          (or (fourth classargs) unsafe)
     
    10541059          (= 1 (length callargs))
    10551060          (or unsafe (fourth classargs))
    1056           (or (test name 'extended-binding)
    1057               (test name 'standard-binding) )
     1061          (intrinsic? name)
    10581062          (cond ((eq? number-type (first classargs))
    10591063                 (make-node '##core#call (list #t (third classargs))
     
    10751079       (and inline-substitutions-enabled
    10761080            (or (not argc) (= rargc argc))
    1077             (or (test name 'extended-binding) (test name 'standard-binding))
     1081            (intrinsic? name)
    10781082            (or (third classargs) unsafe)
    10791083            (make-node
     
    10921096     (and inline-substitutions-enabled
    10931097          (= (length callargs) (first classargs))
    1094           (or (test name 'extended-binding) (test name 'standard-binding))
     1098          (intrinsic? name)
    10951099          (make-node
    10961100           '##core#call '(#t)
     
    11061110     (and inline-substitutions-enabled
    11071111          (null? callargs)
    1108           (or (test name 'extended-binding) (test name 'standard-binding))
     1112          (intrinsic? name)
    11091113          (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) )
    11101114
     
    11161120    ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
    11171121     (and inline-substitutions-enabled
    1118           (or (test name 'standard-binding) (test name 'extended-binding))
     1122          (intrinsic? name)
    11191123          (let* ([id (first classargs)]
    11201124                 [fixop (if unsafe (third classargs) (second classargs))]
     
    11451149            inline-substitutions-enabled
    11461150            (= n (first classargs))
    1147             (or (test name 'standard-binding) (test name 'extended-binding))
     1151            (intrinsic? name)
    11481152            (make-node
    11491153             '##core#call '(#t)
     
    11631167    ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
    11641168     (and inline-substitutions-enabled
    1165           (or (test name 'standard-binding) (test name 'extended-binding))
     1169          (intrinsic? name)
    11661170          (let* ([id (first classargs)]
    11671171                 [words (fifth classargs)]
     
    11971201       (and inline-substitutions-enabled
    11981202            (= rargc argc)
    1199             (or (test name 'extended-binding) (test name 'standard-binding))
     1203            (intrinsic? name)
    12001204            (or (third classargs) unsafe)
    12011205            (make-node
     
    12181222    ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
    12191223     (and inline-substitutions-enabled
    1220           (or (test name 'standard-binding) (test name 'extended-binding))
     1224          (intrinsic? name)
    12211225          (let ([argc (first classargs)])
    12221226            (and (>= (length callargs) (first classargs))
     
    17201724           (let* ([name (car gn)]
    17211725                  [lval (get db name 'value)] )
    1722              (set! block-globals (cons name block-globals))
     1726             (hide-variable name)
    17231727             (decompose-lambda-list
    17241728              (first (node-parameters lval))
  • chicken/trunk/rules.make

    r12300 r12301  
    12481248        $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
    12491249
    1250 chicken.c: $(SRCDIR)chicken.scm $(SRCDIR)chicken-more-macros.scm $(SRCDIR)chicken-ffi-macros.scm $(SRCDIR)private-namespace.scm
     1250chicken.c: $(SRCDIR)chicken.scm $(SRCDIR)chicken-more-macros.scm $(SRCDIR)chicken-ffi-macros.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12511251        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    1252 support.c: $(SRCDIR)support.scm $(SRCDIR)banner.scm $(SRCDIR)private-namespace.scm
     1252support.c: $(SRCDIR)support.scm $(SRCDIR)banner.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12531253        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    1254 compiler.c: $(SRCDIR)compiler.scm $(SRCDIR)private-namespace.scm
     1254compiler.c: $(SRCDIR)compiler.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12551255        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    1256 optimizer.c: $(SRCDIR)optimizer.scm $(SRCDIR)private-namespace.scm
     1256optimizer.c: $(SRCDIR)optimizer.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12571257        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    1258 batch-driver.c: $(SRCDIR)batch-driver.scm $(SRCDIR)private-namespace.scm
     1258batch-driver.c: $(SRCDIR)batch-driver.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12591259        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    1260 c-platform.c: $(SRCDIR)c-platform.scm $(SRCDIR)private-namespace.scm
     1260c-platform.c: $(SRCDIR)c-platform.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12611261        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    1262 c-backend.c: $(SRCDIR)c-backend.scm $(SRCDIR)private-namespace.scm
     1262c-backend.c: $(SRCDIR)c-backend.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    12631263        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    12641264
     
    13881388          srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c posixunix.c posixwin.c regex.c \
    13891389          scheduler.c profiler.c stub.c expand.c $(COMPILER_OBJECTS_1:=.c)
     1390
     1391
     1392# benchmarking
     1393
     1394.PHONY: bench
     1395
     1396bench:
     1397        here=`pwd`; \
     1398        cd $(SRCDIR)benchmarks; \
     1399        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
     1400        csi -s cscbench.scm $(BENCHMARK_OPTIONS)
  • chicken/trunk/runtime.c

    r12021 r12301  
    148148#if defined(C_NO_HACKED_APPLY) && defined(C_HACKED_APPLY)
    149149# undef C_HACKED_APPLY
    150 #endif
    151 
    152 #ifdef C_LOCK_TOSPACE
    153 #include <sys/mman.h>
    154150#endif
    155151
     
    529525static C_word get_unbound_variable_value(C_word sym);
    530526static LF_LIST *find_module_handle(C_char *name);
    531 static void lock_tospace(int lock);
    532527
    533528static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
     
    658653    return 0;
    659654
    660 #ifdef C_LOCK_TOSPACE
    661   page_size = sysconf(_SC_PAGESIZE);
    662   assert(page_size > -1);
    663 #else
    664655  page_size = 0;
    665 #endif
    666656  stack_size = stack ? stack : DEFAULT_STACK_SIZE;
    667657  C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);
     
    10371027/* Align memory to page boundary */
    10381028
    1039 #ifndef C_LOCK_TOSPACE
    10401029static void *align_to_page(void *mem)
    10411030{
    10421031  return (void *)C_align((C_uword)mem);
    10431032}
    1044 #endif
     1033
    10451034
    10461035static C_byte *
     
    10481037{
    10491038  C_byte *p;
    1050 #ifdef C_LOCK_TOSPACE
    1051   p = (C_byte *)mmap (NULL, size, (PROT_READ | PROT_WRITE),
    1052                       (MAP_PRIVATE | MAP_ANON), -1, 0);
    1053   if (p != NULL && page_aligned) *page_aligned = p;
    1054 #else
    10551039  p = (C_byte *)C_malloc (size + page_size);
     1040
    10561041  if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
    1057 #endif
    1058 
    1059   /* . */
     1042
    10601043  return p;
    10611044}
     1045
    10621046
    10631047static void
    10641048heap_free (C_byte *ptr, size_t size)
    10651049{
    1066 #ifdef C_LOCK_TOSPACE
    1067   int r = munmap (ptr, size);
    1068   assert (r == 0);
    1069 #else
    10701050  C_free (ptr);
    1071 #endif
    1072   /* . */
    1073 }
     1051}
     1052
    10741053
    10751054static C_byte *
     
    10781057{
    10791058  C_byte *p;
    1080 #ifdef C_LOCK_TOSPACE
    1081   p = (C_byte *)mmap (NULL, new_size, (PROT_READ | PROT_WRITE),
    1082                       (MAP_PRIVATE | MAP_ANON), -1, 0);
    1083   if (ptr != NULL) {
    1084     memcpy (p, ptr, old_size);
    1085     heap_free (ptr, old_size);
    1086   }
    1087   if (p != NULL && page_aligned) *page_aligned = p;
    1088 #else
    10891059  p = (C_byte *)C_realloc (ptr, new_size + page_size);
     1060
    10901061  if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
    1091 #endif
    1092 
    1093   /* . */
     1062
    10941063  return p;
    10951064}
     1065
    10961066
    10971067/* Modify heap size at runtime: */
     
    11271097  tospace_limit = tospace_start + size;
    11281098  mutation_stack_top = mutation_stack_bottom;
    1129   lock_tospace(1);
    11301099
    11311100  if(reintern) initialize_symbol_table();
     
    27082677
    27092678
    2710 static void lock_tospace(int lock)
    2711 {
    2712 #ifdef C_LOCK_TOSPACE
    2713   int r;
    2714 
    2715   r = mprotect(tospace_start, (heap_size / 2),
    2716                lock ? PROT_NONE : (PROT_READ | PROT_WRITE));
    2717 
    2718   if(r == -1) panic(strerror(errno));
    2719 #endif
    2720 }
    2721 
    2722 
    27232679C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
    27242680{
     
    27462702  if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);
    27472703
    2748   lock_tospace(0);
    27492704  finalizers_checked = 0;
    27502705  C_restart_trampoline = (TRAMPOLINE)trampoline;
     
    30152970  if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, tgc);
    30162971
    3017   lock_tospace(1);
    30182972  /* Jump from the Empire State Building... */
    30192973  C_longjmp(C_restart, 1);
     
    31953149  size_t  new_heapspace_size;
    31963150
    3197   lock_tospace(0);
    3198 
    31993151  if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);
    32003152
     
    33233275  C_fromspace_top = new_tospace_top;
    33243276  C_fromspace_limit = new_tospace_limit;
    3325   lock_tospace(1);
    33263277
    33273278  if(gc_report_flag) {
     
    41934144    return C_fix(C_MOST_POSITIVE_FIXNUM);
    41944145
    4195   case C_fix(22):
    4196 #ifdef C_LOCK_TOSPACE
    4197     return C_SCHEME_TRUE;
    4198 #else
    4199     return C_SCHEME_FALSE;
    4200 #endif
     4146    /* 22 */
    42014147
    42024148  case C_fix(23):
  • chicken/trunk/setup-api.scm

    r11974 r12301  
    126126
    127127(define *major-version* (##sys#fudge 41))
    128 (define *default-eggdir* (conc "eggs/" *major-version*))
    129128
    130129(define *sudo* #f)
     
    136135(define *windows-shell* (or (eq? *windows* 'mingw32)
    137136                            (eq? *windows* 'msvc)))
    138 (define *debug* #f)
    139137
    140138(register-feature! 'chicken-setup)
     
    169167(define *ranlib-command* "ranlib")
    170168(define *csc-options* '())
    171 (define *dont-ask* #f)
    172169(define *base-directory* (current-directory))
    173170
     
    189186; be converted to a number, then it is kept as a string.
    190187
    191 (define (version-string->numbers string)
     188#;(define (version-string->numbers string)
    192189  (map (lambda (x) (or (string->number x) (->string x)))
    193190       (string-split string ".")))
  • chicken/trunk/support.scm

    r12109 r12301  
    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
    40   target-heap-size target-stack-size
     39  foreign-declarations block-compilation line-number-database-size node->sexpr sexpr->node
     40  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
    45   always-bound-to-procedure block-variable-literal? copy-node! valid-c-identifier? tree-copy copy-node-tree-and-rename
     45  block-variable-literal? copy-node! valid-c-identifier? tree-copy copy-node-tree-and-rename
    4646  direct-call-ids foreign-type-table first-analysis scan-sharp-greater-string
    47   make-block-variable-literal block-variable-literal-name
     47  make-block-variable-literal block-variable-literal-name variable-mark
    4848  expand-profile-lambda profile-lambda-list profile-lambda-index profile-info-vector-name
    4949  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments
     
    5454  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
    5555  string->c-identifier c-ify-string words words->bytes check-and-open-input-file close-checked-input-file fold-inner
    56   constant? basic-literal? source-info->string
     56  constant? basic-literal? source-info->string mark-variable load-inline-file
    5757  collapsable-literal? immediate? canonicalize-begin-body string->expr get get-all
    5858  put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode
     
    6767  default-optimization-iterations chop-separator chop-extension follow-without-loop
    6868  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    69   foreign-argument-conversion foreign-result-conversion final-foreign-type debugging export-list block-globals
    70   constant-declarations process-lambda-documentation big-fixnum?
    71   export-dump-hook
     69  foreign-argument-conversion foreign-result-conversion final-foreign-type debugging
     70  constant-declarations process-lambda-documentation big-fixnum? sort-symbols
     71  export-dump-hook intrinsic? node->sexpr emit-global-inline-file inline-max-size
    7272  make-random-name foreign-type-convert-result foreign-type-convert-argument process-custom-declaration)
    7373
     
    231231        (proc x (lambda (x2) (loop x2 (cons x done)))) ) ) )
    232232
     233(define (sort-symbols lst)
     234  (sort lst (lambda (s1 s2) (string<? (symbol->string s1) (symbol->string s2)))))
     235
    233236
    234237;;; Predicates on expressions and literals:
     
    321324;   symbol-keyed hash-tables here.
    322325
    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) )
     326(define initialize-analysis-database
     327  (let ((initial #t))
     328    (lambda (db)
     329      (for-each
     330       (lambda (s)
     331         (when initial
     332           (mark-variable s '##compiler#intrinsic 'standard))
     333         (when (memq s side-effecting-standard-bindings) (put! db s 'side-effecting #t))
     334         (when (memq s foldable-standard-bindings) (put! db s 'foldable #t)) )
     335       standard-bindings)
     336      (for-each
     337       (lambda (s)
     338         (when initial
     339           (mark-variable s '##compiler#intrinsic 'extended))
     340         (when (memq s foldable-extended-bindings) (put! db s 'foldable #t)) )
     341       extended-bindings)
     342      (set! initial #f))))
    338343
    339344(define (get db key prop)
     
    418423       (lambda (sym plist)
    419424         (let ([val #f]
     425               (lval #f)
    420426               [pval #f]
    421427               [csites '()]
     
    429435                       ((captured assigned boxed global contractable standard-binding foldable assigned-locally
    430436                                  side-effecting collapsable removable undefined replacing unused simple inlinable inline-export
    431                                   has-unused-parameters extended-binding customizable constant boxed-rest)
     437                                  has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
    432438                        (printf "\t~a" (cdr (assq (caar es) names))) )
    433439                       ((unknown)
     
    435441                       ((value)
    436442                        (unless (eq? val 'unknown) (set! val (cdar es))) )
     443                       ((local-value)
     444                        (unless (eq? val 'unknown) (set! lval (cdar es))) )
    437445                       ((potential-value)
    438446                        (set! pval (cdar es)) )
     
    448456             (cond [(and val (not (eq? val 'unknown)))
    449457                    (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
    450                    [(and pval (not (eq? pval 'unknown)))
     458                   [(and lval (not (eq? val 'unknown)))
     459                    (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ]
     460                   [(and pval (not (eq? val 'unknown)))
    451461                    (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
    452462             (when (pair? refs) (printf "\trefs=~s" (length refs)))
     
    532542                  (make-node
    533543                   '##core#call
    534                    (list (cond [(memq name always-bound-to-procedure)
     544                   (list (cond [(variable-mark name '##compiler#always-bound-to-procedure)
    535545                                (set! count (add1 count))
    536546                                #t]
     
    655665      (##sys#setslot to i (##sys#slot from i)) ) ) )
    656666
     667(define (node->sexpr n)
     668  (let walk ((n n))
     669    `(,(node-class n)
     670      ,(node-parameters n)
     671      ,@(map walk (node-subexpressions n)))))
     672
     673(define (sexpr->node x)
     674  (let walk ((x x))
     675    (make-node (car x) (cadr x) (map walk (cddr x)))))
     676
     677(define (emit-global-inline-file filename db)
     678  (let ((lst '()))
     679    (with-output-to-file filename
     680      (lambda ()
     681        (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
     682               source-filename "\n")
     683        (##sys#hash-table-for-each
     684         (lambda (sym plist)
     685           (when (variable-visible? sym)
     686             (and-let* ((val (assq 'local-value plist))
     687                        ((not (node? (variable-mark sym '##compiler#inline-global))))
     688                        ((let ((val (assq 'value plist)))
     689                           (or (not val)
     690                               (not (eq? 'unknown (cdr val))))))
     691                        ((assq 'inlinable plist))
     692                        (lparams (node-parameters (cdr val)))
     693                        ((get db (first lparams) 'simple))
     694                        ((not (get db sym 'hidden-refs)))
     695                        ((case (variable-mark sym '##compiler#inline)
     696                           ((yes) #t)
     697                           ((no) #f)
     698                           (else
     699                            (< (fourth lparams) inline-max-size) ) ) ) )
     700               (set! lst (cons sym lst))
     701               (pp (list sym (node->sexpr (cdr val))))
     702               (newline))))
     703         db)
     704        (print "; END OF FILE")))
     705    (when (and (pair? lst)
     706               (debugging 'i "the following procedures can be globally inlined:"))
     707      (for-each (cut print "  " <>) (sort-symbols lst)))))
     708
     709(define (load-inline-file fname)
     710  (with-input-from-file fname
     711    (lambda ()
     712      (let loop ()
     713        (let ((x (read)))
     714          (unless (eof-object? x)
     715            (mark-variable
     716             (car x)
     717             '##compiler#inline-global
     718             (sexpr->node (cadr x)))
     719            (loop)))))))
     720
    657721
    658722;;; Match node-structure with pattern:
     
    736800   db) )
    737801
    738 (define (check-global-exports db)
    739   (when export-list
    740     (let ([exps export-list])
    741       (##sys#hash-table-for-each
    742        (lambda (sym plist)
    743          (when (and (memq sym exps) (not (assq 'assigned plist)))
    744            (compiler-warning 'var "exported global variable `~S' is used but not defined" sym) )
    745          (set! exps (delete sym exps eq?)) )
    746        db)
    747       (for-each (cut compiler-warning 'var "exported global variable `~S' is not defined" <>) exps) ) ) )
    748 
    749802
    750803;;; change hook function to hide non-exported module bindings
     
    754807    (when (and (not val) (not exp))
    755808      (debugging 'o "hiding nonexported module bindings" sym)
    756       (set! block-globals (cons sym block-globals)) ) ) )
    757 
     809      (hide-variable sym))))
    758810
    759811
     
    10531105
    10541106(define (scan-free-variables node)
    1055   (let ((vars '()))
     1107  (let ((vars '())
     1108        (hvars '()))
    10561109
    10571110    (define (walk n e)
     
    10621115          ((##core#variable)
    10631116           (let ((var (first params)))
    1064              (unless (memq var e) (set! vars (lset-adjoin eq? vars var))) ) )
     1117             (unless (memq var e)
     1118               (set! vars (lset-adjoin eq? vars var))
     1119               (unless (variable-visible? var)
     1120                 (set! hvars (lset-adjoin eq? hvars var))))))
    10651121          ((set!)
    10661122           (let ((var (first params)))
     
    10811137
    10821138    (walk node '())
    1083     vars) )
     1139    (values vars hvars) ) )
    10841140
    10851141
     
    12131269    -no-usual-integrations      standard procedures may be redefined
    12141270    -unsafe                     disable safety checks
     1271    -local                      assume globals are only modified in current file
    12151272    -block                      enable block-compilation
    12161273    -disable-interrupts         disable interrupts in compiled code
    12171274    -fixnum-arithmetic          assume all numbers are fixnums
    1218     -benchmark-mode             fixnum mode, no interrupts and opt.-level 3
     1275    -benchmark-mode             equivalent to '-block -optimize-level 4
     1276                                 -debug-level 0 -fixnum-arithmetic -lambda-lift
     1277                                 -disable-interrupts -inline'
    12191278    -disable-stack-overflow-checks 
    12201279                                disables detection of stack-overflows.
    12211280    -inline                     enable inlining
    12221281    -inline-limit               set inlining threshold
     1282    -inline-global              enable cross-module inlining
     1283    -emit-inline-file FILENAME  generate file with globally inlinable procedures
     1284                                (implies -inline -local)
    12231285
    12241286  Configuration options:
     
    14231485       (or (fx> x 1073741823)
    14241486           (fx< x -1073741824) ) ) )
     1487
     1488
     1489;;; symbol visibility and other global variable properties
     1490
     1491(define (hide-variable sym)
     1492  (mark-variable sym '##compiler#visibility 'hidden))
     1493
     1494(define (export-variable sym)
     1495  (mark-variable sym '##compiler#visibility 'exported))
     1496
     1497(define (variable-visible? sym)
     1498  (let ((p (##sys#get sym '##compiler#visibility)))
     1499    (case p
     1500      ((hidden) #f)
     1501      ((exported) #t)
     1502      (else (not block-compilation)))))
     1503
     1504(define (mark-variable var mark #!optional (val #t))
     1505  (##sys#put! var mark val) )
     1506
     1507(define (variable-mark var mark)
     1508  (##sys#get var mark) )
     1509
     1510(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
  • chicken/trunk/tweaks.scm

    r8361 r12301  
    4343
    4444
     45(define-inline (node? x) (##sys#structure? x 'node))
    4546(define-inline (make-node c p s) (##sys#make-structure 'node c p s))
    4647(define-inline (node-class n) (##sys#slot n 1))
    4748(define-inline (node-parameters n) (##sys#slot n 2))
    4849(define-inline (node-subexpressions n) (##sys#slot n 3))
     50
     51(define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic))
     52
     53(define-inline (mark-variable var mark #!optional (val #t))
     54  (##sys#put! var mark val) )
     55
     56(define-inline (variable-mark var mark)
     57  (##sys#get var mark) )
Note: See TracChangeset for help on using the changeset viewer.