Changeset 15543 in project for chicken/trunk/optimizer.scm


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

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

Location:
chicken/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk

  • 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)))
Note: See TracChangeset for help on using the changeset viewer.