Changeset 15323 in project


Ignore:
Timestamp:
08/05/09 12:39:20 (10 years ago)
Author:
felix winkelmann
Message:

more intelligent inlining; standard-extension procedure in setup-api

Location:
chicken/branches/inlining
Files:
24 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/inlining/README

    r15262 r15323  
    44  (c) 2008-2009, The Chicken Team
    55
    6   version 4.1.1
     6  version 4.1.2-ii
    77
    88
  • chicken/branches/inlining/TODO

    r15270 r15323  
    66
    77** compiler
     8*** inlining breaks (benchmarks/boyer):
     9    either we walk the inlined expr and have missing analysis results for renamed
     10    vars or we miss required copy-propagations (possible solution: mark renamed
     11    vars and add checks to all places where a non-existant analysis property may
     12    trigger an optimization)
    813*** pre-optimization
    914**** changes call-sites and makes them invalid for later pre-optimization
     
    7479
    7580** compiler
     81*** test inlining with compiler modules
    7682*** (csc) generate object-files in /tmp (or TMPDIR)?
    77 *** try to improve inlining (single calls should be inlinable)
    78     Currently only "simple" procedures are inlined, possibly because accessed variables
    79     may not be lexically visible but access to globals should ok, or not?
    8083*** option ("-M") to compile file as unnamed module (importing scheme + chicken)
    8184
     
    105108*** extend scripts/guess-platforms.sh for more platforms
    106109
    107 ** documentation
    108 *** document qs, normalize-pathname
    109 
    110110** scrutiny
    111111*** allow giving toplevel procedure names to `scrutinize' option?
     
    162162*** initialized to trap function on set!/define, which does fixup
    163163*** would also allow inline-caching hacks
     164
     165
     166* 4.0.9 benchmark results
     167
     168(c)2008-2009 The Chicken Team
     169(c)2000-2007 Felix L. Winkelmann
     170Version 4.0.9 - SVN rev. 15246
     171linux-unix-gnu-x86 [ manyargs dload ptables applyhook ]
     172compiled 2009-07-23 on x (Linux)
     173
     174
     175CC:
     176Using built-in specs.
     177Target: i486-linux-gnu
     178Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.3-5ubuntu4' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --with-tune=generic --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu
     179Thread model: posix
     180gcc version 4.3.3 (Ubuntu 4.3.3-5ubuntu4)
     181
     182CFLAGS:
     183-fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H -Os -fomit-frame-pointer -I/home/felix/include
     184
     185Running benchmarks ...
     186
     187  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped)
     188
     189                     (runtime)                                  (code size)
     190
     191                     base       fast     unsafe        max      base      fast    unsafe       max
     192                  ----------------------------------------------------------------------------------
     1930                   0.000      0.000      0.000      0.000     1013k     1013k      902k      902k
     194binarytrees         0.076      0.081      0.082      0.004     1021k     1021k      910k      910k
     195boyer               0.053      0.052      0.053      0.004     1045k     1045k      934k      934k
     196browse              0.088      0.086      0.073      0.072     1029k     1029k      918k      918k
     197conform             0.108      0.072      0.072      0.064     1089k     1085k      954k      954k
     198cpstak              0.272      0.250      0.208      0.169     1013k     1013k      906k      906k
     199ctak                0.124      0.128      0.110      0.106     1017k     1017k      906k      906k
     200dderiv              0.106      0.089      0.082      0.076     1021k     1021k      910k      910k
     201deriv               0.078      0.081      0.068      0.078     1017k     1017k      910k      906k
     202destructive         0.069      0.076      0.062      0.070     1017k     1017k      910k      906k
     203div-iter            0.002      0.021      0.018      0.021     1013k     1013k      906k      906k
     204div-rec             0.046      0.052      0.036      0.057     1013k     1013k      906k      906k
     205dynamic             0.074      0.062      0.078      0.056     1293k     1285k     1078k     1078k
     206earley              0.029      0.018      0.028      0.028     1073k     1065k      950k      950k
     207fft                 0.046      0.032      0.028                1025k     1025k      914k      950k
     208fib                 0.014      0.148      0.109      0.033     1013k     1013k      902k      902k
     209fibc                1.464      0.854      0.736      0.572     1017k     1013k      906k      906k
     210fprint              0.121      0.124      0.112      0.117     1017k     1017k      906k      906k
     211fread               0.572      0.056      0.524      0.526     1013k     1013k      902k      902k
     212hanoi               0.414      0.392      0.341      0.145     1013k     1013k      906k      902k
     213lattice             5.228      5.109      4.156      4.168     1029k     1029k      918k      918k
     214maze                0.136      0.112      0.085                1089k     1077k      946k      918k
     215nbody               2.414      1.610      0.528                1045k     1033k      914k      918k
     216nqueens             0.068      0.064      0.029      0.021     1017k     1017k      906k      906k
     217puzzle              0.052      0.056      0.028      0.026     1037k     1037k      922k      918k
     218scheme              0.025      0.014      0.010      0.010     1165k     1165k      998k      998k
     219tak                 0.273      0.268      0.217      0.056     1013k     1013k      906k      902k
     220takl                0.142      0.148      0.057      0.073     1017k     1017k      906k      906k
     221takr                0.438      0.430      0.301      0.246     1125k     1125k      998k      998k
     222traverse            0.224      0.150      0.012      0.112     1037k     1033k      914k      914k
     223travinit            0.033      0.033      0.026      0.018     1037k     1033k      910k      910k
     224triangl             0.546      0.553      0.042      0.377     1017k     1017k      906k      906k
     225
     226TOTAL              13.488     11.733      8.805      7.385
  • chicken/branches/inlining/batch-driver.scm

    r15246 r15323  
    445445
    446446             (when (and (pair? compiler-syntax-statistics)
    447                         (debugging 'x "applied compiler syntax:"))
     447                        (debugging 'o "applied compiler syntax:"))
    448448               (for-each
    449449                (lambda (cs) (printf "  ~a\t\t~a~%" (car cs) (cdr cs)))
  • chicken/branches/inlining/benchmarks/cscbench.scm

    r15050 r15323  
    11;;;; cscbench - Compile and run benchmarks - felix -*- Scheme -*-
    22;
    3 ; - Usage: cscbench [-debug] [-cc=<path>] OPTION ...
     3; - Usage: cscbench [-debug] [-cc=<path>] [-csc=<path>] [-chicken=<path>] OPTION ...
    44
    55(require-extension srfi-1 utils posix regex)
     
    77(define ignored-files '("cscbench.scm" "cscbench.scm~"))
    88(define flonum-files '("fft" "maze" "nbody"))
    9 (define cc "`csc -cc-name`")
     9(define cc "gcc")
    1010(define chicken "chicken")
     11(define csc "csc")
    1112
    1213(define (abort-run) #f)
     
    5253
    5354(define (compile-and-run file decls options coptions unsafe)
    54   (system* "~A ~A -quiet -no-warnings -heap-size 16m -output-file tmpfile.c ~A ~A"
     55  (with-output-to-file "bench.log" (cut print "\n==================" file) append:)
     56  (system* "~A ~A -quiet -no-warnings -heap-size 16m -output-file tmpfile.c -debug xop ~A ~A 2>&1 >>bench.log"
    5557           chicken file decls options)
    5658  (system* "~a ~a -s -I.. tmpfile.c -o tmpfile ../lib~achicken.a -lm"
     
    8183
    8284(define (main options)
    83   (when (and (pair? options) (string=? "-debug" (car options)))
    84     (set! options (cdr options))
    85     (set! system*
    86       (let ([system* system*])
    87         (lambda args
    88           (let ([s (apply sprintf args)])
    89             (printf "system: ~A~%" s)
    90             (system* s) ) ) ) ) )
    91   (and-let* ([(pair? options)]
    92              [m (string-match "-cc=(.*)" (car options))] )
    93     (set! options (cdr options))
    94     (set! cc (second m)) )
     85  (call/cc
     86   (lambda (return)
     87     (let loop ((opts options))
     88       (cond ((null? opts) (return #f))
     89             ((string=? "-debug" (car opts))
     90              (set! system*
     91                (let ([system* system*])
     92                  (lambda args
     93                    (let ([s (apply sprintf args)])
     94                      (printf "system: ~A~%" s)
     95                      (system* s) ) ) ) ) )
     96             ((string-match "-cc=(.*)" (car opts)) =>
     97              (lambda (m) (set! cc (second m))))
     98             ((string-match "-csc=(.*)" (car opts)) =>
     99              (lambda (m) (set! csc (second m))))
     100             ((string-match "-chicken=(.*)" (car opts)) =>
     101              (lambda (m) (set! chicken (second m))))
     102             (else
     103              (set! options opts)
     104              (return #f)))
     105       (loop (cdr opts)))))
     106  (set! cc (string-trim-both (with-input-from-pipe "csc -cc-name" read-line)))
    95107  (delete-file* "tmpfile.scm")
     108  (delete-file* "bench.log")
    96109  (system* "~A -version" chicken)
    97110  (dflush "\nCC:\n")
     
    100113      (system* "~A -v" cc) )
    101114  (dflush "\nCFLAGS:\n")
    102   (system* "echo `csc -cflags`")
    103   (display "\nRunning benchmarks ...\n\n  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped)\n")
     115  (system* "echo `~a -cflags`" csc)
     116  (display "\nRunning benchmarks ...\n\n  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped,\n")
     117  (display "   compiler log will be written to \"bench.log\")\n")
    104118  (display "\n                     (runtime)                                  (code size)\n")
    105119  (display "\n                     base       fast     unsafe        max      base      fast    unsafe       max")
  • chicken/branches/inlining/buildversion

    r15262 r15323  
    1 4.1.1
     14.1.2-ii
  • chicken/branches/inlining/c-platform.scm

    r15246 r15323  
    953953                              (and (not (get db var 'references))
    954954                                   (not (get db var 'assigned))
     955                                   (not (get db var 'inline-transient))
    955956                                   (make-node
    956957                                    '##core#call '(#t)
  • chicken/branches/inlining/compiler-namespace.scm

    r15246 r15323  
    167167 get-line
    168168 get-line-2
     169 get-list
    169170 hide-variable
    170171 immediate?
  • chicken/branches/inlining/compiler.scm

    r15276 r15323  
    240240;   constant -> <boolean>                    If true: variable has fixed value
    241241;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
     242;   inline-transient -> <boolean>            If true: was introduced during inlining
    242243;
    243244; <lambda-id>:
     
    252253;   explicit-rest -> <boolean>               If true: procedure is called with consed rest list
    253254;   captured-variables -> (<var> ...)        List of closed over variables
     255;   inline-target -> <boolean>               If true: was target of an inlining operation
    254256
    255257
     
    19711973                          (else
    19721974                           (let ((lparams (node-parameters n)))
    1973                              (put! db (first lparams) 'simple #t) ;XXX hack
    19741975                             (quick-put! plist 'inlinable #t)
    19751976                             (quick-put! plist 'local-value n))))))))
  • chicken/branches/inlining/defaults.make

    r15076 r15323  
    280280# Scheme compiler flags
    281281
    282 CHICKEN_OPTIONS = -no-trace -optimize-level 2 -include-path . -include-path $(SRCDIR)
     282CHICKEN_OPTIONS = -optimize-level 2 -include-path . -include-path $(SRCDIR)
    283283ifdef DEBUGBUILD
    284284CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db
    285285endif
    286 CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use
     286CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use -no-trace
    287287CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -inline -local
    288288CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
     
    290290CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
    291291CHICKEN_IMPORT_LIBRARY_OPTIONS = $(CHICKEN_DYNAMIC_OPTIONS)
     292
     293ifndef DEBUGBUILD
     294CHICKEN_PROGRAM_OPTIONS += -no-trace
     295CHICKEN_COMPILER_OPTIONS += -no-trace
     296endif
    292297
    293298# targets
  • chicken/branches/inlining/eval.scm

    r15203 r15323  
    3232  (hide ##sys#split-at-separator
    3333        ##sys#r4rs-environment ##sys#r5rs-environment
    34         ##sys#interaction-environment pds pdss pxss) )
     34        ##sys#interaction-environment pds pdss pxss)
     35  (not inline ##sys#repl-eval-hook ##sys#repl-read-hook ##sys#repl-print-hook
     36       ##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
     37       ##sys#syntax-error-hook))
    3538
    3639(define (d arg1 . more)
  • chicken/branches/inlining/expand.scm

    r15171 r15323  
    3232        macro-alias module-indirect-exports
    3333        d dd dm dc map-se merge-se
    34         lookup check-for-redef) )
     34        lookup check-for-redef)
     35  (not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook
     36       ##sys#alias-global-hook ##sys#toplevel-definition-hook))
     37
    3538
    3639
     
    14071410        (else #f)))
    14081411
    1409 (declare (not inline ##sys#toplevel-definition-hook))
    1410 
    14111412(define (##sys#toplevel-definition-hook sym mod exp val) #f)
    14121413
  • chicken/branches/inlining/library.scm

    r15119 r15323  
    3636        ##sys#print-exit
    3737        ##sys#format-here-doc-warning)
     38  (not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook
     39       ##sys#default-read-info-hook ##sys#infix-list-hook ##sys#sharp-number-hook
     40       ##sys#user-print-hook ##sys#user-interrupt-hook ##sys#step-hook)
    3841  (foreign-declare #<<EOF
    3942#include <string.h>
  • chicken/branches/inlining/lolevel.scm

    r15169 r15323  
    3636   ##sys#check-generic-structure
    3737   ##sys#check-generic-vector )
     38  (not inline ipc-hook-0 ##sys#invalid-procedure-call-hook)
    3839  (foreign-declare #<<EOF
    3940#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
  • chicken/branches/inlining/manual/Extensions

    r15000 r15323  
    151151Similar to {{install-program}}, but additionally changes the file permissions of all
    152152files in {{FILELIST}} to executable (for installing shell-scripts).
     153
     154==== standard-extension
     155
     156 [procedure] (standard-extension ID VERSION)
     157
     158A convenience procedure that combines the compilation and installation of
     159a simple single-file extension. This is roughly equivalent to:
     160
     161  (compile -s -O2 -d1 ID.scm -j ID)
     162  (compile -c -O2 -d1 ID.scm -j ID -unit ID)
     163  (compile -s -O2 -d0 ID.import.scm)
     164 
     165  (install-extension
     166   'ID
     167   '("ID.o" "ID.so" "ID.import.so")
     168   '((version 1.0)
     169     (static "ID.o")))
    153170
    154171
  • chicken/branches/inlining/manual/The User's Manual

    r15262 r15323  
    77</nowiki>
    88
    9 This is the manual for Chicken Scheme, version 4.1.1
     9This is the manual for Chicken Scheme, version 4.1.2-ii
    1010
    1111; [[Getting started]] : What is CHICKEN and how do I use it?
  • chicken/branches/inlining/optimizer.scm

    r15246 r15323  
    2626
    2727
    28 (declare (unit optimizer))
     28(declare
     29  (unit optimizer)
     30  (not inline ##sys#compiler-syntax-hook) )
    2931
    3032
     
    134136          n) )
    135137
    136     (define (walk n)
     138    (define (walk n fid)
    137139      (if (memq n broken-constant-nodes)
    138140          n
    139141          (simplify
    140142           (let* ((odirty dirty)
    141                   (n1 (walk1 n))
     143                  (n1 (walk1 n fid))
    142144                  (subs (node-subexpressions n1)) )
    143145             (case (node-class n1)
     
    149151                       (walk (if (node-value (car subs))
    150152                                 (cadr subs)
    151                                  (caddr subs) ) ) )
     153                                 (caddr subs) )
     154                             fid) )
    152155                      (else n1) ) )
    153156
     
    177180               (else n1) ) ) ) ) )
    178181
    179     (define (walk1 n)
     182    (define (walk1 n fid)
    180183      (let ((subs (node-subexpressions n))
    181184            (params (node-parameters n))
     
    204207                    (touch)
    205208                    (set! removed-lets (add1 removed-lets))
    206                     (walk (second subs)) ]
    207                    [else (make-node 'let params (map walk subs))] ) ) )
     209                    (walk (second subs) fid) ]
     210                   [else (make-node 'let params (map (cut walk <> fid) subs))] ) ) )
    208211
    209212          ((##core#lambda)
    210            (let ([llist (third params)])
    211              (cond [(test (first params) 'has-unused-parameters)
     213           (let ((llist (third params))
     214                 (id (first params)))
     215             (cond [(test id 'has-unused-parameters)
    212216                    (decompose-lambda-list
    213217                     llist
     
    219223                          '##core#lambda
    220224                          (list (first params) (second params)
    221                                 (cond [(and rest (test (first params) 'explicit-rest))
     225                                (cond [(and rest (test id 'explicit-rest))
    222226                                       (debugging 'o "merged explicitly consed rest parameter" rest)
    223227                                       (build-lambda-list used (add1 argc) #f) ]
    224228                                      [else (build-lambda-list used argc rest)] )
    225229                                (fourth params) )
    226                           (list (walk (first subs))) ) ) ) ) ]
    227                    [(test (first params) 'explicit-rest)
     230                          (list (walk (first subs) id)) ) ) ) ) ]
     231                   [(test id 'explicit-rest)
    228232                    (decompose-lambda-list
    229233                     llist
     
    237241                              (build-lambda-list vars (add1 argc) #f)
    238242                              (fourth params) )
    239                         (list (walk (first subs))) ) ) ) ]
    240                    [else (walk-generic n class params subs)] ) ) )
     243                        (list (walk (first subs) id)) ) ) ) ]
     244                   [else (walk-generic n class params subs id)] ) ) )
    241245
    242246          ((##core#call)
     
    257261                           (debugging 'o "contracted procedure" var)
    258262                           (touch)
    259                            (walk (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f)) ) ]
     263                           (when fid (put! db fid 'inline-target #t))
     264                           (walk
     265                            (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
     266                            fid) ) ]
    260267                        [(memq var constant-declarations)
    261268                         (or (and-let* ((k (car args))
     
    273280                                '##core#call '(#t)
    274281                                (list k (make-node '##core#undefined '() '())) ) )
    275                              (walk-generic n class params subs)) ]
     282                             (walk-generic n class params subs fid)) ]
    276283                        [(and lval
    277284                              (eq? '##core#lambda (node-class lval)))
     
    281288                            llist
    282289                            (lambda (vars argc rest)
    283                               (let ([fid (first lparams)])
     290                              (let ([ifid (first lparams)])
    284291                                (cond [(and inline-locally
    285                                             (test fid 'simple)
    286292                                            (test var 'inlinable)
     293                                            (not (test (first lparams) 'inline-target)) ; inlinable procedure has changed
    287294                                            (case (variable-mark var '##compiler#inline)
    288295                                              ((yes) #t)
     
    293300                                        'i
    294301                                        (if (node? (variable-mark var '##compiler#inline-global))
    295                                             "procedure can be inlined (globally)"
    296                                             "procedure can be inlined")
    297                                         var fid (fourth lparams))
     302                                            "global inlining"
     303                                            "inlining")
     304                                        var ifid (fourth lparams))
     305                                       (when fid (put! db fid 'inline-target #t))
    298306                                       (check-signature var args llist)
    299307                                       (debugging 'o "inlining procedure" var)
    300308                                       (touch)
    301                                        (walk (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t)) ]
    302                                       [(test fid 'has-unused-parameters)
     309                                       (walk
     310                                        (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
     311                                        fid) ]
     312                                      [(test ifid 'has-unused-parameters)
    303313                                       (if (< (length args) argc) ; Expression was already optimized (should this happen?)
    304                                            (walk-generic n class params subs)
     314                                           (walk-generic n class params subs fid)
    305315                                           (let loop ((vars vars) (argc argc) (args args) (used '()))
    306316                                             (cond [(or (null? vars) (zero? argc))
     
    309319                                                     '##core#call
    310320                                                     params
    311                                                      (map walk (cons fun (append-reverse used args))) ) ]
     321                                                     (map (cut walk <> fid) (cons fun (append-reverse used args))) ) ]
    312322                                                   [(test (car vars) 'unused)
    313323                                                    (touch)
     
    319329                                                         'let
    320330                                                         (list (gensym 't))
    321                                                          (list (walk (car args))
     331                                                         (list (walk (car args) fid)
    322332                                                               (loop (cdr vars) (sub1 argc) (cdr args) used) ) )
    323333                                                        (loop (cdr vars) (sub1 argc) (cdr args) used) ) ]
     
    326336                                                               (cdr args)
    327337                                                               (cons (car args) used) ) ] ) ) ) ]
    328                                       [(and (test fid 'explicit-rest)
     338                                      [(and (test ifid 'explicit-rest)
    329339                                            (not (memq n rest-consers)) ) ; make sure we haven't inlined rest-list already
    330340                                       (let ([n (llist-length llist)])
    331341                                         (if (< (length args) n)
    332                                              (walk-generic n class params subs)
     342                                             (walk-generic n class params subs fid)
    333343                                             (begin
    334344                                               (debugging 'o "consed rest parameter at call site" var n)
     
    337347                                                            '##core#call
    338348                                                            params
    339                                                             (map walk
     349                                                            (map (cut walk <> fid)
    340350                                                                 (cons fun
    341351                                                                       (append
     
    350360                                                   (set! rest-consers (cons n2 rest-consers))
    351361                                                   n2) ) ) ) ) ]
    352                                       [else (walk-generic n class params subs)] ) ) ) ) ) ]
    353                         [else (walk-generic n class params subs)] ) ) ]
     362                                      [else (walk-generic n class params subs fid)] ) ) ) ) ) ]
     363                        [else (walk-generic n class params subs fid)] ) ) ]
    354364               [(##core#lambda)
    355365                (if (first params)
    356                     (walk-generic n class params subs)
    357                     (make-node '##core#call (cons #t (cdr params)) (map walk subs)) ) ]
    358                [else (walk-generic n class params subs)] ) ) )
     366                    (walk-generic n class params subs fid)
     367                    (make-node '##core#call (cons #t (cdr params)) (map (cut walk <> fid) subs)) ) ]
     368               [else (walk-generic n class params subs fid)] ) ) )
    359369
    360370          ((set!)
     
    365375                   [(and (or (not (test var 'global))
    366376                             (not (variable-visible? var)))
     377                         (not (test var 'inline-transient))
    367378                         (not (test var 'references))
    368379                         (not (expression-has-side-effects? (first subs) db)) )
     
    370381                    (debugging 'o "removed side-effect free assignment to unused variable" var)
    371382                    (make-node '##core#undefined '() '()) ]
    372                    [else (make-node 'set! params (list (walk (car subs))))] ) ) )
    373 
    374           (else (walk-generic n class params subs)) ) ) )
     383                   [else (make-node 'set! params (list (walk (car subs) fid)))] ) ) )
     384
     385          (else (walk-generic n class params subs fid)) ) ) )
    375386   
    376     (define (walk-generic n class params subs)
    377       (let ((subs2 (map walk subs)))
     387    (define (walk-generic n class params subs fid)
     388      (let ((subs2 (map (cut walk <> fid) subs)))
    378389        (if (every eq? subs subs2)
    379390            n
     
    385396          (debugging 'p "traversal phase...")
    386397          (set! simplified-ops '())
    387           (let ((node2 (walk node)))
     398          (let ((node2 (walk node #f)))
    388399            (when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
    389400            (when (and (pair? simplified-ops) (debugging 'o "  call simplifications:"))
     
    424435                  (kont (first (node-parameters (second subs))))
    425436                  (lnode (and (not (test kont 'unknown)) (test kont 'value)))
    426                   (krefs (test kont 'references)) )
     437                  (krefs (get-list db kont 'references)) )
    427438             ;; Call-site has one argument and a known continuation (which is a ##core#lambda)
    428439             ;;  that has only one use:
    429              (if (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
    430                       (eq? '##core#lambda (node-class lnode)) )
    431                 (let* ((llist (third (node-parameters lnode)))
    432                         (body (first (node-subexpressions lnode)))
    433                         (bodysubs (node-subexpressions body)) )
    434                    ;; Continuation has one parameter?
    435                    (if (and (proper-list? llist) (null? (cdr llist)))
    436                        (let* ((var (car llist))
    437                               (refs (test var 'references)) )
    438                         ;; Parameter is only used once?
    439                         (if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
    440                              ;; Continuation contains an 'if' node?
    441                              (let ((iftest (first (node-subexpressions body))))
    442                                ;; Parameter is used only once and is the test-argument?
    443                                (if (and (eq? '##core#variable (node-class iftest))
    444                                         (eq? var (first (node-parameters iftest))) )
    445                                    ;; Modify call-site to call continuation directly and swap branches
    446                                    ;;  in the conditional:
    447                                    (begin
    448                                      (set! removed-nots (+ removed-nots 1))
    449                                      (node-parameters-set! n '(#t))
    450                                      (node-subexpressions-set! n (cdr subs))
    451                                      (node-subexpressions-set!
    452                                       body
    453                                       (cons (car bodysubs) (reverse (cdr bodysubs))) )
    454                                      (touch) ) ) ) ) ) ) ) ) ) )
     440             (when (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
     441                        (eq? '##core#lambda (node-class lnode)) )
     442              (let* ((llist (third (node-parameters lnode)))
     443                      (body (first (node-subexpressions lnode)))
     444                      (bodysubs (node-subexpressions body)) )
     445                 ;; Continuation has one parameter?
     446                 (if (and (proper-list? llist) (null? (cdr llist)))
     447                     (let* ((var (car llist))
     448                            (refs (get-list db var 'references)) )
     449                      ;; Parameter is only used once?
     450                      (if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
     451                           ;; Continuation contains an 'if' node?
     452                           (let ((iftest (first (node-subexpressions body))))
     453                             ;; Parameter is used only once and is the test-argument?
     454                             (if (and (eq? '##core#variable (node-class iftest))
     455                                      (eq? var (first (node-parameters iftest))) )
     456                                 ;; Modify call-site to call continuation directly and swap branches
     457                                 ;;  in the conditional:
     458                                 (begin
     459                                   (set! removed-nots (+ removed-nots 1))
     460                                   (node-parameters-set! n '(#t))
     461                                   (node-subexpressions-set! n (cdr subs))
     462                                   (node-subexpressions-set!
     463                                    body
     464                                    (cons (car bodysubs) (reverse (cdr bodysubs))) )
     465                                   (touch) ) ) ) ) ) ) ) ) ) )
    455466         (or (test 'not 'call-sites) '()) ) )
    456467   
     
    505516           (immediate? const1)
    506517           (immediate? const2)
    507            (= 1 (length (get db var1 'references)))
    508            (= 1 (length (get db var2 'references)))
     518           (= 1 (length (get-list db var1 'references)))
     519           (= 1 (length (get-list db var2 'references)))
    509520           (make-node
    510521            '##core#switch
     
    531542      (and (equal? op eq-inline-operator)
    532543           (immediate? const)
    533            (= 1 (length (get db var 'references)))
     544           (= 1 (length (get-list db var 'references)))
    534545           (make-node
    535546            '##core#switch
     
    577588                               (cond [(and (eq? c 'let)
    578589                                           (null? (cdr params))
     590                                           (not (get db (first params) 'inline-transient))
    579591                                           (not (get db (first params) 'references))
    580592                                           (pair? vars)
     
    600612   (var1 var2 p more)
    601613   ,(lambda (db var1 var2 p more)
    602       (and (= 1 (length (get db var1 'references)))
     614      (and (= 1 (length (get-list db var1 'references)))
    603615           (make-node
    604616            '##core#call p
     
    618630   ,(lambda (db var op args d x y)
    619631      (and (not (equal? op eq-inline-operator))
    620            (= 1 (length (get db var 'references)))
     632           (= 1 (length (get-list db var 'references)))
    621633           (make-node
    622634            'if d
     
    11951207                      (proper-list? llist)
    11961208                      (and-let* ([val (get db d 'value)]
    1197                                  [refs (get db d 'references)]
    1198                                  [sites (get db d 'call-sites)] )
     1209                                 [refs (get-list db d 'references)]
     1210                                 [sites (get-list db d 'call-sites)] )
    11991211                        (and (eq? n val)
    12001212                             (= (length refs) (length sites))
  • chicken/branches/inlining/posixunix.scm

    r15119 r15323  
    3434              ##sys#terminal-check
    3535              check-time-vector)
     36  (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)
    3637  (foreign-declare #<<EOF
    3738#include <signal.h>
  • chicken/branches/inlining/posixwin.scm

    r15119 r15323  
    7272        $quote-args-list $exec-setup $exec-teardown
    7373        check-time-vector)
     74  (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)
    7475  (foreign-declare #<<EOF
    7576#ifndef WIN32_LEAN_AND_MEAN
  • chicken/branches/inlining/rules.make

    r15246 r15323  
    13141314
    13151315bench:
    1316         here=`pwd`; \
     1316        @here=`pwd`; \
    13171317        cd $(SRCDIR)benchmarks; \
    13181318        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
  • chicken/branches/inlining/scheduler.scm

    r15057 r15323  
    3838        ##sys#fdset-select-timeout ##sys#fdset-restore
    3939        ##sys#clear-i/o-state-for-thread!)
     40  (not inline ##sys#interrupt-hook)
    4041  (foreign-declare #<<EOF
    4142#ifdef HAVE_ERRNO_H
  • chicken/branches/inlining/setup-api.scm

    r15119 r15323  
    3737     (run execute)
    3838     compile
     39     standard-extension
    3940     make make/proc
    4041     host-extension
     
    499500
    500501
     502;;; Convenience function
     503
     504(define (standard-extension name version)
     505  (let* ((sname (->string name))
     506         (fname (make-pathname #f sname "scm"))
     507         (iname (make-pathname #f sname "import.scm")))
     508    (compile -s -O2 -d1 ,fname -j ,name)
     509    (compile -c -O2 -d1 ,fname -j ,name -unit ,name)
     510    (compile -s -O2 -d0 ,iname)
     511    (install-extension
     512     name
     513     (list fname (make-pathname #f sname "setup"))
     514     `((version ,version)
     515       (static ,(make-pathname #f fname "o"))))))
     516
     517
    501518;;; Installation
    502519
  • chicken/branches/inlining/srfi-4.scm

    r13140 r15323  
    3535       ##sys#u8vector-ref ##sys#s8vector-ref ##sys#u16vector-ref ##sys#s16vector-ref subvector
    3636       ##sys#u32vector-ref ##sys#s32vector-ref ##sys#f32vector-ref ##sys#f64vector-ref)
     37 (not inline ##sys#user-print-hook ##sys#number-hash-hook)
    3738 (foreign-declare #<<EOF
    3839#define C_u8peek(b, i)         C_fix(((unsigned char *)C_data_pointer(b))[ C_unfix(i) ])
  • chicken/branches/inlining/support.scm

    r15246 r15323  
    2626
    2727
    28 (declare (unit support))
     28(declare
     29  (unit support))
    2930
    3031
     
    3233(include "tweaks")
    3334(include "banner")
     35
     36(declare
     37  (not inline compiler-cleanup-hook ##sys#user-read-hook) )
    3438
    3539
     
    352356        (##sys#hash-table-set! db key (list (cons prop val)))) ) )
    353357
     358(define (get-list db key prop)          ; returns '() if not set
     359  (let ((x (get db key prop)))
     360    (or x '())))
     361
    354362
    355363;;; Line-number database management:
     
    384392                 (contractable . con) (standard-binding . stb) (simple . sim) (inlinable . inl)
    385393                 (collapsable . col) (removable . rem) (constant . con)
     394                 (inline-target . ilt) (inline-transient . itr)
    386395                 (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb) (inline-export . ilx)
    387396                 (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) )
     
    570579               (fold (cdr vars)) ) ) ) ) )
    571580
    572 (define (inline-lambda-bindings llist args body copy?)
     581(define (inline-lambda-bindings llist args body copy? db)
    573582  (decompose-lambda-list
    574583   llist
     
    577586       (let* ([rlist (if copy? (map gensym vars) vars)]
    578587              [body (if copy?
    579                         (copy-node-tree-and-rename body vars rlist)
     588                        (copy-node-tree-and-rename body vars rlist db)
    580589                        body) ] )
    581590         (fold-right
     
    592601          largs) ) ) ) ) )
    593602
    594 (define (copy-node-tree-and-rename node vars aliases)
     603(define (copy-node-tree-and-rename node vars aliases db)
    595604  (let ([rlist (map cons vars aliases)])
    596605    (define (rename v rl) (alist-ref v rl eq? v))
     
    601610        (case class
    602611          [(##core#variable) (varnode (rename (first params) rl))]
    603           [(set!) (make-node 'set! (list (rename (first params) rl)) (map (cut walk <> rl) subs))]
     612          [(set!)
     613           (make-node
     614            'set! (list (rename (first params) rl))
     615            (list (walk (first subs) rl)) ) ]
    604616          [(let)
    605            (let* ([v (first params)]
    606                   [a (gensym v)]
    607                   [rl2 (alist-cons v a rl)] )
    608              (make-node 'let (list a) (map (cut walk <> rl2) subs)) ) ]
     617           (let* ((v (first params))
     618                  (val1 (walk (first subs) rl))
     619                  (a (gensym v))
     620                  (rl2 (alist-cons v a rl)) )
     621             (make-node
     622              'let (list a)
     623              (list val1 (walk (second subs) rl2)))) ]
    609624          [(##core#lambda)
    610625           (decompose-lambda-list
    611626            (third params)
    612627            (lambda (vars argc rest)
    613               (let* ([as (map gensym vars)]
    614                      [rl2 (append as rl)] )
     628              (let* ((as (map (lambda (v)
     629                                (let ((a (gensym v)))
     630                                  (put! db v 'inline-transient #t)
     631                                  a))
     632                              vars) )
     633                     (rl2 (append (map cons vars as) rl)) )
    615634                (make-node
    616635                 '##core#lambda
     
    660679                        ((assq 'inlinable plist))
    661680                        (lparams (node-parameters (cdr val)))
    662                         ((get db (first lparams) 'simple))
     681                        ;;((get db (first lparams) 'simple))
    663682                        ((not (get db sym 'hidden-refs)))
    664683                        ((case (variable-mark sym '##compiler#inline)
  • chicken/branches/inlining/version.scm

    r15262 r15323  
    1 (define-constant +build-version+ "4.1.1")
     1(define-constant +build-version+ "4.1.2-ii")
Note: See TracChangeset for help on using the changeset viewer.