Changeset 15543 in project


Ignore:
Timestamp:
08/23/09 00:02:41 (10 years ago)
Author:
felix
Message:

merged inlining branch (r15318:15542) into trunk; updated bootstrap tarball; bumped version to 4.1.4

Location:
chicken/trunk
Files:
30 edited
4 copied

Legend:

Unmodified
Added
Removed
  • chicken/trunk

  • chicken/trunk/README

    r15540 r15543  
    44  (c) 2008-2009, The Chicken Team
    55
    6   version 4.1.3
     6  version 4.1.4
    77
    88
  • chicken/trunk/TODO

    r15270 r15543  
    7474
    7575** compiler
     76*** test inlining with compiler modules
    7677*** (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?
    8078*** option ("-M") to compile file as unnamed module (importing scheme + chicken)
    8179
     
    10199*** need script to process import libraries for generating indices for doc.callcc.org
    102100    then tell Toby Butzon about it
    103 *** test DESTDIR and proper linking
    104 *** using "touch" with WINDOWS_SHELL won't work (need alternative)
     101*** using "touch" with WINDOWS_SHELL won't work (need alternative) (mingw/non-msys build)
    105102*** extend scripts/guess-platforms.sh for more platforms
    106103
    107 ** documentation
    108 *** document qs, normalize-pathname
    109 
    110104** scrutiny
    111 *** allow giving toplevel procedure names to `scrutinize' option?
    112105*** write test file to trigger every type of warning (diff with result file in test-suite)
    113106*** add support for keyword arguments and check even length and available keywords
    114 
    115 ** libraries
    116 *** analyse usage statistics ("-debug v") of all core libraries
    117107
    118108
     
    131121
    132122* optimizations
     123
     124** inlining could be enabled for all core libs
     125
     126** global inline files for core units
     127*** This would remove necessity for many simple re-write rules in c-platform.scm
    133128
    134129** self-recursion optimization
     
    158153   the compiler)
    159154
    160 ** Lisp2-hack by Dybvig
    161 *** add function-cell to symbol, call on direct call without checks
    162 *** initialized to trap function on set!/define, which does fixup
    163 *** would also allow inline-caching hacks
     155
     156* 4.0.9 benchmark results
     157
     158(c)2008-2009 The Chicken Team
     159(c)2000-2007 Felix L. Winkelmann
     160Version 4.0.9 - SVN rev. 15246
     161linux-unix-gnu-x86 [ manyargs dload ptables applyhook ]
     162compiled 2009-07-23 on x (Linux)
     163
     164
     165CC:
     166Using built-in specs.
     167Target: i486-linux-gnu
     168Configured 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
     169Thread model: posix
     170gcc version 4.3.3 (Ubuntu 4.3.3-5ubuntu4)
     171
     172CFLAGS:
     173-fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H -Os -fomit-frame-pointer -I/home/felix/include
     174
     175Running benchmarks ...
     176
     177  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped)
     178
     179                     (runtime)                                  (code size)
     180
     181                     base       fast     unsafe        max      base      fast    unsafe       max
     182                  ----------------------------------------------------------------------------------
     1830                   0.000      0.000      0.000      0.000     1013k     1013k      902k      902k
     184binarytrees         0.076      0.081      0.082      0.004     1021k     1021k      910k      910k
     185boyer               0.053      0.052      0.053      0.004     1045k     1045k      934k      934k
     186browse              0.088      0.086      0.073      0.072     1029k     1029k      918k      918k
     187conform             0.108      0.072      0.072      0.064     1089k     1085k      954k      954k
     188cpstak              0.272      0.250      0.208      0.169     1013k     1013k      906k      906k
     189ctak                0.124      0.128      0.110      0.106     1017k     1017k      906k      906k
     190dderiv              0.106      0.089      0.082      0.076     1021k     1021k      910k      910k
     191deriv               0.078      0.081      0.068      0.078     1017k     1017k      910k      906k
     192destructive         0.069      0.076      0.062      0.070     1017k     1017k      910k      906k
     193div-iter            0.002      0.021      0.018      0.021     1013k     1013k      906k      906k
     194div-rec             0.046      0.052      0.036      0.057     1013k     1013k      906k      906k
     195dynamic             0.074      0.062      0.078      0.056     1293k     1285k     1078k     1078k
     196earley              0.029      0.018      0.028      0.028     1073k     1065k      950k      950k
     197fft                 0.046      0.032      0.028                1025k     1025k      914k      950k
     198fib                 0.014      0.148      0.109      0.033     1013k     1013k      902k      902k
     199fibc                1.464      0.854      0.736      0.572     1017k     1013k      906k      906k
     200fprint              0.121      0.124      0.112      0.117     1017k     1017k      906k      906k
     201fread               0.572      0.056      0.524      0.526     1013k     1013k      902k      902k
     202hanoi               0.414      0.392      0.341      0.145     1013k     1013k      906k      902k
     203lattice             5.228      5.109      4.156      4.168     1029k     1029k      918k      918k
     204maze                0.136      0.112      0.085                1089k     1077k      946k      918k
     205nbody               2.414      1.610      0.528                1045k     1033k      914k      918k
     206nqueens             0.068      0.064      0.029      0.021     1017k     1017k      906k      906k
     207puzzle              0.052      0.056      0.028      0.026     1037k     1037k      922k      918k
     208scheme              0.025      0.014      0.010      0.010     1165k     1165k      998k      998k
     209tak                 0.273      0.268      0.217      0.056     1013k     1013k      906k      902k
     210takl                0.142      0.148      0.057      0.073     1017k     1017k      906k      906k
     211takr                0.438      0.430      0.301      0.246     1125k     1125k      998k      998k
     212traverse            0.224      0.150      0.012      0.112     1037k     1033k      914k      914k
     213travinit            0.033      0.033      0.026      0.018     1037k     1033k      910k      910k
     214triangl             0.546      0.553      0.042      0.377     1017k     1017k      906k      906k
     215
     216TOTAL              13.488     11.733      8.805      7.385
     217
     218
     219** These benchmarks are meaningless - find real ones.
  • chicken/trunk/batch-driver.scm

    r15246 r15543  
    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/trunk/benchmarks/cscbench.scm

    r15346 r15543  
    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
    12 (define +chicken-format+ "~A ~A -quiet -no-warnings -heap-size 16m -output-file tmpfile.c ~A ~A")
     13(define +chicken-format+
     14  "~A ~A -quiet -no-warnings -heap-size 16m -output-file tmpfile.c ~A ~A -debug xopi 2>&1 >>bench.log")
     15
    1316(define +cc-format+
    1417  (cond-expand
     
    8487
    8588(define (main options)
    86   (when (and (pair? options) (string=? "-debug" (car options)))
    87     (set! options (cdr options))
    88     (set! system*
    89       (let ([system* system*])
    90         (lambda args
    91           (let ([s (apply sprintf args)])
    92             (printf "system: ~A~%" s)
    93             (system* s) ) ) ) ) )
    94   (and-let* ([(pair? options)]
    95              [m (string-match "-cc=(.*)" (car options))] )
    96     (set! options (cdr options))
    97     (set! cc (second m)) )
     89  (call/cc
     90   (lambda (return)
     91     (let loop ((opts options))
     92       (cond ((null? opts) (return #f))
     93             ((string=? "-debug" (car opts))
     94              (set! system*
     95                (let ([system* system*])
     96                  (lambda args
     97                    (let ([s (apply sprintf args)])
     98                      (printf "system: ~A~%" s)
     99                      (system* s) ) ) ) ) )
     100             ((string-match "-cc=(.*)" (car opts)) =>
     101              (lambda (m) (set! cc (second m))))
     102             ((string-match "-csc=(.*)" (car opts)) =>
     103              (lambda (m) (set! csc (second m))))
     104             ((string-match "-chicken=(.*)" (car opts)) =>
     105              (lambda (m) (set! chicken (second m))))
     106             (else
     107              (set! options opts)
     108              (return #f)))
     109       (loop (cdr opts)))))
     110  (set! cc (string-trim-both (with-input-from-pipe "csc -cc-name" read-line)))
    98111  (delete-file* "tmpfile.scm")
     112  (delete-file* "bench.log")
    99113  (system* "~A -version" chicken)
    100114  (dflush "\nCC:\n")
     
    103117      (system* "~A -v" cc) )
    104118  (dflush "\nCFLAGS:\n")
    105   (system* "echo `csc -cflags`")
    106   (display "\nRunning benchmarks ...\n\n  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped)\n")
     119  (system* "echo `~a -cflags`" csc)
     120  (display "\nRunning benchmarks ...\n\n  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped,\n")
     121  (display "   compiler log will be written to \"bench.log\")\n")
    107122  (display "\n                     (runtime)                                  (code size)\n")
    108123  (display "\n                     base       fast     unsafe        max      base      fast    unsafe       max")
  • chicken/trunk/buildversion

    r15528 r15543  
    1 4.1.3
     14.1.4
  • chicken/trunk/c-platform.scm

    r15321 r15543  
    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/trunk/compiler-namespace.scm

    r15527 r15543  
    167167 get-line
    168168 get-line-2
     169 get-list
    169170 hide-variable
    170171 immediate?
  • chicken/trunk/compiler.scm

    r15445 r15543  
    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
     
    17101712             (unless (memq var localenv)
    17111713               (grow 1)
    1712                (cond ((memq var env) (put! db var 'captured #t))
     1714               (cond ((memq var env)
     1715                      (put! db var 'captured #t))
    17131716                     ((not (get db var 'global))
    17141717                      (put! db var 'global #t) ) ) ) ) )
     
    18071810                  (compiler-warning 'redef "redefinition of extended binding `~S'" var) ) )
    18081811               (put! db var 'potential-value val) )
    1809              (when (and (not (memq var localenv))
    1810                         (not (memq var env)) )
     1812             (unless (memq var localenv)
    18111813               (grow 1)
    1812                (put! db var 'global #t) )
     1814               (cond ((memq var env)
     1815                      (put! db var 'captured #t))
     1816                     ((not (get db var 'global))
     1817                      (put! db var 'global #t) ) ) )
    18131818             (assign var val (append localenv env) here)
    18141819             (unless toplevel-scope (put! db var 'assigned-locally #t))
     
    18301835      (cond ((eq? '##core#undefined (node-class val))
    18311836             (put! db var 'undefined #t) )
    1832             ((and (eq? '##core#variable (node-class val))
     1837            ((and (eq? '##core#variable (node-class val)) ; assignment to itself
    18331838                  (eq? var (first (node-parameters val))) ) )
    18341839            ((or (memq var env)
     
    18471852                  (not (get db var 'unknown)))
    18481853             (let ((home (get db var 'home)))
    1849                (if (or (not home) (eq? here home))
    1850                    (put! db var 'local-value val)             
    1851                    (put! db var 'unknown #t))))
     1854               (cond ((get db var 'local-value)
     1855                      (put! db var 'unknown #t))
     1856                     ((or (not home) (eq? here home))
     1857                      (put! db var 'local-value val)           )
     1858                     (else (put! db var 'unknown #t)))))
    18521859            (else (put! db var 'unknown #t)) ) )
    18531860   
     
    19131920
    19141921         (set! value (and (not unknown) value))
     1922         (set! local-value (and (not unknown) local-value))
    19151923
    19161924         ;; If this is the first analysis, register known local or potentially known global lambda-value id's
     
    19741982                          (else
    19751983                           (let ((lparams (node-parameters n)))
    1976                              (put! db (first lparams) 'simple #t) ;XXX hack
    19771984                             (quick-put! plist 'inlinable #t)
    19781985                             (quick-put! plist 'local-value n))))))))
  • chicken/trunk/defaults.make

    r15506 r15543  
    281281# Scheme compiler flags
    282282
    283 CHICKEN_OPTIONS = -no-trace -optimize-level 2 -include-path . -include-path $(SRCDIR)
     283CHICKEN_OPTIONS = -optimize-level 2 -include-path . -include-path $(SRCDIR)
    284284ifdef DEBUGBUILD
    285285CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db
    286286endif
    287 CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use
     287CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use -no-trace
    288288CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -inline -local
    289289CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
     
    291291CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
    292292CHICKEN_IMPORT_LIBRARY_OPTIONS = $(CHICKEN_DYNAMIC_OPTIONS)
     293
     294ifndef DEBUGBUILD
     295CHICKEN_PROGRAM_OPTIONS += -no-trace
     296CHICKEN_COMPILER_OPTIONS += -no-trace
     297endif
    293298
    294299# targets
  • chicken/trunk/distribution/manifest

    r15527 r15543  
    200200tests/compiler-tests.scm
    201201tests/compiler-tests-2.scm
     202tests/inlining-tests.scm
    202203tests/locative-stress-test.scm
    203204tests/r4rstest.scm
  • chicken/trunk/eval.scm

    r15485 r15543  
    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/trunk/expand.scm

    r15171 r15543  
    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/trunk/library.scm

    r15321 r15543  
    3636        ##sys#print-exit
    3737        ##sys#format-here-doc-warning)
     38  (not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#schedule
     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/trunk/lolevel.scm

    r15169 r15543  
    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/trunk/manual

  • chicken/trunk/manual/Extensions

    r15000 r15543  
    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/trunk/manual/The User's Manual

    r15528 r15543  
    77</nowiki>
    88
    9 This is the manual for Chicken Scheme, version 4.1.3
     9This is the manual for Chicken Scheme, version 4.1.4
    1010
    1111; [[Getting started]] : What is CHICKEN and how do I use it?
  • chicken/trunk/optimizer.scm

    r15246 r15543  
    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 fids)
    137139      (if (memq n broken-constant-nodes)
    138140          n
    139141          (simplify
    140142           (let* ((odirty dirty)
    141                   (n1 (walk1 n))
     143                  (n1 (walk1 n fids))
    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                             fids) )
    152155                      (else n1) ) )
    153156
     
    177180               (else n1) ) ) ) ) )
    178181
    179     (define (walk1 n)
     182    (define (walk1 n fids)
    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) fids) ]
     210                   [else (make-node 'let params (map (cut walk <> fids) 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) (cons id fids))) ) ) ) ) ]
     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) (cons id fids))) ) ) ) ]
     244                   [else (walk-generic n class params subs (cons id fids))] ) ) )
    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                           (for-each (cut put! db <> 'inline-target #t) fids)
     264                           (walk
     265                            (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
     266                            fids) ) ]
    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 fids)) ]
    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                                       (for-each (cut put! db <> 'inline-target #t) fids)
    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                                        fids) ]
     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 fids)
    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 <> fids) (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) fids)
    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 fids)
    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 <> fids)
    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 fids)] ) ) ) ) ) ]
     363                        [else (walk-generic n class params subs fids)] ) ) ]
    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 fids)
     367                    (make-node '##core#call (cons #t (cdr params)) (map (cut walk <> fids) subs)) ) ]
     368               [else (walk-generic n class params subs fids)] ) ) )
    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) fids)))] ) ) )
     384
     385          (else (walk-generic n class params subs fids)) ) ) )
    375386   
    376     (define (walk-generic n class params subs)
    377       (let ((subs2 (map walk subs)))
     387    (define (walk-generic n class params subs fids)
     388      (let ((subs2 (map (cut walk <> fids) 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 '())))
    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))
     
    12961308             [argc (length (third params))]
    12971309             [klambdas '()]
    1298              [sites (get db fnvar 'call-sites)]
     1310             [sites (or (get db fnvar 'call-sites) '())]
    12991311             [ksites '()] )
    13001312        (if (and (list? params) (= (length params) 4) (list? (caddr params)))
  • chicken/trunk/posixunix.scm

    r15321 r15543  
    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/trunk/posixwin.scm

    r15119 r15543  
    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/trunk/rules.make

    r15506 r15543  
    12881288
    12891289testclean:
    1290         $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(SRCDIR)tests/*.out $(SRCDIR)tests/tmp* \
    1291           $(SRCDIR)tests/*.so $(SRCDIR)tests/*.import.scm $(SRCDIR)tests/repository
     1290        $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(SRCDIR)tests/a.out $(SRCDIR)tests/scrutiny.out \
     1291          $(SRCDIR)tests/tmp* $(SRCDIR)tests/*.so $(SRCDIR)tests/*.import.scm $(SRCDIR)tests/repository
    12921292
    12931293# run tests
     
    13451345
    13461346bench:
    1347         here=`pwd`; \
     1347        @here=`pwd`; \
    13481348        cd $(SRCDIR)benchmarks; \
    13491349        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
  • chicken/trunk/scheduler.scm

    r15057 r15543  
    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/trunk/setup-api.scm

    r15530 r15543  
    4040     (run execute)
    4141     compile
     42     standard-extension
    4243     make make/proc
    4344     host-extension
     
    501502
    502503
     504;;; Convenience function
     505
     506(define (standard-extension name version)
     507  (let* ((sname (->string name))
     508         (fname (make-pathname #f sname "scm"))
     509         (iname (make-pathname #f sname "import.scm")))
     510    (compile -s -O2 -d1 ,fname -j ,name)
     511    (compile -c -O2 -d1 ,fname -j ,name -unit ,name)
     512    (compile -s -O2 -d0 ,iname)
     513    (install-extension
     514     name
     515     (list fname (make-pathname #f sname "setup"))
     516     `((version ,version)
     517       (static ,(make-pathname #f fname "o"))))))
     518
     519
    503520;;; Installation
    504521
  • chicken/trunk/srfi-4.scm

    r13140 r15543  
    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/trunk/support.scm

    r15527 r15543  
    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)
     
    13541373;;; We need this for constant folding:
    13551374
    1356 (define (string-null? x) (string-null? x))
     1375(define (string-null? x)
     1376  (##core#inline "C_i_string_null_p" s))
    13571377
    13581378
  • chicken/trunk/tests/compiler-tests-2.scm

    r12114 r15543  
    1313 (plus 1))
    1414
    15 (print (plus1 1))
     15(assert (= 2 (plus1 1)))
    1616
    1717(define (len lst)
     
    2424 (len 0))
    2525
    26 (print (len '(1 2 3)))
     26(assert (= 3 (len '(1 2 3))))
  • chicken/trunk/tests/runtests.sh

    r15346 r15543  
    3939
    4040echo "======================================== compiler tests (2) ..."
    41 $compile compiler-tests.scm -lambda-lift
     41$compile compiler-tests-2.scm -lambda-lift
     42./a.out
     43
     44echo "======================================== compiler inlining tests  ..."
     45$compile inlining-tests.scm -optimize-level 3
    4246./a.out
    4347
  • chicken/trunk/version.scm

    r15528 r15543  
    1 (define-constant +build-version+ "4.1.3")
     1(define-constant +build-version+ "4.1.4")
Note: See TracChangeset for help on using the changeset viewer.