Ticket #1068: 0001-Fix-1068-partially-by-removing-returnvar-passing-fro.patch

File 0001-Fix-1068-partially-by-removing-returnvar-passing-fro.patch, 6.9 KB (added by sjamaan, 10 years ago)

Initial attempt at fixing #1068 by ripping out returnvar-passing in cps-conversion

  • compiler.scm 

    From d10fefe27031c0468424466c49aa80c21fb325a8 Mon Sep 17 00:00:00 2001
From: Peter Bex <peter.bex@xs4all.nl>
Date: Sun, 15 Dec 2013 16:04:27 +0100
Subject: [PATCH] Fix #1068 (partially!) by removing returnvar-passing from
 CPS-conversion

---
 compiler.scm             |   53 +++++++++++++++++++++-------------------------
 tests/compiler-tests.scm |    9 ++++++++
 tests/syntax-tests.scm   |   14 +++++++++++-
 3 files changed, 46 insertions(+), 30 deletions(-)

diff --git a/compiler.scm b/compiler.scm
index 0398eef..f356eaf 100644
    a b  
    16881688
    16891689(define (perform-cps-conversion node)
    16901690
    1691   (define (cps-lambda id returnvar llist subs k)
    1692     (let ([t1 (or returnvar (gensym 'k))])
     1691  (define (cps-lambda id llist subs k)
     1692    (let ([t1 (gensym 'k)])
    16931693      (k (make-node
    16941694          '##core#lambda (list id #t (cons t1 llist) 0)
    1695           (list (walk (gensym-f-id)
    1696                       (car subs)
     1695          (list (walk (car subs)
    16971696                      (lambda (r)
    16981697                        (make-node '##core#call (list #t) (list (varnode t1) r)) ) ) ) ) ) ) )
    16991698
    … …  
    17011700     (and (eq? (node-class node) '##core#variable)
    17021701          (eq? (car (node-parameters node)) var)))
    17031702 
    1704   (define (walk returnvar n k)
     1703  (define (walk n k)
    17051704    (let ((subs (node-subexpressions n))
    17061705          (params (node-parameters n))
    17071706          (class (node-class n)) )
    17081707      (case (node-class n)
    17091708        ((##core#variable quote ##core#undefined ##core#primitive) (k n))
    17101709        ((if) (let* ((t1 (gensym 'k))
    1711                      (t2 (or returnvar (gensym 'r)))
     1710                     (t2 (gensym 'r))
    17121711                     (k1 (lambda (r) (make-node '##core#call (list #t) (list (varnode t1) r)))) )
    17131712                (make-node
    17141713                 'let
    17151714                 (list t1)
    17161715                 (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0)
    17171716                                  (list (k (varnode t2))) )
    1718                        (walk #f (car subs)
     1717                       (walk (car subs)
    17191718                             (lambda (v)
    17201719                               (make-node 'if '()
    17211720                                          (list v
    1722                                                 (walk #f (cadr subs) k1)
    1723                                                 (walk #f (caddr subs) k1) ) ) ) ) ) ) ) )
     1721                                                (walk (cadr subs) k1)
     1722                                                (walk (caddr subs) k1) ) ) ) ) ) ) ) )
    17241723        ((let)
    17251724         (let loop ((vars params) (vals subs))
    17261725           (if (null? vars)
    1727                (walk #f (car vals) k)
    1728                (walk (car vars)
    1729                      (car vals)
     1726               (walk (car vals) k)
     1727               (walk (car vals)
    17301728                     (lambda (r)
    17311729                       (if (node-for-var? r (car vars)) ; Don't generate unneccessary lets
    17321730                           (loop (cdr vars) (cdr vals))
    17331731                           (make-node 'let
    17341732                                      (list (car vars))
    17351733                                      (list r (loop (cdr vars) (cdr vals))) )) ) ) ) ) )
    1736         ((lambda ##core#lambda) (cps-lambda (gensym-f-id) returnvar (first params) subs k))
     1734        ((lambda ##core#lambda) (cps-lambda (gensym-f-id) (first params) subs k))
    17371735        ((set!) (let ((t1 (gensym 't)))
    1738                   (walk #f
    1739                         (car subs)
     1736                  (walk (car subs)
    17401737                        (lambda (r)
    17411738                          (make-node 'let (list t1)
    17421739                                     (list (make-node 'set! (list (first params)) (list r))
    … …  
    17481745             (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
    17491746           ;; mark to avoid leaf-routine optimization
    17501747           (mark-variable id '##compiler#callback-lambda)
    1751            ;; maybe pass returnvar here?
    1752            (cps-lambda id #f (first (node-parameters lam)) (node-subexpressions lam) k) ) )
     1748           (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
    17531749        ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref
    17541750                        ##core#inline_loc_update)
    17551751         (walk-inline-call class params subs k) )
    1756         ((##core#call) (walk-call returnvar (car subs) (cdr subs) params k))
    1757         ((##core#callunit) (walk-call-unit returnvar (first params) k))
     1752        ((##core#call) (walk-call (car subs) (cdr subs) params k))
     1753        ((##core#callunit) (walk-call-unit (first params) k))
    17581754        ((##core#the ##core#the/result)
    17591755         ;; remove "the" nodes, as they are not used after scrutiny
    1760          (walk returnvar (car subs) k))
     1756         (walk (car subs) k))
    17611757        ((##core#typecase)
    17621758         ;; same here, the last clause is chosen, exp is dropped
    1763          (walk returnvar (last subs) k))
     1759         (walk (last subs) k))
    17641760        (else (bomb "bad node (cps)")) ) ) )
    17651761 
    1766   (define (walk-call returnvar fn args params k)
     1762  (define (walk-call fn args params k)
    17671763    (let ((t0 (gensym 'k))
    1768           (t3 (or returnvar (gensym 'r))) )
     1764          (t3 (gensym 'r)) )
    17691765      (make-node
    17701766       'let (list t0)
    17711767       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
    … …  
    17731769             (walk-arguments
    17741770              args
    17751771              (lambda (vars)
    1776                 (walk #f fn
     1772                (walk fn
    17771773                      (lambda (r)
    17781774                        (make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
    17791775 
    1780   (define (walk-call-unit returnvar unitname k)
     1776  (define (walk-call-unit unitname k)
    17811777    (let ((t0 (gensym 'k))
    1782           (t3 (or returnvar (gensym 'r))) )
     1778          (t3 (gensym 'r)) )
    17831779      (make-node
    17841780       'let (list t0)
    17851781       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
    … …  
    18001796             (loop (cdr args) (cons (car args) vars)) )
    18011797            (else
    18021798             (let ((t1 (gensym 'a)))
    1803                (walk t1
    1804                      (car args)
     1799               (walk (car args)
    18051800                     (lambda (r)
    18061801                       (if (node-for-var? r t1) ; Don't generate unneccessary lets
    18071802                           (loop (cdr args) (cons (varnode t1) vars) )
    … …  
    18181813                             ##core#inline_loc_ref ##core#inline_loc_update))
    18191814               (every atomic? (node-subexpressions n)) ) ) ) )
    18201815 
    1821   (walk #f node values) )
     1816  (walk node values) )
    18221817
    18231818
    18241819;;; Foreign callback stub type:

  • tests/compiler-tests.scm 

    diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 45b6bfd..444aa50 100644
    a b  
    217217
    218218(gp-test)
    219219
     220;; Optimizer would "lift" inner-bar out of its let and replace
     221;; outer-bar with it, even though it wasn't visible yet.  Caused by
     222;; broken cps-conversion (underlying problem for #1068).
     223(let ((outer-bar (##core#undefined)))
     224  (let ((inner-bar (let ((tmp (lambda (x) (if x '1 (outer-bar '#t)))))
     225                     tmp)))
     226    (set! outer-bar inner-bar)
     227    (outer-bar #f)))
     228
    220229;; Test that encode-literal/decode-literal use the proper functions
    221230;; to decode number literals.
    222231(assert (equal? '(+inf.0 -inf.0) (list (fp/ 1.0 0.0) (fp/ -1.0 0.0))))

  • tests/syntax-tests.scm 

    diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index a5f4323..89481cd 100644
    a b take 
    11131113                   (bar foo))
    11141114            bar))
    11151115
     1116;; Obscure letrec issue #1068
     1117(t 1 (letrec ((foo (lambda () 1))
     1118              (bar (let ((tmp (lambda (x) (if x (foo) (bar #t)))))
     1119                     tmp)))
     1120       (bar #f)))
     1121
     1122;; Just to verify (this has always worked)
     1123(t 1 (letrec* ((foo (lambda () 1))
     1124               (bar (let ((tmp (lambda (x) (if x (foo) (bar #t)))))
     1125                      tmp)))
     1126       (bar #f)))
     1127
    11161128(t 1 (letrec* ((foo 1)
    11171129               (bar foo))
    1118               bar))
     1130       bar))