[Git][ghc/ghc][wip/expand-do] rec do compiles but compiled code loops forever. I think I have broken the...
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Wed Mar 15 22:08:21 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
5af2773c by Apoorv Ingle at 2023-03-15T17:08:07-05:00
rec do compiles but compiled code loops forever. I think I have broken the mfix compilation. How do i debug this?
- - - - -
3 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Expr.hs
- testsuite/tests/rebindable/T18324.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -1055,11 +1055,12 @@ data HsExpansion orig expanded
= HsExpanded orig expanded
deriving Data
--- | Just print the original expression (the @a@).
+-- | Just print the original expression (the @a@) with the expanded version (the @b@)
instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
ppr (HsExpanded orig expanded)
- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
- (ppr orig)
+ -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+ -- (ppr orig)
+ = ppr orig <+> braces (text "Expansion:" <+> ppr expanded)
{-
@@ -1961,6 +1962,13 @@ matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block")
matchDoContextErrString ListComp = text "list comprehension"
matchDoContextErrString MonadComp = text "monad comprehension"
+instance Outputable HsDoFlavour where
+ ppr (DoExpr m) = text "DoExpr" <+> parens (ppr m)
+ ppr (MDoExpr m) = text "MDoExpr" <+> parens (ppr m)
+ ppr GhciStmtCtxt = text "GhciStmtCtxt"
+ ppr ListComp = text "ListComp"
+ ppr MonadComp = text "MonadComp"
+
pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -76,7 +76,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import Data.List (unzip4, minimumBy)
+import Data.List (unzip4, minimumBy, (\\))
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
import Data.Maybe (isJust, isNothing)
import Control.Arrow (first)
@@ -432,12 +432,20 @@ rnExpr (HsDo _ do_or_lc (L l stmts))
= do { ((stmts1, _), fvs1) <-
rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
(\ _ -> return ((), emptyFVs))
- ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
+ ; ((pp_stmts, fvs2), is_app_do) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
; let orig_do_block = HsDo noExtField do_or_lc (L l pp_stmts)
- expd_do_block = expand_do_stmts pp_stmts
- ; return ( mkExpandedExpr orig_do_block expd_do_block
- , fvs1 `plusFV` fvs2 ) }
-
+ ; return $ case do_or_lc of
+ DoExpr {} -> (if is_app_do
+ -- TODO i don't want to thing about applicative stmt rearrangements yet
+ then orig_do_block
+ else let expd_do_block = expand_do_stmts do_or_lc pp_stmts
+ in mkExpandedExpr orig_do_block expd_do_block
+ , fvs1 `plusFV` fvs2 )
+ _ -> (orig_do_block, fvs1 `plusFV` fvs2)
+ -- ListComp -> (orig_do_block, fvs1 `plusFV` fvs2)
+ -- MDoExpr {} -> (orig_do_block, fvs1 `plusFV` fvs2) -- TODO: Recursive mfix like do statements
+ -- GhciStmtCtxt -> (orig_do_block, fvs1 `plusFV` fvs2)
+ }
-- ExplicitList: see Note [Handling overloaded and rebindable constructs]
rnExpr (ExplicitList _ exps)
= do { (exps', fvs) <- rnExprs exps
@@ -1060,7 +1068,7 @@ rnStmts ctxt rnBody stmts thing_inside
postProcessStmtsForApplicativeDo
:: HsDoFlavour
-> [(ExprLStmt GhcRn, FreeVars)]
- -> RnM ([ExprLStmt GhcRn], FreeVars)
+ -> RnM (([ExprLStmt GhcRn], FreeVars), Bool) -- True <=> applicative do statement
postProcessStmtsForApplicativeDo ctxt stmts
= do {
-- rearrange the statements using ApplicativeStmt if
@@ -1074,8 +1082,10 @@ postProcessStmtsForApplicativeDo ctxt stmts
; in_th_bracket <- isBrackStage <$> getStage
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
- ; rearrangeForApplicativeDo ctxt stmts }
- else noPostProcessStmts (HsDoStmt ctxt) stmts }
+ ; ado_stmts_and_fvs <- rearrangeForApplicativeDo ctxt stmts
+ ; return (ado_stmts_and_fvs, True) }
+ else do { do_stmts_and_fvs <- noPostProcessStmts (HsDoStmt ctxt) stmts
+ ; return (do_stmts_and_fvs, False) } }
-- | strip the FreeVars annotations from statements
noPostProcessStmts
@@ -2711,50 +2721,107 @@ mkExpandedExpr a b = XExpr (HsExpanded a b)
-- | Expand the Do statments so that it works fine with Quicklook
-- See Note[Rebindable Do Expanding Statements]
-- ANI Questions: 1. What should be the location information in the expanded expression? Currently the error is still displayed on the expanded expr and not on the unexpanded expr
--- 2. Need to figure out the exact cases where this function needs to be called. It fails on lists
+-- 2. Need to figure out the exact cases where this function needs to be called. It fails on lists
-- 3. Convert let statements into expanded version.
-- 4. hopefully the co-recursive cases won't get affected by this expansion
-expand_do_stmts :: [ExprLStmt GhcRn] -> HsExpr GhcRn
-
-expand_do_stmts [L _ (LastStmt _ body _ NoSyntaxExprRn)]
--- TODO: not sure about this maybe this never happens in a do block?
--- This does happen in a list comprehension though
--- = genHsApp (genHsVar returnMName) body
- = unLoc body
-
-expand_do_stmts [L l (LastStmt _ body _ (SyntaxExprRn ret))]
---
+expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> HsExpr GhcRn
+
+expand_do_stmts do_flavour [L _ (LastStmt _ body _ NoSyntaxExprRn)]
+ -- if it is a last statement of a list comprehension, we need to explicitly return it -- See Note [TODO]
+ -- genHsApp (genHsVar returnMName) body
+ | ListComp <- do_flavour
+ = genHsApp (genHsVar returnMName) body
+ | MonadComp <- do_flavour
+ = unLoc body -- genHsApp (genHsVar returnMName) body
+ | otherwise
+ -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt
+ = unLoc body
+
+expand_do_stmts _ [L l (LastStmt _ body _ (SyntaxExprRn ret))]
+--
-- ------------------------------------------------
-- return e ~~> return e
-- definitely works T18324.hs
= unLoc $ mkHsApp (L l ret) body
-expand_do_stmts ((L l (BindStmt _ x e)):lstmts)
+expand_do_stmts do_or_lc ((L l (BindStmt _ x e)) : lstmts) =
-- stmts ~~> stmt'
-- ------------------------------------------------
--- x <- e ; stmts ~~> (Prelude.>>=) e (\ x -> stmts' )
- = genHsApps bindMName -- (>>=)
- [ e -- e
- , mkHsLam [x] (L l $ expand_do_stmts lstmts) -- (\ x -> stmts')
+-- x <- e ; stmts ~~> (Prelude.>>=) e (\ x -> stmts')
+ genHsApps bindMName -- (Prelude.>>=)
+ [ e
+ , mkHsLam [x] (L l $ expand_do_stmts do_or_lc lstmts) -- (\ x -> stmts')
]
--- expand_do_stmts ((L l (LetStmt _ x e)):lstmts) = undefined
+
+expand_do_stmts do_or_lc (L l (LetStmt _ bnds) : lstmts) =
-- stmts ~~> stmts'
-- ------------------------------------------------
-- let x = e ; stmts ~~> let x = e in stmts'
+ HsLet NoExtField noHsTok bnds noHsTok
+ $ L l (expand_do_stmts do_or_lc lstmts)
+
-expand_do_stmts ((L l (BodyStmt _ e (SyntaxExprRn f) _)):lstmts)
+expand_do_stmts do_or_lc ((L l (BodyStmt _ e (SyntaxExprRn f) _)) : lstmts) =
-- stmts ~~> stmts'
-- ----------------------------------------------
--- e ; stmts ~~> (Prelude.>>) e (\ _ -> stmt')
- = unLoc $ nlHsApp (nlHsApp (L l f) -- (>>) See Note [BodyStmt]
+-- e ; stmts ~~> (Prelude.>>) e stmt'
+ unLoc $ nlHsApp (nlHsApp (L l f) -- (>>) See Note [BodyStmt]
e)
- $ mkHsLam [] (L l $ expand_do_stmts lstmts)
+ $ (L l $ expand_do_stmts do_or_lc lstmts)
+
+expand_do_stmts do_or_lc ((L l (RecStmt { recS_stmts = rec_stmts
+ , recS_later_ids = later_ids -- forward referenced local ids
+ , recS_rec_ids = local_ids -- ids referenced outside of the rec block
+ , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr
+ , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr
+ -- use it at the end of expanded rec block
+ }))
+ : lstmts) =
+-- See Note [Typing a RecStmt]
+-- stmts ~~> stmts'
+-- -------------------------------------------------------------------------------------------
+-- rec { later_ids, local_ids, rec_block } ; stmts
+-- ~~> ((Prelude.>>=) (mfix (\[ local_ids ++ later_ids ]
+-- -> do { rec_stmts
+-- ; return (later_ids, local_ids) } )))
+-- (\ [ local_ids ++ later_ids ] -> stmts')
--- expand_do_stmts ((L l (TransStmt {})):lstmts) = undefined
--- expand_do_stmts ((L l (RecStmt {})):lstmts) = undefined
+ genHsApps bindMName -- (Prelude.>>=)
+ [ mkHsApp (noLocA mfix_fun) mfix_expr -- mfix (do block)
+ , mkHsLam [ mkBigLHsVarPatTup $ all_ids ]
+ (L l $ expand_do_stmts do_or_lc lstmts) -- (\ x -> stmts')
+ ]
+ where
+ local_only_ids = local_ids \\ later_ids -- get unique local rec ids; local rec ids and later ids can overlap
+ all_ids = local_only_ids ++ later_ids -- put local ids before return ids
+
+ return_stmt :: ExprLStmt GhcRn
+ return_stmt = noLocA $ LastStmt noExtField
+ (mkHsApp (noLocA return_fun)
+ $ 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 = L l $ HsDo noExtField (MDoExpr Nothing) $ do_stmts
+ mfix_expr :: LHsExpr GhcRn
+ mfix_expr = mkHsLam [ mkBigLHsVarPatTup all_ids ] $ do_block
+
+expand_do_stmts _ (stmt@(L _ (RecStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened RecStmt" $ ppr stmt
+
+
+expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened TransStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened ParStmt" $ ppr stmt
+
+expand_do_stmts _ (stmt@(L _ (ApplicativeStmt {})):_) =
+ pprPanic "expand_do_stmts: impossible happened ApplicativeStmt" $ ppr stmt
--- expand_do_stmts (stmt@(L _ (ParStmt {})):_) = pprPanic "expand_do_stmts: impossible happened" $ ppr stmt
-expand_do_stmts stmt = pprPanic "expand_do_stmts: impossible happened" $ ppr stmt
+expand_do_stmts do_flavor stmts = pprPanic "expand_do_stmts: impossible happened" $ (ppr do_flavor $$ ppr stmts)
-----------------------------------------
-- Bits and pieces for RecordDotSyntax.
=====================================
testsuite/tests/rebindable/T18324.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE ImpredicativeTypes, DeriveAnyClass #-}
+{-# LANGUAGE ImpredicativeTypes, DeriveAnyClass, MonadComprehensions #-}
module T18324 where
@@ -26,3 +26,9 @@ foo2 = do { x <- t ; return (p x) }
-- foo3 = do { x <- ts ; update ts ; return (p x) }
+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
+partitionM _ [] = pure ([], [])
+partitionM f (x:xs) = do
+ res <- f x
+ (as,bs) <- partitionM f xs
+ pure ([x | res]++as, [x | not res]++bs)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5af2773cc5a5c6763037c47050c4b9ee2a93015a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5af2773cc5a5c6763037c47050c4b9ee2a93015a
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/20230315/78b40aa5/attachment-0001.html>
More information about the ghc-commits
mailing list