[Git][ghc/ghc][wip/T25281] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Sep 25 16:44:09 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
20b07472 by Simon Peyton Jones at 2024-09-25T17:43:55+01:00
Wibbles
- - - - -
1 changed file:
- compiler/GHC/HsToCore/Expr.hs
Changes:
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -259,38 +259,11 @@ dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e
-- | Desugar a typechecked expression.
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
-dsExpr (HsVar _ (L _ id)) = dsHsVar id
-
-{- Record selectors are warned about if they are not
-present in all of the parent data type's constructor,
-or always in case of pattern synonym record selectors
-(regulated by a flag). However, this only produces
-a warning if it's not a part of a record selector
-application. For example:
-
- data T = T1 | T2 {s :: Bool}
- f x = s x -- the warning from this case will be supressed
-
-See the `HsApp` case for where it is filtered out
--}
-dsExpr (HsRecSel _ (FieldOcc id _))
- = do { let name = getName id
- RecSelId {sel_cons = (_, cons_wo_field)}
- = idDetails id
- ; cons_trimmed <- trim_cons cons_wo_field
- ; unless (null cons_wo_field) $ diagnosticDs
- $ DsIncompleteRecordSelector name cons_trimmed (cons_trimmed /= cons_wo_field)
- -- This only produces a warning if it's not a part of a
- -- record selector application (e.g. `s a` where `s` is a selector)
- -- See the `HsApp` case for where it is filtered out
- ; dsHsVar id }
- where
- trim_cons :: [ConLike] -> DsM [ConLike]
- trim_cons cons_wo_field = do
- dflags <- getDynFlags
- let maxConstructors = maxUncoveredPatterns dflags
- return $ take maxConstructors cons_wo_field
+dsExpr e@(HsVar {}) = dsApp e
+dsExpr e@(HsApp {}) = dsApp e
+dsExpr e@(HsAppType {}) = dsApp e
+dsExpr e@(HsRecSel {}) = dsApp e
dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref
-- See Note [Holes] in GHC.Tc.Types.Constraint
@@ -298,11 +271,6 @@ dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref
dsExpr (HsPar _ e) = dsLExpr e
dsExpr (ExprWithTySig _ e _) = dsLExpr e
-dsExpr (HsIPVar x _) = dataConCantHappen x
-
-dsExpr (HsGetField x _ _) = dataConCantHappen x
-dsExpr (HsProjection x _) = dataConCantHappen x
-
dsExpr (HsLit _ lit)
= do { warnAboutOverflowedLit lit
; dsLit (convertLit lit) }
@@ -313,12 +281,13 @@ dsExpr (HsOverLit _ lit)
dsExpr e@(XExpr ext_expr_tc)
= case ext_expr_tc of
+ WrapExpr {} -> dsApp e
+ ConLikeTc {} -> dsApp e
+
ExpandedThingTc o e
| OrigStmt (L loc _) <- o
-> putSrcSpanDsA loc $ dsExpr e
| otherwise -> dsExpr e
- WrapExpr {} -> dsHsWrapped e
- ConLikeTc con tvs tys -> dsConLike con tvs tys
-- Hpc Support
HsTick tickish e -> do
e' <- dsLExpr e
@@ -347,7 +316,6 @@ dsExpr (NegApp _ (L loc
-- See Note [Checking "negative literals"]
(lit { ol_val = HsIntegral (negateIntegralLit i) })
; dsOverLit lit }
- ;
; dsSyntaxExpr neg_expr [mkTicks ts expr'] }
dsExpr (NegApp _ expr neg_expr)
@@ -357,69 +325,6 @@ dsExpr (NegApp _ expr neg_expr)
dsExpr (HsLam _ variant a_Match)
= uncurry mkCoreLams <$> matchWrapper (LamAlt variant) Nothing a_Match
-dsExpr e@(HsApp _ fun arg)
- = dsApp e []
-
-dsLApp :: LHsExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-dsLApp (L loc e) core_args = dsApp e core_args
-
-dsApp :: HsExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-
-dsApp (HsPar _ e) core_args = dsLApp e core_args
-
-dsApp (HsApp _ fun arg) core_args
- = do { core_arg <- dsLExpr arg
- ; dsLApp fun (core_arg : core_args) }
-
-dsApp (HsAppType arg_ty fun _) core_args
- = dsLApp fun (Type ty : core_args)
-
-dsApp (XExpr (WrapExpr hs_wrap fun)) core_args
- = do { (fun_wrap, all_args) <- split_wrap hs_wrap core_args
- ; if isIdHsWrapper fun_wrap
- then dsLApp fun all_args
- else ... }
- where
- split_wrap :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])
- split_wrap (WpTyApp ty) args
- = return (WpHole, Type ty : args)
- split_wrap (WpEvApp tm) args
- = do { core_tm <- dsEvTerm tm
- ; (WpHole, Type ty : args)
- split_wrap (WpCompose w1 w2) args
- = do { (w2', args') <- split_wrap w2 args
- ; if isIdHsWrapper w2'
- then split_wrap w1 args'
- else return (w1 <.> w2', args') }
- split_wrap wrap args
- = return (wrap, args)
-
-
-dsApp (HsVar _ v) core_args
- -- We want to have a special case that uses the PMC information to filter
- -- out some of the incomplete record selectors warnings and not trigger
- -- the warning emitted during the desugaring of dsExpr(HsRecSel)
- -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc
- = do { (msgs, fun') <- captureMessagesDs $ dsLExpr fun
- -- Make sure to filter out the generic incomplete record selector warning
- -- if it's a raw record selector
- ; arg' <- dsLExpr arg
- ; case getIdFromTrivialExpr_maybe fun' of
- Just fun_id | isRecordSelector fun_id
- -> do { let msgs' = filterMessages is_incomplete_rec_sel_msg msgs
- ; addMessagesDs msgs'
- ; pmcRecSel fun_id arg' }
- _ -> addMessagesDs msgs
- ; warnUnusedBindValue fun arg (exprType arg')
- ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
- where
- is_incomplete_rec_sel_msg :: MsgEnvelope DsMessage -> Bool
- is_incomplete_rec_sel_msg (MsgEnvelope {errMsgDiagnostic = DsIncompleteRecordSelector{}})
- = False
- is_incomplete_rec_sel_msg _ = True
-
-
-dsExpr e@(HsAppType {}) = dsHsWrapped e
{-
Note [Checking "negative literals"]
@@ -480,13 +385,17 @@ dsExpr (ExplicitTuple _ tup_args boxity)
dsExpr (ExplicitSum types alt arity expr)
= mkCoreUnboxedSum arity alt types <$> dsLExpr expr
-dsExpr (HsPragE _ prag expr) =
- ds_prag_expr prag expr
-
-dsExpr (HsEmbTy x _) = dataConCantHappen x
-dsExpr (HsQual x _ _) = dataConCantHappen x
-dsExpr (HsForAll x _ _) = dataConCantHappen x
-dsExpr (HsFunArr x _ _ _) = dataConCantHappen x
+dsExpr (HsPragE _ (HsPragSCC _ cc)) expr
+ = do { dflags <- getDynFlags
+ ; if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags
+ then do
+ mod_name <- getModule
+ count <- goptM Opt_ProfCountEntries
+ let nm = sl_fs cc
+ flavour <- mkExprCCFlavour <$> getCCIndexDsM nm
+ Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)
+ <$> dsLExpr expr
+ else dsLExpr expr }
dsExpr (HsCase ctxt discrim matches)
= do { core_discrim <- dsLExpr discrim
@@ -528,11 +437,6 @@ dsExpr (HsMultiIf res_ty alts)
mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
(text "multi-way if")
-{-
-\noindent
-\underline{\bf Various data construction things}
- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--}
dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs
@@ -620,7 +524,6 @@ dsExpr (RecordCon { rcon_con = L _ con_like
; return (mkCoreApps con_expr' con_args) }
-dsExpr (RecordUpd x _ _) = dataConCantHappen x
-- Here is where we desugar the Template Haskell brackets and escapes
@@ -635,27 +538,158 @@ dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext
-- Arrow notation extension
dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
-
-- HsSyn constructs that just shouldn't be here, because
--- the renamer removed them. See GHC.Rename.Expr.
+-- the renamer or typechecker removed them. See GHC.Rename.Expr.
-- Note [Handling overloaded and rebindable constructs]
-dsExpr (HsOverLabel x _) = dataConCantHappen x
-dsExpr (OpApp x _ _ _) = dataConCantHappen x
-dsExpr (SectionL x _ _) = dataConCantHappen x
-dsExpr (SectionR x _ _) = dataConCantHappen x
+dsExpr (HsIPVar x _) = dataConCantHappen x
+dsExpr (HsGetField x _ _) = dataConCantHappen x
+dsExpr (HsProjection x _) = dataConCantHappen x
+dsExpr (RecordUpd x _ _) = dataConCantHappen x
+dsExpr (HsEmbTy x _) = dataConCantHappen x
+dsExpr (HsQual x _ _) = dataConCantHappen x
+dsExpr (HsForAll x _ _) = dataConCantHappen x
+dsExpr (HsFunArr x _ _ _) = dataConCantHappen x
+dsExpr (HsOverLabel x _) = dataConCantHappen x
+dsExpr (OpApp x _ _ _) = dataConCantHappen x
+dsExpr (SectionL x _ _) = dataConCantHappen x
+dsExpr (SectionR x _ _) = dataConCantHappen x
+
+
+{- *********************************************************************
+* *
+* Desugaring applications
+* *
+********************************************************************* -}
+
+dsApp :: HsExpr -> DsM CoreExpr
+dsApp e = ds_app e [] []
+
+----------------------
+ds_lapp :: LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr
+-- The [LHsExpr] args correspond to the [CoreExpr] args,
+-- 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
+
+ds_app :: HsExpr GhcTc -> [LHsExpr] -> [CoreExpr] -> DsM CoreExpr
+-- The work-horse
+ds_app (HsPar _ e) hs_args core_args = dsLApp 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_app (HsAppType arg_ty fun _) hs_args core_args
+ = dsLApp fun hs_args (Type 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
+ else do { core_fun <- dsHsWrapper fun_wrap $ \core_wrap ->
+ do { core_fun <- dsLExpr fun
+ ; return (fun_wrap core_fun) }
+ ; return (mkCoreApps core_fun all_args) } }
+
+ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args
+-- Desugar desugars 'ConLikeTc': it eta-expands
+-- data constructors to make linear types work.
+-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
+ = do { ds_con <- dsHsConLike con
+ ; ids <- newSysLocalsDs tys
+ -- NB: these 'Id's may be representation-polymorphic;
+ -- see Wrinkle [Representation-polymorphic lambda] in
+ -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head.
+ ; let core_fun = mkLams tvs $ mkLams ids $
+ ds_con `mkTyApps` mkTyVarTys tvs
+ `mkVarApps` ids
+ ; 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
+ = do { dflags <- getDynFlags
+
+ -- Record selectors are warned about if they are not present in all of the
+ -- parent data type's constructor, or always in case of pattern synonym record
+ -- selectors (regulated by a flag). However, this only produces a warning if
+ -- it's not a part of a record selector application. For example:
+ -- data T = T1 | T2 {s :: Bool}
+ -- g y = map s y -- Warn here
+ -- f x = s x -- No warning here
+ ; let maxConstructors = maxUncoveredPatterns dflags
+ cons_trimmed = take maxConstructors cons_wo_field
+ ; when (null hs_args && not (null cons_wo_field)) $
+ diagnosticDs $ DsIncompleteRecordSelector (idName fun_id) cons_trimmed
+ (cons_trimmed /= cons_wo_field)
+
+ -- Type-based check
+ -- ToDo: explain
+ ; case filterOut isTypeArg core_args of
+ (arg:_) -> pmcRecSel fun_id arg
+ _ -> return ()
+
+ -- Warn about unused return value in
+ -- do { ...; e; ... } when e returns (say) an Int
+ ; warnUnusedMonadBindValue fld_occ hs_args core_args
+
+ ; return (mkCoreApps (Var fun_id) core_args) }
+
+-- We want to have a special case that uses the PMC information to filter
+-- out some of the incomplete record selectors warnings and not trigger
+-- 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
+ | 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
+
+ | 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
+
+ | otherwise
+ = return (mkCoreApps (Var fun_id) core_args)
+
+------------------------------
+splitHsWrapArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg])
+-- Splits the wrapper into the trailing arguments, and leftover bit
+splitHsWrapArg w args = go w args
+ where
+ go (WpTyApp ty) args = return (WpHole, Type ty : args)
+ go (WpEvApp tm) args = do { core_tm <- dsEvTerm tm
+ ; (WpHole, Type ty : 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)
+
+
+------------------------------
+dsHsConLike :: ConLike -> DsM CoreExpr
+dsHsConLike (RealDataCon dc)
+ = return (varToCoreExpr (dataConWrapId dc))
+dsHsConLike (PatSynCon ps)
+ | Just (builder_name, _, add_void) <- patSynBuilder ps
+ = do { builder_id <- dsLookupGlobalId builder_name
+ ; return (if add_void
+ then mkCoreApp (text "dsConLike" <+> ppr ps)
+ (Var builder_id) unboxedUnitExpr
+ else Var builder_id) }
+ | otherwise
+ = pprPanic "dsConLike" (ppr ps)
+
-ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
-ds_prag_expr (HsPragSCC _ cc) expr = do
- dflags <- getDynFlags
- if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags
- then do
- mod_name <- getModule
- count <- goptM Opt_ProfCountEntries
- let nm = sl_fs cc
- flavour <- mkExprCCFlavour <$> getCCIndexDsM nm
- Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)
- <$> dsLExpr expr
- else dsLExpr expr
------------------------------
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
@@ -943,49 +977,7 @@ Other places that requires from the same treatment:
because we already know 'y' is of the form "Just ...".
See test case T21360b.
-************************************************************************
-* *
- Desugaring Variables
-* *
-************************************************************************
--}
-
-dsHsVar :: Id -> DsM CoreExpr
--- We could just call dsHsUnwrapped; but this is a short-cut
--- for the very common case of a variable with no wrapper.
-dsHsVar var
- = return (varToCoreExpr var) -- See Note [Desugaring vars]
-dsHsConLike :: ConLike -> DsM CoreExpr
-dsHsConLike (RealDataCon dc)
- = return (varToCoreExpr (dataConWrapId dc))
-dsHsConLike (PatSynCon ps)
- | Just (builder_name, _, add_void) <- patSynBuilder ps
- = do { builder_id <- dsLookupGlobalId builder_name
- ; return (if add_void
- then mkCoreApp (text "dsConLike" <+> ppr ps)
- (Var builder_id) unboxedUnitExpr
- else Var builder_id) }
- | otherwise
- = pprPanic "dsConLike" (ppr ps)
-
--- | This function desugars 'ConLikeTc': it eta-expands
--- data constructors to make linear types work.
---
--- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
-dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr
-dsConLike con tvs tys
- = do { ds_con <- dsHsConLike con
- ; ids <- newSysLocalsDs tys
- -- NB: these 'Id's may be representation-polymorphic;
- -- see Wrinkle [Representation-polymorphic lambda] in
- -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head.
- ; return (mkLams tvs $
- mkLams ids $
- ds_con `mkTyApps` mkTyVarTys tvs
- `mkVarApps` ids) }
-
-{-
************************************************************************
* *
\subsection{Errors and contexts}
@@ -994,26 +986,16 @@ dsConLike con tvs tys
-}
-- Warn about certain types of values discarded in monadic bindings (#3263)
-warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
-warnUnusedBindValue fun arg@(L loc _) arg_ty
- | Just (l, f) <- fish_var fun
- , f `hasKey` thenMClassOpKey -- it is a (>>)
- = when (isGeneratedSrcSpan l) $ -- it is compiler generated (>>)
- putSrcSpanDs (locA loc) $ warnDiscardedDoBindings arg arg_ty
- where
- -- Retrieve the location info and the head of the application
- -- It is important that we /do not/ look through HsApp to avoid
- -- generating duplicate warnings
- -- See Part 2. of Note [Expanding HsDo with XXExprGhcRn]
- fish_var :: LHsExpr GhcTc -> Maybe (SrcSpan , Id)
- fish_var (L l (HsVar _ id)) = return (locA l, unLoc id)
- fish_var (L _ (HsAppType _ e _)) = fish_var e
- fish_var (L l (XExpr (WrapExpr _ e))) = do (l, e') <- fish_var (L l e)
- return (l, e')
- fish_var (L l (XExpr (ExpandedThingTc _ e))) = fish_var (L l e)
- fish_var _ = Nothing
-
-warnUnusedBindValue _ _ _ = return ()
+warnUnusedMonadBindValue :: FieldOcc GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> Type -> 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 (>>)
+ , Type arg_ty : _ <- core_args
+ , hs_arg : _ <- hs_args
+ = putSrcSpanDs (locA loc) $ warnDiscardedDoBindings hs_arg arg_ty
+ | otherwise
+ = return ()
-- Warn about certain types of values discarded in monadic bindings (#3263)
warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/20b07472ec530556a4e16a5e625a9f0652a09a6e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/20b07472ec530556a4e16a5e625a9f0652a09a6e
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/bec55062/attachment-0001.html>
More information about the ghc-commits
mailing list