Changeset 15446 in project for chicken


Ignore:
Timestamp:
08/13/09 20:17:38 (10 years ago)
Author:
felix winkelmann
Message:

mark all outer lambdas as inline-targets

Location:
chicken/branches/inlining
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/inlining/README

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

    r15323 r15446  
    1 4.1.2-ii
     14.1.2ii
  • chicken/branches/inlining/manual/The User's Manual

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

    r15323 r15446  
    136136          n) )
    137137
    138     (define (walk n fid)
     138    (define (walk n fids)
    139139      (if (memq n broken-constant-nodes)
    140140          n
    141141          (simplify
    142142           (let* ((odirty dirty)
    143                   (n1 (walk1 n fid))
     143                  (n1 (walk1 n fids))
    144144                  (subs (node-subexpressions n1)) )
    145145             (case (node-class n1)
     
    152152                                 (cadr subs)
    153153                                 (caddr subs) )
    154                              fid) )
     154                             fids) )
    155155                      (else n1) ) )
    156156
     
    180180               (else n1) ) ) ) ) )
    181181
    182     (define (walk1 n fid)
     182    (define (walk1 n fids)
    183183      (let ((subs (node-subexpressions n))
    184184            (params (node-parameters n))
     
    207207                    (touch)
    208208                    (set! removed-lets (add1 removed-lets))
    209                     (walk (second subs) fid) ]
    210                    [else (make-node 'let params (map (cut walk <> fid) subs))] ) ) )
     209                    (walk (second subs) fids) ]
     210                   [else (make-node 'let params (map (cut walk <> fids) subs))] ) ) )
    211211
    212212          ((##core#lambda)
     
    228228                                      [else (build-lambda-list used argc rest)] )
    229229                                (fourth params) )
    230                           (list (walk (first subs) id)) ) ) ) ) ]
     230                          (list (walk (first subs) (cons id fids))) ) ) ) ) ]
    231231                   [(test id 'explicit-rest)
    232232                    (decompose-lambda-list
     
    241241                              (build-lambda-list vars (add1 argc) #f)
    242242                              (fourth params) )
    243                         (list (walk (first subs) id)) ) ) ) ]
    244                    [else (walk-generic n class params subs id)] ) ) )
     243                        (list (walk (first subs) (cons id fids))) ) ) ) ]
     244                   [else (walk-generic n class params subs (cons id fids))] ) ) )
    245245
    246246          ((##core#call)
     
    261261                           (debugging 'o "contracted procedure" var)
    262262                           (touch)
    263                            (when fid (put! db fid 'inline-target #t))
     263                           (for-each (cut put! db <> 'inline-target #t) fids)
    264264                           (walk
    265265                            (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
    266                             fid) ) ]
     266                            fids) ) ]
    267267                        [(memq var constant-declarations)
    268268                         (or (and-let* ((k (car args))
     
    280280                                '##core#call '(#t)
    281281                                (list k (make-node '##core#undefined '() '())) ) )
    282                              (walk-generic n class params subs fid)) ]
     282                             (walk-generic n class params subs fids)) ]
    283283                        [(and lval
    284284                              (eq? '##core#lambda (node-class lval)))
     
    303303                                            "inlining")
    304304                                        var ifid (fourth lparams))
    305                                        (when fid (put! db fid 'inline-target #t))
     305                                       (for-each (cut put! db <> 'inline-target #t) fids)
    306306                                       (check-signature var args llist)
    307307                                       (debugging 'o "inlining procedure" var)
     
    309309                                       (walk
    310310                                        (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
    311                                         fid) ]
     311                                        fids) ]
    312312                                      [(test ifid 'has-unused-parameters)
    313313                                       (if (< (length args) argc) ; Expression was already optimized (should this happen?)
    314                                            (walk-generic n class params subs fid)
     314                                           (walk-generic n class params subs fids)
    315315                                           (let loop ((vars vars) (argc argc) (args args) (used '()))
    316316                                             (cond [(or (null? vars) (zero? argc))
     
    319319                                                     '##core#call
    320320                                                     params
    321                                                      (map (cut walk <> fid) (cons fun (append-reverse used args))) ) ]
     321                                                     (map (cut walk <> fids) (cons fun (append-reverse used args))) ) ]
    322322                                                   [(test (car vars) 'unused)
    323323                                                    (touch)
     
    329329                                                         'let
    330330                                                         (list (gensym 't))
    331                                                          (list (walk (car args) fid)
     331                                                         (list (walk (car args) fids)
    332332                                                               (loop (cdr vars) (sub1 argc) (cdr args) used) ) )
    333333                                                        (loop (cdr vars) (sub1 argc) (cdr args) used) ) ]
     
    340340                                       (let ([n (llist-length llist)])
    341341                                         (if (< (length args) n)
    342                                              (walk-generic n class params subs fid)
     342                                             (walk-generic n class params subs fids)
    343343                                             (begin
    344344                                               (debugging 'o "consed rest parameter at call site" var n)
     
    347347                                                            '##core#call
    348348                                                            params
    349                                                             (map (cut walk <> fid)
     349                                                            (map (cut walk <> fids)
    350350                                                                 (cons fun
    351351                                                                       (append
     
    360360                                                   (set! rest-consers (cons n2 rest-consers))
    361361                                                   n2) ) ) ) ) ]
    362                                       [else (walk-generic n class params subs fid)] ) ) ) ) ) ]
    363                         [else (walk-generic n class params subs fid)] ) ) ]
     362                                      [else (walk-generic n class params subs fids)] ) ) ) ) ) ]
     363                        [else (walk-generic n class params subs fids)] ) ) ]
    364364               [(##core#lambda)
    365365                (if (first params)
    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)] ) ) )
     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)] ) ) )
    369369
    370370          ((set!)
     
    381381                    (debugging 'o "removed side-effect free assignment to unused variable" var)
    382382                    (make-node '##core#undefined '() '()) ]
    383                    [else (make-node 'set! params (list (walk (car subs) fid)))] ) ) )
    384 
    385           (else (walk-generic n class params subs fid)) ) ) )
     383                   [else (make-node 'set! params (list (walk (car subs) fids)))] ) ) )
     384
     385          (else (walk-generic n class params subs fids)) ) ) )
    386386   
    387     (define (walk-generic n class params subs fid)
    388       (let ((subs2 (map (cut walk <> fid) subs)))
     387    (define (walk-generic n class params subs fids)
     388      (let ((subs2 (map (cut walk <> fids) subs)))
    389389        (if (every eq? subs subs2)
    390390            n
     
    396396          (debugging 'p "traversal phase...")
    397397          (set! simplified-ops '())
    398           (let ((node2 (walk node #f)))
     398          (let ((node2 (walk node '())))
    399399            (when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
    400400            (when (and (pair? simplified-ops) (debugging 'o "  call simplifications:"))
  • chicken/branches/inlining/version.scm

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