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 returnvarpassing from
CPSconversion

compiler.scm  53 +++++++++++++++++++++
tests/compilertests.scm  9 ++++++++
tests/syntaxtests.scm  14 +++++++++++
3 files changed, 46 insertions(+), 30 deletions()
diff git a/compiler.scm b/compiler.scm
index 0398eef..f356eaf 100644
a

b


1688  1688  
1689  1689  (define (performcpsconversion node) 
1690  1690  
1691   (define (cpslambda id returnvar llist subs k) 
1692   (let ([t1 (or returnvar (gensym 'k))]) 
 1691  (define (cpslambda id llist subs k) 
 1692  (let ([t1 (gensym 'k)]) 
1693  1693  (k (makenode 
1694  1694  '##core#lambda (list id #t (cons t1 llist) 0) 
1695   (list (walk (gensymfid) 
1696   (car subs) 
 1695  (list (walk (car subs) 
1697  1696  (lambda (r) 
1698  1697  (makenode '##core#call (list #t) (list (varnode t1) r)) ) ) ) ) ) ) ) 
1699  1698  
… 
… 

1701  1700  (and (eq? (nodeclass node) '##core#variable) 
1702  1701  (eq? (car (nodeparameters node)) var))) 
1703  1702  
1704   (define (walk returnvar n k) 
 1703  (define (walk n k) 
1705  1704  (let ((subs (nodesubexpressions n)) 
1706  1705  (params (nodeparameters n)) 
1707  1706  (class (nodeclass n)) ) 
1708  1707  (case (nodeclass n) 
1709  1708  ((##core#variable quote ##core#undefined ##core#primitive) (k n)) 
1710  1709  ((if) (let* ((t1 (gensym 'k)) 
1711   (t2 (or returnvar (gensym 'r))) 
 1710  (t2 (gensym 'r)) 
1712  1711  (k1 (lambda (r) (makenode '##core#call (list #t) (list (varnode t1) r)))) ) 
1713  1712  (makenode 
1714  1713  'let 
1715  1714  (list t1) 
1716  1715  (list (makenode '##core#lambda (list (gensymfid) #f (list t2) 0) 
1717  1716  (list (k (varnode t2))) ) 
1718   (walk #f (car subs) 
 1717  (walk (car subs) 
1719  1718  (lambda (v) 
1720  1719  (makenode 'if '() 
1721  1720  (list v 
1722   (walk #f (cadr subs) k1) 
1723   (walk #f (caddr subs) k1) ) ) ) ) ) ) ) ) 
 1721  (walk (cadr subs) k1) 
 1722  (walk (caddr subs) k1) ) ) ) ) ) ) ) ) 
1724  1723  ((let) 
1725  1724  (let loop ((vars params) (vals subs)) 
1726  1725  (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) 
1730  1728  (lambda (r) 
1731  1729  (if (nodeforvar? r (car vars)) ; Don't generate unneccessary lets 
1732  1730  (loop (cdr vars) (cdr vals)) 
1733  1731  (makenode 'let 
1734  1732  (list (car vars)) 
1735  1733  (list r (loop (cdr vars) (cdr vals))) )) ) ) ) ) ) 
1736   ((lambda ##core#lambda) (cpslambda (gensymfid) returnvar (first params) subs k)) 
 1734  ((lambda ##core#lambda) (cpslambda (gensymfid) (first params) subs k)) 
1737  1735  ((set!) (let ((t1 (gensym 't))) 
1738   (walk #f 
1739   (car subs) 
 1736  (walk (car subs) 
1740  1737  (lambda (r) 
1741  1738  (makenode 'let (list t1) 
1742  1739  (list (makenode 'set! (list (first params)) (list r)) 
… 
… 

1748  1745  (cons (apply makeforeigncallbackstub id params) foreigncallbackstubs) ) 
1749  1746  ;; mark to avoid leafroutine optimization 
1750  1747  (markvariable id '##compiler#callbacklambda) 
1751   ;; maybe pass returnvar here? 
1752   (cpslambda id #f (first (nodeparameters lam)) (nodesubexpressions lam) k) ) ) 
 1748  (cpslambda id (first (nodeparameters lam)) (nodesubexpressions lam) k) ) ) 
1753  1749  ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref 
1754  1750  ##core#inline_loc_update) 
1755  1751  (walkinlinecall class params subs k) ) 
1756   ((##core#call) (walkcall returnvar (car subs) (cdr subs) params k)) 
1757   ((##core#callunit) (walkcallunit returnvar (first params) k)) 
 1752  ((##core#call) (walkcall (car subs) (cdr subs) params k)) 
 1753  ((##core#callunit) (walkcallunit (first params) k)) 
1758  1754  ((##core#the ##core#the/result) 
1759  1755  ;; remove "the" nodes, as they are not used after scrutiny 
1760   (walk returnvar (car subs) k)) 
 1756  (walk (car subs) k)) 
1761  1757  ((##core#typecase) 
1762  1758  ;; same here, the last clause is chosen, exp is dropped 
1763   (walk returnvar (last subs) k)) 
 1759  (walk (last subs) k)) 
1764  1760  (else (bomb "bad node (cps)")) ) ) ) 
1765  1761  
1766   (define (walkcall returnvar fn args params k) 
 1762  (define (walkcall fn args params k) 
1767  1763  (let ((t0 (gensym 'k)) 
1768   (t3 (or returnvar (gensym 'r))) ) 
 1764  (t3 (gensym 'r)) ) 
1769  1765  (makenode 
1770  1766  'let (list t0) 
1771  1767  (list (makenode '##core#lambda (list (gensymfid) #f (list t3) 0) 
… 
… 

1773  1769  (walkarguments 
1774  1770  args 
1775  1771  (lambda (vars) 
1776   (walk #f fn 
 1772  (walk fn 
1777  1773  (lambda (r) 
1778  1774  (makenode '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) ) 
1779  1775  
1780   (define (walkcallunit returnvar unitname k) 
 1776  (define (walkcallunit unitname k) 
1781  1777  (let ((t0 (gensym 'k)) 
1782   (t3 (or returnvar (gensym 'r))) ) 
 1778  (t3 (gensym 'r)) ) 
1783  1779  (makenode 
1784  1780  'let (list t0) 
1785  1781  (list (makenode '##core#lambda (list (gensymfid) #f (list t3) 0) 
… 
… 

1800  1796  (loop (cdr args) (cons (car args) vars)) ) 
1801  1797  (else 
1802  1798  (let ((t1 (gensym 'a))) 
1803   (walk t1 
1804   (car args) 
 1799  (walk (car args) 
1805  1800  (lambda (r) 
1806  1801  (if (nodeforvar? r t1) ; Don't generate unneccessary lets 
1807  1802  (loop (cdr args) (cons (varnode t1) vars) ) 
… 
… 

1818  1813  ##core#inline_loc_ref ##core#inline_loc_update)) 
1819  1814  (every atomic? (nodesubexpressions n)) ) ) ) ) 
1820  1815  
1821   (walk #f node values) ) 
 1816  (walk node values) ) 
1822  1817  
1823  1818  
1824  1819  ;;; Foreign callback stub type: 
diff git a/tests/compilertests.scm b/tests/compilertests.scm
index 45b6bfd..444aa50 100644
a

b


217  217  
218  218  (gptest) 
219  219  
 220  ;; Optimizer would "lift" innerbar out of its let and replace 
 221  ;; outerbar with it, even though it wasn't visible yet. Caused by 
 222  ;; broken cpsconversion (underlying problem for #1068). 
 223  (let ((outerbar (##core#undefined))) 
 224  (let ((innerbar (let ((tmp (lambda (x) (if x '1 (outerbar '#t))))) 
 225  tmp))) 
 226  (set! outerbar innerbar) 
 227  (outerbar #f))) 
 228  
220  229  ;; Test that encodeliteral/decodeliteral use the proper functions 
221  230  ;; to decode number literals. 
222  231  (assert (equal? '(+inf.0 inf.0) (list (fp/ 1.0 0.0) (fp/ 1.0 0.0)))) 
diff git a/tests/syntaxtests.scm b/tests/syntaxtests.scm
index a5f4323..89481cd 100644
a

b

take 
1113  1113  (bar foo)) 
1114  1114  bar)) 
1115  1115  
 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  
1116  1128  (t 1 (letrec* ((foo 1) 
1117  1129  (bar foo)) 
1118   bar)) 
 1130  bar)) 