[Git][ghc/ghc][wip/T25281] Compiles now
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Sep 25 21:38:12 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
fd8fb94e by Simon Peyton Jones at 2024-09-25T22:37:40+01:00
Compiles now
- - - - -
1 changed file:
- compiler/GHC/HsToCore/Expr.hs
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -31,13 +31,11 @@ import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.Pmc
import GHC.HsToCore.Errors.Types
-import GHC.Types.SourceText
-import GHC.Types.Name hiding (varName)
-import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.HsToCore.Quote
import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
import GHC.Hs
+
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
import GHC.Tc.Utils.TcType
@@ -48,26 +46,31 @@ import GHC.Core.TyCo.Rep
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Make
+import GHC.Core.PatSyn
import GHC.Driver.Session
+
+import GHC.Types.SourceText
+import GHC.Types.Name hiding (varName)
+import GHC.Core.FamInstEnv( topNormaliseType )
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Id.Make
+import GHC.Types.Basic
+import GHC.Types.SrcLoc
+import GHC.Types.Tickish
+
import GHC.Unit.Module
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Builtin.Types
import GHC.Builtin.Names
-import GHC.Types.Basic
-import GHC.Types.SrcLoc
-import GHC.Types.Tickish
+
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import GHC.Core.PatSyn
import Control.Monad
-import GHC.Types.Error
{-
************************************************************************
@@ -385,7 +388,7 @@ dsExpr (ExplicitTuple _ tup_args boxity)
dsExpr (ExplicitSum types alt arity expr)
= mkCoreUnboxedSum arity alt types <$> dsLExpr expr
-dsExpr (HsPragE _ (HsPragSCC _ cc)) expr
+dsExpr (HsPragE _ (HsPragSCC _ cc) expr)
= do { dflags <- getDynFlags
; if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags
then do
@@ -411,11 +414,11 @@ dsExpr (HsLet _ binds body) = do
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
-dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
+dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
dsExpr (HsDo res_ty ctx at DoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty
dsExpr (HsDo res_ty ctx at GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts res_ty
dsExpr (HsDo res_ty ctx at MDoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty
-dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
dsExpr (HsIf _ guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
@@ -437,7 +440,6 @@ dsExpr (HsMultiIf res_ty alts)
mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
(text "multi-way if")
-
dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs
dsExpr (ArithSeq expr witness seq)
@@ -446,41 +448,35 @@ dsExpr (ArithSeq expr witness seq)
Just fl -> do { newArithSeq <- dsArithSeq expr seq
; dsSyntaxExpr fl [newArithSeq] }
-{-
-Static Pointers
-~~~~~~~~~~~~~~~
-
-See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
-
+{- Note [Desugaring static pointers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
+for an overview.
g = ... static f ...
==>
g = ... makeStatic loc f ...
-}
-dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do
- expr_ds <- dsLExpr expr
- let (_, [ty]) = splitTyConApp whole_ty
- makeStaticId <- dsLookupGlobalId makeStaticName
-
- dflags <- getDynFlags
- let platform = targetPlatform dflags
- let (line, col) = case locA loc of
- RealSrcSpan r _ ->
- ( srcLocLine $ realSrcSpanStart r
- , srcLocCol $ realSrcSpanStart r
- )
- _ -> (0, 0)
- srcLoc = mkCoreTup [ mkIntExprInt platform line
- , mkIntExprInt platform col
- ]
-
- putSrcSpanDsA loc $ return $
- mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
-
-{-
-\noindent
-\underline{\bf Record construction and update}
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+dsExpr (HsStatic (_, whole_ty) expr@(L loc _))
+ = do { expr_ds <- dsLExpr expr
+ ; let (_, [ty]) = splitTyConApp whole_ty
+ ; makeStaticId <- dsLookupGlobalId makeStaticName
+
+ ; dflags <- getDynFlags
+ ; let platform = targetPlatform dflags
+ (line, col) = case locA loc of
+ RealSrcSpan r _ -> ( srcLocLine $ realSrcSpanStart r
+ , srcLocCol $ realSrcSpanStart r )
+ _ -> (0, 0)
+ srcLoc = mkCoreTup [ mkIntExprInt platform line
+ , mkIntExprInt platform col
+ ]
+
+ ; putSrcSpanDsA loc $ return $
+ mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] }
+
+{- Note [Desugaring record construction]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For record construction we do this (assuming T has three arguments)
\begin{verbatim}
T { op2 = e }
@@ -503,6 +499,7 @@ constructor @C@, setting all of @C@'s fields to bottom.
dsExpr (RecordCon { rcon_con = L _ con_like
, rcon_flds = rbinds
, rcon_ext = con_expr })
+-- See Note [Desugaring record construction]
= do { con_expr' <- dsExpr con_expr
; let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
@@ -561,7 +558,7 @@ dsExpr (SectionR x _ _) = dataConCantHappen x
* *
********************************************************************* -}
-dsApp :: HsExpr -> DsM CoreExpr
+dsApp :: HsExpr GhcTc -> DsM CoreExpr
dsApp e = ds_app e [] []
----------------------
@@ -570,26 +567,27 @@ ds_lapp :: LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
-- but there may be more of the latter because they include
-- type and dictionary arguments
ds_lapp (L loc e) hs_args core_args
- = ds_app e hs_args core_args
+ = putSrcSpanDsA loc $
+ ds_app e hs_args core_args
-ds_app :: HsExpr GhcTc -> [LHsExpr] -> [CoreExpr] -> DsM CoreExpr
+ds_app :: HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
-- The work-horse
-ds_app (HsPar _ e) hs_args core_args = dsLApp e hs_args core_args
+ds_app (HsPar _ e) hs_args core_args = ds_lapp e hs_args core_args
ds_app (HsApp _ fun arg) hs_args core_args
= do { core_arg <- dsLExpr arg
- ; dsLApp fun (arg : hs_args) (core_arg : core_args) }
+ ; ds_lapp fun (arg : hs_args) (core_arg : core_args) }
ds_app (HsAppType arg_ty fun _) hs_args core_args
- = dsLApp fun hs_args (Type ty : core_args)
+ = ds_lapp fun hs_args (Type arg_ty : core_args)
ds_app (XExpr (WrapExpr hs_wrap fun)) hs_args core_args
= do { (fun_wrap, all_args) <- splitHsWrapperArgs hs_wrap core_args
; if isIdHsWrapper fun_wrap
- then ds_lapp fun hs_args all_args
+ then ds_app fun hs_args all_args
else do { core_fun <- dsHsWrapper fun_wrap $ \core_wrap ->
- do { core_fun <- dsLExpr fun
- ; return (fun_wrap core_fun) }
+ do { core_fun <- dsExpr fun
+ ; return (core_wrap core_fun) }
; return (mkCoreApps core_fun all_args) } }
ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args
@@ -607,7 +605,7 @@ ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args
; return (mkApps core_fun core_args) }
ds_app (HsRecSel _ fld_occ@(FieldOcc { foExt = fun_id })) hs_args core_args
- | RecSelId {sel_cons = (_, cons_wo_field)} <- idDetails id
+ | RecSelId {sel_cons = (_, cons_wo_field)} <- idDetails fun_id
= do { dflags <- getDynFlags
-- Record selectors are warned about if they are not present in all of the
@@ -640,40 +638,42 @@ ds_app (HsRecSel _ fld_occ@(FieldOcc { foExt = fun_id })) hs_args core_args
-- the warning emitted during the desugaring of dsExpr(HsRecSel)
-- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
-ds_app (HsVar _ (L _ fun_id)) core_args
+ds_app (HsVar _ (L _ fun_id)) _hs_args core_args
| fun_id `hasKey` noinlineIdKey -- See Note [noinlineId magic] in GHC.Types.Id.Make
, Type _ : arg1 : rest_args <- core_args
, (inner_fun, inner_args) <- collectArgs arg1
- = return (Var fun_id `App` Type (exprType inner_fun) `App` inner_fun)
- `mkCoreApps` inner_args `mkCoreApps` rest_args
+ = return (Var fun_id `App` Type (exprType inner_fun) `App` inner_fun
+ `mkCoreApps` inner_args `mkCoreApps` rest_args)
| fun_id `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2)
- , Type _r : Type ty1 : Type ty2 : arg1 : arg2 : rest_args
- = reuturn (Case arg1 case_bndr ty2 [Alt DEFAULT [] (mkCoreApps arg2 rest_args)])
- where
- case_bndr = case arg1 of
- Var v1 | isInternalName (idName v1)
- -> v1 -- Note [Desugaring seq], points (2) and (3)
- _ -> mkWildValBinder ManyTy ty1
+ , Type _r : Type ty1 : Type ty2 : arg1 : arg2 : rest_args <- core_args
+ , let case_bndr = case arg1 of
+ Var v1 | isInternalName (idName v1)
+ -> v1 -- Note [Desugaring seq], points (2) and (3)
+ _ -> mkWildValBinder ManyTy ty1
+ = return (Case arg1 case_bndr ty2 [Alt DEFAULT [] (mkCoreApps arg2 rest_args)])
| otherwise
= return (mkCoreApps (Var fun_id) core_args)
+ds_app e _hs_args core_args
+ = do { core_e <- dsExpr e
+ ; return (mkCoreApps core_e core_args) }
+
------------------------------
-splitHsWrapArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])
+splitHsWrapperArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])
-- Splits the wrapper into the trailing arguments, and leftover bit
-splitHsWrapArg w args = go w args
+splitHsWrapperArgs wrap args = go wrap args
where
go (WpTyApp ty) args = return (WpHole, Type ty : args)
go (WpEvApp tm) args = do { core_tm <- dsEvTerm tm
- ; (WpHole, Type ty : args)
+ ; return (WpHole, core_tm : args)}
go (WpCompose w1 w2) args
- = do { (w2', args') <- split_wrap w2 args
- ; if isIdHsWrapper w2'
- then go w1 args'
- else return (w1 <.> w2', args') }
- go wrap wrap args = return (wrap, args)
-
+ = do { (w1', args') <- go w1 args
+ ; if isIdHsWrapper w1'
+ then go w2 args'
+ else return (w1' <.> w2, args') }
+ go wrap args = return (wrap, args)
------------------------------
dsHsConLike :: ConLike -> DsM CoreExpr
@@ -689,8 +689,6 @@ dsHsConLike (PatSynCon ps)
| otherwise
= pprPanic "dsConLike" (ppr ps)
-
-
------------------------------
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExprTc { syn_expr = expr
@@ -818,10 +816,12 @@ Haskell 98 report:
-}
dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr
--- SG: Surprisingly, this code path seems inactive for regular Do,
+-- This code path seems inactive for regular Do,
-- which is expanded in GHC.Tc.Gen.Do.
--- It's all used for ApplicativeDo (even the BindStmt case), which is *very*
+-- It is used only for ApplicativeDo (even the BindStmt case), which is *very*
-- annoying because it is a lot of duplicated code that is seldomly tested.
+-- But we are on course to expane Applicative in GHC.Tc.Gen.Do, at which
+-- point all this will go away
dsDo ctx stmts res_ty
= goL stmts
where
@@ -986,11 +986,11 @@ Other places that requires from the same treatment:
-}
-- Warn about certain types of values discarded in monadic bindings (#3263)
-warnUnusedMonadBindValue :: FieldOcc GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> Type -> DsM ()
+warnUnusedMonadBindValue :: FieldOcc GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM ()
warnUnusedMonadBindValue (FieldOcc { foExt = fun_id, foLabel = L loc _ })
hs_args core_args
| fun_id `hasKey` thenMClassOpKey -- it is a (>>)
- , isGeneratedSrcSpan loc -- it is compiler generated (>>)
+ , isGeneratedSrcSpan (locA loc) -- it is compiler generated (>>)
, Type arg_ty : _ <- core_args
, hs_arg : _ <- hs_args
= putSrcSpanDs (locA loc) $ warnDiscardedDoBindings hs_arg arg_ty
@@ -1023,37 +1023,3 @@ warnDiscardedDoBindings rhs rhs_ty
| otherwise -- RHS does have type of form (m ty), which is weird
= return () -- but at least this warning is irrelevant
-
-{-
-************************************************************************
-* *
- dsHsWrapped
-* *
-************************************************************************
--}
-
-------------------------------
-dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
-dsHsWrapped orig_hs_expr
- = go idHsWrapper orig_hs_expr
- where
- go wrap (HsPar _ (L _ hs_e))
- = go wrap hs_e
- go wrap1 (XExpr (WrapExpr wrap2 hs_e))
- = go (wrap1 <.> wrap2) hs_e
- go wrap (HsAppType ty (L _ hs_e) _)
- = go (wrap <.> WpTyApp ty) hs_e
-
- go wrap (HsVar _ (L _ var))
- = do { dsHsWrapper wrap $ \wrap' -> do
- { let expr = wrap' (varToCoreExpr var)
- ty = exprType expr
- ; dflags <- getDynFlags
- ; warnAboutIdentities dflags var ty
- ; return expr } }
-
- go wrap hs_e
- = do { dsHsWrapper wrap $ \wrap' -> do
- { addTyCs FromSource (hsWrapDictBinders wrap) $
- do { e <- dsExpr hs_e
- ; return (wrap' e) } } }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd8fb94e0a7ee13c962102433912c5bf27579f29
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fd8fb94e0a7ee13c962102433912c5bf27579f29
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/20240925/2a6ab69c/attachment-0001.html>
More information about the ghc-commits
mailing list