[Git][ghc/ghc][wip/expand-do] wrap the mfix function arg tuple in a lazy pattern so that we do not go in a recursive loop

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
7bbd88de by Apoorv Ingle at 2023-03-27T11:01:05-05:00
wrap the mfix function arg tuple in a lazy pattern so that we do not go in a recursive loop

- - - - -


5 changed files:

- compiler/GHC/Tc/Gen/Match.hs
- testsuite/tests/rebindable/T18324.hs
- testsuite/tests/rebindable/T18324b.hs
- testsuite/tests/rebindable/all.T
- + testsuite/tests/rebindable/simple-rec.hs


Changes:

=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1296,17 +1296,17 @@ expand_do_stmts do_or_lc
 
     return_stmt  :: ExprLStmt GhcRn
     return_stmt  = noLocA $ LastStmt noExtField
-                                     (-- mkHsApp (noLocA return_fun)
-                                      --    $ 
-                                      mkBigLHsTup (map nlHsVar all_ids) noExtField)
+                                     (mkBigLHsTup (map nlHsVar all_ids) noExtField)
                                      Nothing
                                      (SyntaxExprRn return_fun)
     do_stmts     :: XRec GhcRn [ExprLStmt GhcRn]
     do_stmts     = noLocA $ (unLoc rec_stmts) ++ [return_stmt]
     do_block     :: LHsExpr GhcRn
-    do_block     = noLocA $ HsDo noExtField (MDoExpr Nothing) $ do_stmts
+    do_block     = noLocA $ HsDo noExtField (DoExpr Nothing) $ do_stmts
     mfix_expr    :: LHsExpr GhcRn
-    mfix_expr    = mkHsLam [ mkBigLHsVarPatTup all_ids ] $ do_block
+    mfix_expr    = mkHsLam [ noLocA (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] $ do_block
+                             -- LazyPat becuase we do not want to eagerly evaluate the pattern
+                             -- and potentially loop forever
 
 expand_do_stmts do_or_lc ((L _ (ApplicativeStmt _ args mb_join)): lstmts) =
 -- See Note [Applicative BodyStmt]


=====================================
testsuite/tests/rebindable/T18324.hs
=====================================
@@ -1,5 +1,5 @@
 {-# LANGUAGE ImpredicativeTypes, DeriveAnyClass #-}
--- {-# LANGUAGE MonadComprehensions, RecursiveDo #-}
+
 module Main where
 
 type Id = forall a. a -> a
@@ -14,6 +14,10 @@ foo1 = t >>= \x -> return (p x)
 
 foo2 = do { x <- t ; return (p x) }
 
+blah x y = return (3::Int)
+
 main = do x <- foo1
           putStrLn $ show x
+
+
           


=====================================
testsuite/tests/rebindable/T18324b.hs
=====================================
@@ -62,17 +62,8 @@ data HsDataDefn pass
 data FamEqn pass rhs
   = FamEqn
        { feqn_tycon  :: LIdP pass
-
--- LIdP (GhcRn) ~~> 
-
        , feqn_rhs    :: rhs }
 
--- type TyFamInstEqn pass = FamEqn pass (LHsType pass)
-
--- data TyFamInstDecl pass
---   = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
-
-
 fffggg :: ClsInstDecl GhcRn -> [Int]
 fffggg ddd = -- let
     -- data_fams = 
@@ -86,3 +77,5 @@ fffggg ddd = -- let
     --   TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts ddd
     --   [ 0 ]
     -- in data_fams ++ ty_fams
+
+


=====================================
testsuite/tests/rebindable/all.T
=====================================
@@ -46,3 +46,4 @@ test('T20126', normal, compile_fail, [''])
 test('T18324', normal, compile, [''])
 test('T23147', normal, compile, [''])
 test('pattern-fails', normal, compile_and_run, [''])
+test('simple-rec', normal, compile_and_run, [''])


=====================================
testsuite/tests/rebindable/simple-rec.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE RecursiveDo #-}
+module Main where
+
+
+blah x y = return (3::Int)
+
+main = do -- x <- foo1
+          rec {  y <- blah x y
+              ;  x <- blah x y
+              }
+          putStrLn $ show x



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bbd88de8535ade0bb26864e2d0021550a83ddcb

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7bbd88de8535ade0bb26864e2d0021550a83ddcb
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230327/093acf71/attachment-0001.html>