Utils.hs 36.2 KB
 Austin Seipp committed Dec 03, 2014 1 2 3 4 {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  Simon Marlow committed Oct 11, 2006 5 6  Utilities for desugaring  partain committed Jan 08, 1996 7 8  This module exports some utility functions of no great interest.  Austin Seipp committed Dec 03, 2014 9 -}  partain committed Jan 08, 1996 10   Herbert Valerio Riedel committed May 15, 2014 11 {-# LANGUAGE CPP #-}  Alan Zimmerman committed Apr 09, 2018 12 {-# LANGUAGE FlexibleContexts #-}  Jonathan DK Gibbons committed Apr 22, 2020 13 {-# LANGUAGE LambdaCase #-}  Alan Zimmerman committed Apr 09, 2018 14 {-# LANGUAGE TypeFamilies #-}  Shayan-Najd committed Nov 24, 2018 15 {-# LANGUAGE ViewPatterns #-}  Ian Lynagh committed Nov 04, 2011 16   batterseapower committed Jul 31, 2008 17 -- | Utility functions for constructing Core syntax, principally for desugaring  Sylvain Henry committed Feb 14, 2020 18 module GHC.HsToCore.Utils (  Simon Peyton Jones committed Sep 26, 2014 19 20  EquationInfo(..), firstPat, shiftEqns,  simonpj committed May 18, 1999 21   Jonathan DK Gibbons committed Apr 22, 2020 22  MatchResult'(..), MatchResult, CaseAlt(..),  Simon Peyton Jones committed Sep 26, 2014 23 24  cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults,  John Ericson committed Apr 22, 2020 25  adjustMatchResultDs,  John Ericson committed Apr 22, 2020 26  shareFailureHandler,  Simon Peyton Jones committed Sep 26, 2014 27 28 29 30  mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, wrapBind, wrapBinds,  simonm committed Dec 02, 1998 31   Simon Peyton Jones committed Jul 30, 2015 32  mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,  batterseapower committed Jul 31, 2008 33 34 35 36  seqVar, -- LHs tuples  Richard Eisenberg committed Oct 03, 2019 37  mkLHsPatTup, mkVanillaTuplePat,  Simon Marlow committed Sep 17, 2015 38  mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,  batterseapower committed Jul 31, 2008 39 40 41  mkSelectorBinds,  Simon Peyton Jones committed Sep 26, 2014 42  selectSimpleMatchVarL, selectMatchVars, selectMatchVar,  Brian Foley committed Mar 15, 2020 43  mkOptTickBox, mkBinaryTickBox, decideBangHood,  Ryan Scott committed Jul 30, 2018 44  isTrueLHsExpr  partain committed Jan 08, 1996 45 46  ) where  simonm committed Jan 08, 1998 47 48 #include "HsVersions.h"  Herbert Valerio Riedel committed Sep 19, 2017 49 50 import GhcPrelude  Sylvain Henry committed Feb 14, 2020 51 52 import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )  partain committed Mar 19, 1996 53   Sylvain Henry committed Sep 20, 2019 54 import GHC.Hs  Sylvain Henry committed Apr 07, 2020 55 56 import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.TcType( tcSplitTyConApp )  Sylvain Henry committed Feb 26, 2020 57 import GHC.Core  Sylvain Henry committed Feb 14, 2020 58 import GHC.HsToCore.Monad  partain committed Mar 19, 1996 59   Sylvain Henry committed Feb 26, 2020 60 61 import GHC.Core.Utils import GHC.Core.Make  Sylvain Henry committed Mar 29, 2020 62 63 64 import GHC.Types.Id.Make import GHC.Types.Id import GHC.Types.Literal  Sylvain Henry committed Mar 16, 2020 65 66 67 68 69 import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.Type import GHC.Core.Coercion  Sylvain Henry committed Apr 18, 2020 70 71 import GHC.Builtin.Types.Prim import GHC.Builtin.Types  Sylvain Henry committed Mar 29, 2020 72 import GHC.Types.Basic  Sylvain Henry committed Mar 16, 2020 73 import GHC.Core.ConLike  Sylvain Henry committed Mar 29, 2020 74 75 76 import GHC.Types.Unique.Set import GHC.Types.Unique.Supply import GHC.Types.Module  Sylvain Henry committed Apr 18, 2020 77 import GHC.Builtin.Names  Sylvain Henry committed Mar 29, 2020 78 import GHC.Types.Name( isInternalName )  sof committed May 19, 1997 79 import Outputable  Sylvain Henry committed Mar 29, 2020 80 import GHC.Types.SrcLoc  Simon Marlow committed Oct 11, 2006 81 import Util  Sylvain Henry committed Feb 21, 2020 82 import GHC.Driver.Session  simonmar committed Apr 29, 2002 83 import FastString  Ben Gamari committed Dec 15, 2015 84 import qualified GHC.LanguageExtensions as LangExt  Simon Marlow committed Nov 02, 2011 85   Sylvain Henry committed Apr 07, 2020 86 import GHC.Tc.Types.Evidence  Gergő Érdi committed Jan 20, 2014 87   Simon Marlow committed Nov 02, 2011 88 import Control.Monad ( zipWithM )  John Ericson committed Jan 07, 2020 89 import Data.List.NonEmpty (NonEmpty(..))  Jonathan DK Gibbons committed Apr 22, 2020 90 import Data.Maybe (maybeToList)  John Ericson committed Jan 07, 2020 91 import qualified Data.List.NonEmpty as NEL  sof committed May 19, 1997 92   Austin Seipp committed Dec 03, 2014 93 94 95 {- ************************************************************************ * *  simonmar committed Jun 17, 1999 96 \subsection{ Selecting match variables}  Austin Seipp committed Dec 03, 2014 97 98 * * ************************************************************************  sof committed May 19, 1997 99 100 101 102 103  We're about to match against some patterns. We want to make some @Ids@ to use as match variables. If a pattern has an @Id@ readily at hand, which should indeed be bound to the pattern as a whole, then use it; otherwise, make one up.  Austin Seipp committed Dec 03, 2014 104 -}  sof committed May 19, 1997 105   Alan Zimmerman committed Jun 06, 2017 106 selectSimpleMatchVarL :: LPat GhcTc -> DsM Id  Simon Peyton Jones committed Jul 27, 2018 107 -- Postcondition: the returned Id has an Internal Name  chak@cse.unsw.edu.au. committed Aug 04, 2006 108 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)  simonpj committed Sep 30, 2004 109 110 111 112  -- (selectMatchVars ps tys) chooses variables of type tys -- to use for matching ps against. If the pattern is a variable, -- we try to use that, to save inventing lots of fresh variables.  chak@cse.unsw.edu.au. committed Aug 04, 2006 113 114 115 -- -- OLD, but interesting note: -- But even if it is a variable, its type might not match. Consider  Simon Peyton Jones committed Sep 26, 2014 116 117 118 -- data T a where -- T1 :: Int -> T Int -- T2 :: a -> T a  simonpj committed Sep 30, 2004 119 --  Simon Peyton Jones committed Sep 26, 2014 120 121 122 -- f :: T a -> a -> Int -- f (T1 i) (x::Int) = x -- f (T2 i) (y::a) = 0  chak@cse.unsw.edu.au. committed Aug 04, 2006 123 124 125 -- Then we must not choose (x::Int) as the matching variable! -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat  Alan Zimmerman committed Jun 06, 2017 126 selectMatchVars :: [Pat GhcTc] -> DsM [Id]  Simon Peyton Jones committed Jul 27, 2018 127 -- Postcondition: the returned Ids have Internal Names  chak@cse.unsw.edu.au. committed Aug 04, 2006 128 129 selectMatchVars ps = mapM selectMatchVar ps  Alan Zimmerman committed Jun 06, 2017 130 selectMatchVar :: Pat GhcTc -> DsM Id  Simon Peyton Jones committed Jul 27, 2018 131 -- Postcondition: the returned Id has an Internal Name  Alan Zimmerman committed Apr 09, 2018 132 133 134 135 selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat) selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat) selectMatchVar (ParPat _ pat) = selectMatchVar (unLoc pat) selectMatchVar (VarPat _ var) = return (localiseId (unLoc var))  Alan Zimmerman committed Nov 23, 2015 136  -- Note [Localise pattern binders]  Alan Zimmerman committed Apr 09, 2018 137 138 selectMatchVar (AsPat _ var _) = return (unLoc var) selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)  Simon Peyton Jones committed Sep 26, 2014 139  -- OK, better make up one...  sof committed May 19, 1997 140   Simon Peyton Jones committed Jul 27, 2018 141 142 {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Oct 21, 2010 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 Consider module M where [Just a] = e After renaming it looks like module M where [Just M.a] = e We don't generalise, since it's a pattern binding, monomorphic, etc, so after desugaring we may get something like M.a = case e of (v:_) -> case v of Just M.a -> M.a Notice the "M.a" in the pattern; after all, it was in the original pattern. However, after optimisation those pattern binders can become let-binders, and then end up floated to top level. They have a different *unique* by then (the simplifier is good about maintaining proper scoping), but it's BAD to have two top-level bindings with the External Name M.a, because that turns into two linker symbols for M.a. It's quite rare for this to actually *happen* -- the only case I know  Simon Peyton Jones committed Sep 26, 2014 160 of is tc003 compiled with the 'hpc' way -- but that only makes it  simonpj@microsoft.com committed Oct 21, 2010 161 162 163 164 165 166 167 168 169 170 171 172 173 all the more annoying. To avoid this, we craftily call 'localiseId' in the desugarer, which simply turns the External Name for the Id into an Internal one, but doesn't change the unique. So the desugarer produces this: M.a{r8} = case e of (v:_) -> case v of Just a{r8} -> M.a{r8} The unique is still 'r8', but the binding site in the pattern is now an Internal Name. Now the simplifier's usual mechanisms will propagate that Name to all the occurrence sites, as well as un-shadowing it, so we'll get M.a{r8} = case e of (v:_) -> case v of Just a{s77} -> a{s77}  Sylvain Henry committed Feb 26, 2020 174 In fact, even GHC.Core.Subst.simplOptExpr will do this, and simpleOptExpr  simonpj@microsoft.com committed Oct 21, 2010 175 176 177 runs on the output of the desugarer, so all is well by the end of the desugaring pass.  Sylvain Henry committed Feb 14, 2020 178 See also Note [MatchIds] in GHC.HsToCore.Match  sof committed May 19, 1997 179   Austin Seipp committed Dec 03, 2014 180 181 182 183 184 ************************************************************************ * * * type synonym EquationInfo and access functions for its pieces * * * ************************************************************************  partain committed Jan 08, 1996 185 186 187 188 \subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym} The equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions.  Austin Seipp committed Dec 03, 2014 189 -}  partain committed Jan 08, 1996 190   Alan Zimmerman committed Jun 06, 2017 191 firstPat :: EquationInfo -> Pat GhcTc  simonpj@microsoft.com committed May 02, 2007 192 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)  simonm committed Dec 02, 1998 193   John Ericson committed Jan 07, 2020 194 shiftEqns :: Functor f => f EquationInfo -> f EquationInfo  simonpj committed Mar 01, 2005 195 -- Drop the first pattern in each equation  John Ericson committed Jan 07, 2020 196 shiftEqns = fmap $\eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }  partain committed Jan 08, 1996 197   Austin Seipp committed Dec 03, 2014 198 -- Functions on MatchResults  simonm committed Dec 02, 1998 199   John Ericson committed Apr 22, 2020 200 matchCanFail :: MatchResult' a -> Bool  Jonathan DK Gibbons committed Apr 22, 2020 201 202 matchCanFail (MR_Fallible {}) = True matchCanFail (MR_Infallible {}) = False  simonpj committed Apr 04, 2005 203   simonpj committed Sep 30, 2004 204 alwaysFailMatchResult :: MatchResult  Jonathan DK Gibbons committed Apr 22, 2020 205 alwaysFailMatchResult = MR_Fallible$ \fail -> return fail  simonpj committed Sep 30, 2004 206   simonm committed Dec 02, 1998 207 cantFailMatchResult :: CoreExpr -> MatchResult  Jonathan DK Gibbons committed Apr 22, 2020 208 cantFailMatchResult expr = MR_Infallible $return expr  partain committed Jan 08, 1996 209   simonm committed Dec 02, 1998 210 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr  John Ericson committed Apr 22, 2020 211 212 213 214 extractMatchResult match_result failure_expr = runMatchResult failure_expr (shareFailureHandler match_result)  partain committed Jan 08, 1996 215   simonm committed Dec 02, 1998 216 combineMatchResults :: MatchResult -> MatchResult -> MatchResult  Jonathan DK Gibbons committed Apr 22, 2020 217 combineMatchResults match_result1@(MR_Infallible _) _  simonm committed Dec 02, 1998 218  = match_result1  John Ericson committed Apr 22, 2020 219 220 221 222 223 224 225 226 combineMatchResults match_result1 match_result2 = -- if the first pattern needs a failure handler (i.e. if it is is fallible), -- make it let-bind it bind it with shareFailureHandler. case shareFailureHandler match_result1 of MR_Infallible _ -> match_result1 MR_Fallible body_fn1 -> MR_Fallible$ \fail_expr -> -- Before actually failing, try the next match arm. body_fn1 =<< runMatchResult fail_expr match_result2  simonm committed Dec 02, 1998 227   Jonathan DK Gibbons committed Apr 22, 2020 228 229 230 231 232 233 adjustMatchResultDs :: (a -> DsM b) -> MatchResult' a -> MatchResult' b adjustMatchResultDs encl_fn = \case MR_Infallible body_fn -> MR_Infallible $encl_fn =<< body_fn MR_Fallible body_fn -> MR_Fallible$ \fail -> encl_fn =<< body_fn fail  simonm committed Dec 02, 1998 234   simonpj committed Mar 01, 2005 235 236 237 wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr wrapBinds [] e = e wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)  simonpj committed Sep 30, 2004 238   simonpj committed Mar 01, 2005 239 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr  Simon Peyton Jones committed Sep 26, 2014 240 241 wrapBind new old body -- NB: this function must deal with term | new==old = body -- variables, type variables or coercion variables  242  | otherwise = Let (NonRec new (varToCoreExpr old)) body  simonm committed Dec 02, 1998 243   simonpj@microsoft.com committed Feb 03, 2006 244 seqVar :: Var -> CoreExpr -> CoreExpr  Simon Peyton Jones committed Sep 20, 2019 245 seqVar var body = mkDefaultCase (Var var) var body  simonpj@microsoft.com committed Feb 03, 2006 246   simonpj committed Sep 30, 2004 247 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult  John Ericson committed Apr 22, 2020 248 mkCoLetMatchResult bind = fmap (mkCoreLet bind)  chak@cse.unsw.edu.au. committed Aug 04, 2006 249   eir@cis.upenn.edu committed Jan 27, 2016 250 251 252 -- (mkViewMatchResult var' viewExpr mr) makes the expression -- let var' = viewExpr in mr mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult  John Ericson committed Apr 22, 2020 253 mkViewMatchResult var' viewExpr = fmap $mkCoreLet$ NonRec var' viewExpr  Dan Licata committed Oct 10, 2007 254   chak@cse.unsw.edu.au. committed Aug 04, 2006 255 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult  John Ericson committed Apr 22, 2020 256 257 mkEvalMatchResult var ty = fmap $\e -> Case (Var var) var ty [(DEFAULT, [], e)]  simonm committed Dec 02, 1998 258 259  mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult  Jonathan DK Gibbons committed Apr 22, 2020 260 261 262 mkGuardedMatchResult pred_expr mr = MR_Fallible$ \fail -> do body <- runMatchResult fail mr return (mkIfThenElse pred_expr body fail)  partain committed Jan 08, 1996 263   Alan Zimmerman committed Jun 06, 2017 264 mkCoPrimCaseMatchResult :: Id -- Scrutinee  eir@cis.upenn.edu committed Dec 11, 2015 265 266 267  -> Type -- Type of the case -> [(Literal, MatchResult)] -- Alternatives -> MatchResult -- Literals are all unlifted  simonpj committed Sep 30, 2004 268 mkCoPrimCaseMatchResult var ty match_alts  Jonathan DK Gibbons committed Apr 22, 2020 269  = MR_Fallible mk_case  partain committed Jan 08, 1996 270  where  twanvl committed Jan 17, 2008 271 272 273  mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))  partain committed Jan 08, 1996 274   Simon Peyton Jones committed Sep 26, 2014 275  sorted_alts = sortWith fst match_alts -- Right order for a Case  Jonathan DK Gibbons committed Apr 22, 2020 276  mk_alt fail (lit, mr)  Simon Peyton Jones committed Nov 09, 2011 277  = ASSERT( not (litIsLifted lit) )  Jonathan DK Gibbons committed Apr 22, 2020 278  do body <- runMatchResult fail mr  Simon Peyton Jones committed Nov 09, 2011 279  return (LitAlt lit, [], body)  partain committed Jan 08, 1996 280   Gergő Érdi committed Jan 20, 2014 281 data CaseAlt a = MkCaseAlt{ alt_pat :: a,  eir@cis.upenn.edu committed Dec 11, 2015 282  alt_bndrs :: [Var],  Gergő Érdi committed Jan 20, 2014 283 284  alt_wrapper :: HsWrapper, alt_result :: MatchResult }  partain committed Jan 08, 1996 285   Simon Peyton Jones committed Sep 26, 2014 286 mkCoAlgCaseMatchResult  John Ericson committed Jan 07, 2020 287 288 289  :: Id -- ^ Scrutinee -> Type -- ^ Type of exp -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)  Simon Peyton Jones committed May 12, 2011 290  -> MatchResult  Ben Gamari committed Jun 02, 2018 291 mkCoAlgCaseMatchResult var ty match_alts  Gergő Érdi committed Jan 20, 2014 292  | isNewtype -- Newtype case; use a let  John Ericson committed Jan 07, 2020 293  = ASSERT( null match_alts_tail && null (tail arg_ids1) )  simonpj committed Mar 01, 2005 294  mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1  simonm committed Dec 02, 1998 295   Gergő Érdi committed Jan 20, 2014 296 297  | otherwise = mkDataConCase var ty match_alts  partain committed Jan 08, 1996 298  where  Gergő Érdi committed Jan 20, 2014 299 300  isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))  Simon Peyton Jones committed Sep 26, 2014 301 302  -- [Interesting: because of GADTs, we can't rely on the type of -- the scrutinised Id to be sufficiently refined to have a TyCon in it]  partain committed Apr 30, 1996 303   John Ericson committed Jan 07, 2020 304 305  alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail = match_alts  Gergő Érdi committed Jan 20, 2014 306 307 308  -- Stuff for newtype arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 var_ty = idType var  Simon Peyton Jones committed Sep 26, 2014 309 310  (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes -- (not that splitTyConApp does, these days)  chak@cse.unsw.edu.au. committed Sep 20, 2006 311  newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)  chak committed Feb 11, 2002 312   Gergő Érdi committed Jan 20, 2014 313 mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult  Jonathan DK Gibbons committed Apr 22, 2020 314 mkCoSynCaseMatchResult var ty alt = MR_Fallible $mkPatSynCase var ty alt  Gergő Érdi committed Jan 20, 2014 315 316 317  mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do  eir@cis.upenn.edu committed Dec 11, 2015 318  matcher <- dsLExpr$ mkLHsWrap wrapper $ Simon Peyton Jones committed Aug 29, 2017 319  nlHsTyApp matcher [getRuntimeRep ty, ty]  Jonathan DK Gibbons committed Apr 22, 2020 320  cont <- mkCoreLams bndrs <$> runMatchResult fail match_result  Ben Gamari committed Oct 30, 2015 321  return $mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]  Gergő Érdi committed Jan 20, 2014 322 323 324 325 326  where MkCaseAlt{ alt_pat = psyn, alt_bndrs = bndrs, alt_wrapper = wrapper, alt_result = match_result} = alt  Simon Peyton Jones committed Nov 21, 2014 327  (matcher, needs_void_lam) = patSynMatcher psyn  Gergő Érdi committed Jan 20, 2014 328   Sylvain Henry committed Mar 16, 2020 329  -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn  Gergő Érdi committed Nov 08, 2014 330  -- on these extra Void# arguments  Simon Peyton Jones committed Nov 21, 2014 331 332  ensure_unstrict cont | needs_void_lam = Lam voidArgId cont | otherwise = cont  Gergő Érdi committed Nov 08, 2014 333   John Ericson committed Jan 07, 2020 334 mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult  Jonathan DK Gibbons committed Apr 22, 2020 335 336 337 mkDataConCase var ty alts@(alt1 :| _) = liftA2 mk_case mk_default mk_alts -- The liftA2 combines the failability of all the alternatives and the default  Gergő Érdi committed Jan 20, 2014 338 339 340 341 342  where con1 = alt_pat alt1 tycon = dataConTyCon con1 data_cons = tyConDataCons tycon  Jonathan DK Gibbons committed Apr 22, 2020 343 344  sorted_alts :: [ CaseAlt DataCon ] sorted_alts = sortWith (dataConTag . alt_pat)$ NEL.toList alts  Gergő Érdi committed Jan 20, 2014 345 346 347 348 349  var_ty = idType var (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes -- (not that splitTyConApp does, these days)  Jonathan DK Gibbons committed Apr 22, 2020 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374  mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr mk_case def alts = mkWildCase (Var var) (idType var) ty $maybeToList def ++ alts mk_alts :: MatchResult' [CoreAlt] mk_alts = traverse mk_alt sorted_alts mk_alt :: CaseAlt DataCon -> MatchResult' CoreAlt mk_alt MkCaseAlt { alt_pat = con , alt_bndrs = args , alt_result = match_result } = flip adjustMatchResultDs match_result$ \body -> do case dataConBoxer con of Nothing -> return (DataAlt con, args, body) Just (DCB boxer) -> do us <- newUniqueSupply let (rep_ids, binds) = initUs_ us (boxer ty_args args) return (DataAlt con, rep_ids, mkLets binds body) mk_default :: MatchResult' (Maybe CoreAlt) mk_default | exhaustive_case = MR_Infallible $return Nothing | otherwise = MR_Fallible$ \fail -> return $Just (DEFAULT, [], fail) mentioned_constructors = mkUniqSet$ map alt_pat sorted_alts  Gergő Érdi committed Jan 20, 2014 375 376 377 378  un_mentioned_constructors = mkUniqSet data_cons minusUniqSet mentioned_constructors exhaustive_case = isEmptyUniqSet un_mentioned_constructors  Austin Seipp committed Dec 03, 2014 379 380 381 {- ************************************************************************ * *  partain committed Mar 19, 1996 382 \subsection{Desugarer's versions of some Core functions}  Austin Seipp committed Dec 03, 2014 383 384 385 * * ************************************************************************ -}  partain committed Jan 08, 1996 386   Simon Peyton Jones committed Sep 26, 2014 387 388 389 390 mkErrorAppDs :: Id -- The error function -> Type -- Type to which it should be applied -> SDoc -- The error message string to pass -> DsM CoreExpr  partain committed Apr 08, 1996 391   twanvl committed Jan 17, 2008 392 393 mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs  Ian Lynagh committed Jun 12, 2012 394  dflags <- getDynFlags  partain committed Apr 08, 1996 395  let  msosn committed Nov 18, 2015 396  full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])  Sylvain Henry committed Nov 22, 2018 397 398  core_msg = Lit (mkLitString full_msg) -- mkLitString returns a result of type String#  Simon Peyton Jones committed Aug 29, 2017 399  return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])  simonpj committed Sep 22, 2000 400   Austin Seipp committed Dec 03, 2014 401 {-  Ben Gamari committed Nov 19, 2019 402 403 404 405 406 407 408 409 410 411 412 413 'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. Note [Desugaring seq] ~~~~~~~~~~~~~~~~~~~~~ There are a few subtleties in the desugaring of seq: 1. (as described in #1031) Consider, f x y = x seq (y seq (# x,y #))  Sylvain Henry committed Feb 26, 2020 414  The [Core let/app invariant] means that, other things being equal, because  Ben Gamari committed Nov 19, 2019 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472  the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: f x y = case (y seq (# x,y #)) of v -> x seq v But that is bad for two reasons: (a) we now evaluate y before x, and (b) we can't bind v to an unboxed pair Seq is very, very special! So we recognise it right here, and desugar to case x of _ -> case y of _ -> (# x,y #) 2. (as described in #2273) Consider let chp = case b of { True -> fst x; False -> 0 } in chp seq ...chp... Here the seq is designed to plug the space leak of retaining (snd x) for too long. If we rely on the ordinary inlining of seq, we'll get let chp = case b of { True -> fst x; False -> 0 } case chp of _ { I# -> ...chp... } But since chp is cheap, and the case is an alluring contet, we'll inline chp into the case scrutinee. Now there is only one use of chp, so we'll inline a second copy. Alas, we've now ruined the purpose of the seq, by re-introducing the space leak: case (case b of {True -> fst x; False -> 0}) of I# _ -> ...case b of {True -> fst x; False -> 0}... We can try to avoid doing this by ensuring that the binder-swap in the case happens, so we get his at an early stage: case chp of chp2 { I# -> ...chp2... } But this is fragile. The real culprit is the source program. Perhaps we should have said explicitly let !chp2 = chp in ...chp2... But that's painful. So the code here does a little hack to make seq more robust: a saturated application of 'seq' is turned *directly* into the case expression, thus: x seq e2 ==> case x of x -> e2 -- Note shadowing! e1 seq e2 ==> case x of _ -> e2 So we desugar our example to: let chp = case b of { True -> fst x; False -> 0 } case chp of chp { I# -> ...chp... } And now all is well. The reason it's a hack is because if you define mySeq=seq, the hack won't work on mySeq. 3. (as described in #2409) The isLocalId ensures that we don't turn True seq e into case True of True { ... } which stupidly tries to bind the datacon 'True'.  Austin Seipp committed Dec 03, 2014 473 -}  simonpj@microsoft.com committed Jun 03, 2009 474   Richard Eisenberg committed Mar 17, 2017 475 -- NB: Make sure the argument is not levity polymorphic  Ben Gamari committed Oct 30, 2015 476 mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr  Ben Gamari committed Nov 19, 2019 477 478 mkCoreAppDs _ (Var f App Type _r App Type ty1 App Type ty2 App arg1) arg2 | f hasKey seqIdKey -- Note [Desugaring seq], points (1) and (2)  simonpj@microsoft.com committed Jun 03, 2009 479 480 481  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] where case_bndr = case arg1 of  Simon Peyton Jones committed Jan 05, 2017 482  Var v1 | isInternalName (idName v1)  Ben Gamari committed Nov 19, 2019 483  -> v1 -- Note [Desugaring seq], points (2) and (3)  Simon Peyton Jones committed Jan 05, 2017 484  _ -> mkWildValBinder ty1  simonpj@microsoft.com committed Jun 03, 2009 485   Sylvain Henry committed Feb 26, 2020 486 mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make  simonpj@microsoft.com committed Jun 03, 2009 487   Richard Eisenberg committed Mar 17, 2017 488 -- NB: No argument can be levity polymorphic  Ben Gamari committed Oct 30, 2015 489 mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr  Andreas Klebinger committed Aug 21, 2018 490 mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args  simonpj@microsoft.com committed Jun 03, 2009 491   Simon Peyton Jones committed Jul 30, 2015 492 mkCastDs :: CoreExpr -> Coercion -> CoreExpr  Sylvain Henry committed Feb 26, 2020 493 -- We define a desugarer-specific version of GHC.Core.Utils.mkCast,  Simon Peyton Jones committed Jul 30, 2015 494 495 496 497 498 499 -- because in the immediate output of the desugarer, we can have -- apparently-mis-matched coercions: E.g. -- let a = b -- in (x :: a) |> (co :: b ~ Int) -- Lint know about type-bindings for let and does not complain -- So here we do not make the assertion checks that we make in  Sylvain Henry committed Feb 26, 2020 500 -- GHC.Core.Utils.mkCast; and we do less peephole optimisation too  Simon Peyton Jones committed Jul 30, 2015 501 502 503 mkCastDs e co | isReflCo co = e | otherwise = Cast e co  Austin Seipp committed Dec 03, 2014 504 505 506 {- ************************************************************************ * *  Simon Peyton Jones committed Jul 30, 2015 507  Tuples and selector bindings  Austin Seipp committed Dec 03, 2014 508 509 * * ************************************************************************  partain committed Jan 08, 1996 510 511 512  This is used in various places to do with lazy patterns. For each binder $b$ in the pattern, we create a binding:  simonmar committed Jun 17, 1999 513 \begin{verbatim}  partain committed Jan 08, 1996 514  b = case v of pat' -> b'  simonmar committed Jun 17, 1999 515 516 \end{verbatim} where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.  partain committed Jan 08, 1996 517 518 519 520 521 522 523 524 525 526  ToDo: making these bindings should really depend on whether there's much work to be done per binding. If the pattern is complex, it should be de-mangled once, into a tuple (and then selected from). Otherwise the demangling can be in-line in the bindings (as here). Boring! Boring! One error message per binder. The above ToDo is even more helpful. Something very similar happens for pattern-bound expressions.  Simon Peyton Jones committed Sep 05, 2011 527 528 Note [mkSelectorBinds] ~~~~~~~~~~~~~~~~~~~~~~  Simon Peyton Jones committed Feb 26, 2016 529 530 531 532 533 534 mkSelectorBinds is used to desugar a pattern binding {p = e}, in a binding group: let { ...; p = e; ... } in body where p binds x,y (this list of binders can be empty). There are two cases.  Simon Peyton Jones committed Sep 30, 2016 535 536 537 538 539 540 ------ Special case (A) ------- For a pattern that is just a variable, let !x = e in body ==> let x = e in x seq body So we return the binding, with 'x' as the variable to seq.  Simon Peyton Jones committed Feb 26, 2016 541   Simon Peyton Jones committed Sep 30, 2016 542 ------ Special case (B) -------  Simon Peyton Jones committed Feb 26, 2016 543 544 545 546 547 548 549 550 551 552 553  For a pattern that is essentially just a tuple: * A product type, so cannot fail * Only one level, so that - generating multiple matches is fine - seq'ing it evaluates the same as matching it Then instead we generate { v = e ; x = case v of p -> x ; y = case v of p -> y } with 'v' as the variable to force  Simon Peyton Jones committed Sep 30, 2016 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 ------ General case (C) ------- In the general case we generate these bindings: let { ...; p = e; ... } in body ==> let { t = case e of p -> (x,y) ; x = case t of (x,y) -> x ; y = case t of (x,y) -> y } in t seq body Note that we return 't' as the variable to force if the pattern is strict (i.e. with -XStrict or an outermost-bang-pattern) Note that (A) /includes/ the situation where * The pattern binds exactly one variable let !(Just (Just x) = e in body ==> let { t = case e of Just (Just v) -> Unit v ; v = case t of Unit v -> v } in t seq body  Sylvain Henry committed Apr 18, 2020 574  The 'Unit' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types  Simon Peyton Jones committed Sep 30, 2016 575 576 577 578 579 580 581 582 583 584 585  Note that forcing 't' makes the pattern match happen, but does not force 'v'. * The pattern binds no variables let !(True,False) = e in body ==> let t = case e of (True,False) -> () in t seq body ------ Examples ----------  Simon Peyton Jones committed Feb 26, 2016 586 587 588 589 590 591 592 593 594  * !(_, (_, a)) = e ==> t = case e of (_, (_, a)) -> Unit a a = case t of Unit a -> a Note that - Forcing 't' will force the pattern to match fully; e.g. will diverge if (snd e) is bottom - But 'a' itself is not forced; it is wrapped in a one-tuple  Sylvain Henry committed Apr 18, 2020 595  (see Note [One-tuples] in GHC.Builtin.Types)  Simon Peyton Jones committed Feb 26, 2016 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656  * !(Just x) = e ==> t = case e of Just x -> Unit x x = case t of Unit x -> x Again, forcing 't' will fail if 'e' yields Nothing. Note that even though this is rather general, the special cases work out well: * One binder, not -XStrict: let Just (Just v) = e in body ==> let t = case e of Just (Just v) -> Unit v v = case t of Unit v -> v in body ==> let v = case (case e of Just (Just v) -> Unit v) of Unit v -> v in body ==> let v = case e of Just (Just v) -> v in body * Non-recursive, -XStrict let p = e in body ==> let { t = case e of p -> (x,y) ; x = case t of (x,y) -> x ; y = case t of (x,y) -> x } in t seq body ==> {inline seq, float x,y bindings inwards} let t = case e of p -> (x,y) in case t of t' -> let { x = case t' of (x,y) -> x ; y = case t' of (x,y) -> x } in body ==> {inline t, do case of case} case e of p -> let t = (x,y) in let { x = case t' of (x,y) -> x ; y = case t' of (x,y) -> x } in body ==> {case-cancellation, drop dead code} case e of p -> body * Special case (B) is there to avoid fruitlessly taking the tuple apart and rebuilding it. For example, consider { K x y = e } where K is a product constructor. Then general case (A) does: { t = case e of K x y -> (x,y) ; x = case t of (x,y) -> x ; y = case t of (x,y) -> y } In the lazy case we can't optimise out this fruitless taking apart and rebuilding. Instead (B) builds { v = e ; x = case v of K x y -> x ; y = case v of K x y -> y } which is better.  Austin Seipp committed Dec 03, 2014 657 -}  Simon Peyton Jones committed Sep 05, 2011 658   Simon Peyton Jones committed Feb 26, 2016 659 mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly  Alan Zimmerman committed Jun 06, 2017 660  -> LPat GhcTc -- ^ The pattern  Adam Sandberg Eriksson committed Nov 14, 2015 661  -> CoreExpr -- ^ Expression to which the pattern is bound  Simon Peyton Jones committed Feb 26, 2016 662  -> DsM (Id,[(Id,CoreExpr)])  Adam Sandberg Eriksson committed Nov 14, 2015 663  -- ^ Id the rhs is bound to, for desugaring strict  Sylvain Henry committed Feb 14, 2020 664  -- binds (see Note [Desugar Strict binds] in GHC.HsToCore.Binds)  Adam Sandberg Eriksson committed Nov 14, 2015 665 666  -- and all the desugared binds  Simon Peyton Jones committed Feb 26, 2016 667 mkSelectorBinds ticks pat val_expr  Vladislav Zavialov committed Nov 30, 2019 668  | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)  Simon Peyton Jones committed Sep 30, 2016 669 670 671  = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B)  Sebastian Graf committed Nov 02, 2019 672  = do { let pat_ty = hsLPatType pat'  Richard Eisenberg committed Jan 19, 2017 673  ; val_var <- newSysLocalDsNoLP pat_ty  Simon Peyton Jones committed Feb 26, 2016 674   Simon Peyton Jones committed Sep 30, 2016 675  ; let mk_bind tick bndr_var  Simon Peyton Jones committed Feb 26, 2016 676 677  -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } -- Remember, 'pat' binds 'bv'  Simon Peyton Jones committed Sep 30, 2016 678  = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'  Simon Peyton Jones committed Feb 26, 2016 679 680 681 682 683 684 685 686  (Var bndr_var) (Var bndr_var) -- Neat hack -- Neat hack: since 'pat' can't fail, the -- "fail-expr" passed to matchSimply is not -- used. But it /is/ used for its type, and for -- that bndr_var is just the ticket. ; return (bndr_var, mkOptTickBox tick rhs_expr) }  Simon Peyton Jones committed Sep 30, 2016 687  ; binds <- zipWithM mk_bind ticks' binders  Simon Peyton Jones committed Feb 26, 2016 688 689  ; return ( val_var, (val_var, val_expr) : binds) }  Simon Peyton Jones committed Sep 30, 2016 690  | otherwise -- General case (C)  Simon Peyton Jones committed Feb 26, 2016 691  = do { tuple_var <- newSysLocalDs tuple_ty  David Feuer committed Jan 15, 2018 692  ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')  Simon Peyton Jones committed Feb 26, 2016 693  ; tuple_expr <- matchSimply val_expr PatBindRhs pat  Simon Peyton Jones committed Feb 18, 2016 694  local_tuple error_expr  Simon Marlow committed Nov 02, 2011 695  ; let mk_tup_bind tick binder  Simon Peyton Jones committed Feb 18, 2016 696  = (binder, mkOptTickBox tick $ Simon Peyton Jones committed Feb 26, 2016 697 698 699 700  mkTupleSelector1 local_binders binder tuple_var (Var tuple_var)) tup_binds = zipWith mk_tup_bind ticks' binders ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }  simonpj committed Feb 24, 1998 701  where  Simon Peyton Jones committed Sep 30, 2016 702 703 704 705 706  pat' = strip_bangs pat -- Strip the bangs before looking for case (A) or (B) -- The incoming pattern may well have a bang on it binders = collectPatBinders pat'  Simon Peyton Jones committed Feb 26, 2016 707  ticks' = ticks ++ repeat []  Simon Marlow committed Nov 02, 2011 708 709  local_binders = map localiseId binders -- See Note [Localise pattern binders]  Simon Peyton Jones committed Feb 26, 2016 710  local_tuple = mkBigCoreVarTup1 binders  simonpj@microsoft.com committed Oct 21, 2010 711  tuple_ty = exprType local_tuple  simonpj committed Feb 24, 1998 712   Shayan-Najd committed Nov 24, 2018 713 strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)  Simon Peyton Jones committed Sep 30, 2016 714 -- Remove outermost bangs and parens  Vladislav Zavialov committed Nov 30, 2019 715 716 717 strip_bangs (L _ (ParPat _ p)) = strip_bangs p strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp = lp  simonpj committed Feb 24, 1998 718   Shayan-Najd committed Nov 24, 2018 719 720 is_flat_prod_lpat :: LPat (GhcPass p) -> Bool is_flat_prod_lpat = is_flat_prod_pat . unLoc  simonmar committed Dec 10, 2003 721   Shayan-Najd committed Nov 24, 2018 722 is_flat_prod_pat :: Pat (GhcPass p) -> Bool  Alan Zimmerman committed Apr 09, 2018 723 724 is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps  Vladislav Zavialov committed Nov 30, 2019 725 is_flat_prod_pat (ConPatOut { pat_con = L _ pcon  Shayan-Najd committed Nov 24, 2018 726  , pat_args = ps})  Simon Peyton Jones committed Sep 30, 2016 727 728 729 730  | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False  simonpj committed Feb 24, 1998 731   Shayan-Najd committed Nov 24, 2018 732 733 is_triv_lpat :: LPat (GhcPass p) -> Bool is_triv_lpat = is_triv_pat . unLoc  simonmar committed Dec 10, 2003 734   Shayan-Najd committed Nov 24, 2018 735 is_triv_pat :: Pat (GhcPass p) -> Bool  Alan Zimmerman committed Apr 09, 2018 736 737 738 739 is_triv_pat (VarPat {}) = True is_triv_pat (WildPat{}) = True is_triv_pat (ParPat _ p) = is_triv_lpat p is_triv_pat _ = False  simonpj@microsoft.com committed Dec 20, 2007 740   Simon Peyton Jones committed Feb 26, 2016 741 742 743 744 745  {- ********************************************************************* * * Creating big tuples and their types for full Haskell expressions. They work over *Ids*, and create tuples replete with their types,  Sylvain Henry committed Sep 20, 2019 746  which is whey they are not in GHC.Hs.Utils.  Simon Peyton Jones committed Feb 26, 2016 747 748 * * ********************************************************************* -}  simonpj@microsoft.com committed Dec 20, 2007 749   Alan Zimmerman committed Jun 06, 2017 750 mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc  simonpj@microsoft.com committed Jun 05, 2008 751 mkLHsPatTup [] = noLoc$ mkVanillaTuplePat [] Boxed  simonpj@microsoft.com committed Dec 20, 2007 752 mkLHsPatTup [lpat] = lpat  Vladislav Zavialov committed Nov 30, 2019 753 mkLHsPatTup lpats = L (getLoc (head lpats)) $ Simon Peyton Jones committed Sep 26, 2014 754  mkVanillaTuplePat lpats Boxed  simonpj@microsoft.com committed Dec 20, 2007 755   Alan Zimmerman committed Jun 06, 2017 756 mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc  simonpj@microsoft.com committed Jul 23, 2009 757 -- A vanilla tuple pattern simply gets its type from its sub-patterns  Sebastian Graf committed Nov 02, 2019 758 mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box  simonpj@microsoft.com committed Jul 23, 2009 759   simonpj@microsoft.com committed Dec 20, 2007 760 -- The Big equivalents for the source tuple expressions  Alan Zimmerman committed Jun 06, 2017 761 mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc  Simon Marlow committed Sep 17, 2015 762 mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)  simonpj@microsoft.com committed Dec 20, 2007 763   Alan Zimmerman committed Jun 06, 2017 764 mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc  Simon Marlow committed Sep 17, 2015 765 mkBigLHsTupId = mkChunkified mkLHsTupleExpr  simonpj@microsoft.com committed Dec 20, 2007 766 767  -- The Big equivalents for the source tuple patterns  Alan Zimmerman committed Jun 06, 2017 768 mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc  Simon Marlow committed Sep 17, 2015 769 mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)  simonpj@microsoft.com committed Dec 20, 2007 770   Alan Zimmerman committed Jun 06, 2017 771 mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc  Simon Marlow committed Sep 17, 2015 772 mkBigLHsPatTupId = mkChunkified mkLHsPatTup  simonpj committed May 18, 1999 773   Austin Seipp committed Dec 03, 2014 774 775 776 {- ************************************************************************ * *  Simon Peyton Jones committed Jul 30, 2015 777  Code for pattern-matching and other failures  Austin Seipp committed Dec 03, 2014 778 779 * * ************************************************************************  partain committed Jan 08, 1996 780 781 782 783  Generally, we handle pattern matching failure like this: let-bind a fail-variable, and use that variable if the thing fails: \begin{verbatim}  Simon Peyton Jones committed Sep 26, 2014 784 785 786 787 788 789 790  let fail.33 = error "Help" in case x of p1 -> ... p2 -> fail.33 p3 -> fail.33 p4 -> ...  partain committed Jan 08, 1996 791 792 793 794 \end{verbatim} Then \begin{itemize} \item  simonmar committed Jun 17, 1999 795 If the case can't fail, then there'll be no mention of @fail.33@, and the  partain committed Jan 08, 1996 796 797 798 799 800 801 802 803 804 805 simplifier will later discard it. \item If it can fail in only one way, then the simplifier will inline it. \item Only if it is used more than once will the let-binding remain. \end{itemize} There's a problem when the result of the case expression is of  simonmar committed Jun 17, 1999 806 unboxed type. Then the type of @fail.33@ is unboxed too, and  partain committed Jan 08, 1996 807 808 there is every chance that someone will change the let into a case: \begin{verbatim}  Simon Peyton Jones committed Sep 26, 2014 809 810  case error "Help" of fail.33 -> case ....  partain committed Jan 08, 1996 811 812 813 \end{verbatim} which is of course utterly wrong. Rather than drop the condition that  partain committed Mar 19, 1996 814 only boxed types can be let-bound, we just turn the fail into a function  partain committed Jan 08, 1996 815 816 for the primitive case: \begin{verbatim}  Simon Peyton Jones committed Sep 26, 2014 817 818 819 820 821 822 823 824  let fail.33 :: Void -> Int# fail.33 = \_ -> error "Help" in case x of p1 -> ... p2 -> fail.33 void p3 -> fail.33 void p4 -> ...  partain committed Jan 08, 1996 825 826 \end{verbatim}  simonmar committed Jun 17, 1999 827 Now @fail.33@ is a function, so it can be let-bound.  lukemaurer committed Feb 01, 2017 828 829 830 831 832 833 834 835 836  We would *like* to use join points here; in fact, these "fail variables" are paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as CPS functions - i.e. they take "join points" as parameters. It's not impossible to imagine extending our type system to allow passing join points around (very carefully), but we certainly don't support it now. 99.99% of the time, the fail variables wind up as join points in short order anyway, and the Void# doesn't do much harm.  Austin Seipp committed Dec 03, 2014 837 -}  partain committed Jan 08, 1996 838   Simon Peyton Jones committed Sep 26, 2014 839 840 841 842 mkFailurePair :: CoreExpr -- Result type of the whole case expression -> DsM (CoreBind, -- Binds the newly-created fail variable -- to \ _ -> expression CoreExpr) -- Fail variable applied to realWorld#  simonpj@microsoft.com committed Sep 08, 2009 843 -- See Note [Failure thunks and CPR]  simonm committed Dec 02, 1998 844 mkFailurePair expr  Simon Peyton Jones committed Feb 23, 2019 845  = do { fail_fun_var <- newFailLocalDs (voidPrimTy mkVisFunTy ty)  Simon Peyton Jones committed Nov 22, 2013 846 847 848 849  ; fail_fun_arg <- newSysLocalDs voidPrimTy ; let real_arg = setOneShotLambda fail_fun_arg ; return (NonRec fail_fun_var (Lam real_arg expr), App (Var fail_fun_var) (Var voidPrimId)) }  simonm committed Dec 02, 1998 850  where  simonpj committed Mar 23, 2000 851  ty = exprType expr  partain committed Jun 05, 1996 852   John Ericson committed Apr 22, 2020 853 854 855 856 857 858 859 860 861 862 863 864 -- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have -- neither a failure arg or failure "hole", so nothing is let-bound, and no -- extraneous Core is produced. shareFailureHandler :: MatchResult -> MatchResult shareFailureHandler = \case mr@(MR_Infallible _) -> mr MR_Fallible match_fn -> MR_Fallible$ \fail_expr -> do (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr body <- match_fn shared_failure_handler -- Never unboxed, per the above, so always OK for let not case. return $Let fail_bind body  Austin Seipp committed Dec 03, 2014 865 {-  simonpj@microsoft.com committed Sep 08, 2009 866 867 Note [Failure thunks and CPR] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  lukemaurer committed Feb 01, 2017 868 869 870 (This note predates join points as formal entities (hence the quotation marks). We can't use actual join points here (see above); if we did, this would also solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR  Sylvain Henry committed Apr 18, 2020 871 join points] in GHC.Core.Opt.WorkWrap.)  lukemaurer committed Feb 01, 2017 872   simonpj@microsoft.com committed Sep 08, 2009 873 874 875 876 When we make a failure point we ensure that it does not look like a thunk. Example: let fail = \rw -> error "urk"  Simon Peyton Jones committed Sep 26, 2014 877  in case x of  simonpj@microsoft.com committed Sep 08, 2009 878 879  [] -> fail realWorld# (y:ys) -> case ys of  Simon Peyton Jones committed Sep 26, 2014 880  [] -> fail realWorld#  simonpj@microsoft.com committed Sep 08, 2009 881 882 883 884 885 886  (z:zs) -> (y,z) Reason: we know that a failure point is always a "join point" and is entered at most once. Adding a dummy 'realWorld' token argument makes it clear that sharing is not an issue. And that in turn makes it more CPR-friendly. This matters a lot: if you don't get it right, you lose  Ryan Scott committed Mar 15, 2019 887 the tail call property. For example, see #3403.  Simon Peyton Jones committed Jul 30, 2015 888 889 890 891 892 893 894  ************************************************************************ * * Ticks * * ********************************************************************* -}  simonpj@microsoft.com committed Sep 08, 2009 895   Peter Wortmann committed Dec 16, 2014 896 897 mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr mkOptTickBox = flip (foldr Tick)  andy@galois.com committed Oct 24, 2006 898 899 900  mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do  Simon Peyton Jones committed Sep 26, 2014 901  uq <- newUnique  ian@well-typed.com committed Nov 06, 2012 902  this_mod <- getModule  Simon Marlow committed Nov 02, 2011 903 904 905 906 907  let bndr1 = mkSysLocal (fsLit "t1") uq boolTy let falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) --  andy@galois.com committed Dec 13, 2006 908 909 910 911  return$ Case e bndr1 boolTy [ (DataAlt falseDataCon, [], falseBox) , (DataAlt trueDataCon, [], trueBox) ]  Adam Sandberg Eriksson committed Nov 14, 2015 912 913 914 915 916  -- *******************************************************************  Simon Peyton Jones committed Jul 27, 2018 917 918 919 920 921 922 923 924 925 926 927 928 929 930 {- Note [decideBangHood] ~~~~~~~~~~~~~~~~~~~~~~~~ With -XStrict we may make /outermost/ patterns more strict. E.g. let (Just x) = e in ... ==> let !(Just x) = e in ... and f x = e ==> f !x = e This adjustment is done by decideBangHood,  Sylvain Henry committed Feb 14, 2020 931  * Just before constructing an EqnInfo, in GHC.HsToCore.Match  Simon Peyton Jones committed Jul 27, 2018 932 933  (matchWrapper and matchSinglePat)  Sylvain Henry committed Feb 14, 2020 934  * When desugaring a pattern-binding in GHC.HsToCore.Binds.dsHsBind  Simon Peyton Jones committed Jul 27, 2018 935 936 937 938 939 940 941 942 943 944 945 946  Note that it is /not/ done recursively. See the -XStrict spec in the user manual. Specifically: ~pat => pat -- when -XStrict (even if pat = ~pat') !pat => !pat -- always pat => !pat -- when -XStrict pat => pat -- otherwise -}  Simon Peyton Jones committed Sep 30, 2016 947 -- | Use -XStrict to add a ! or remove a ~  Simon Peyton Jones committed Jul 27, 2018 948 -- See Note [decideBangHood]  Simon Peyton Jones committed Feb 26, 2016 949 decideBangHood :: DynFlags  Alan Zimmerman committed Apr 09, 2018 950 951  -> LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- Pattern with bang if necessary  Simon Peyton Jones committed Feb 26, 2016 952 decideBangHood dflags lpat  Simon Peyton Jones committed Sep 30, 2016 953 954 955  | not (xopt LangExt.Strict dflags) = lpat | otherwise -- -XStrict  Simon Peyton Jones committed Feb 26, 2016 956 957  = go lpat where  Vladislav Zavialov committed Nov 30, 2019 958  go lp@(L l p)  Simon Peyton Jones committed Feb 26, 2016 959  = case p of  Vladislav Zavialov committed Nov 30, 2019 960  ParPat x p -> L l (ParPat x (go p))  Alan Zimmerman committed Apr 09, 2018 961 962  LazyPat _ lp' -> lp' BangPat _ _ -> lp  Vladislav Zavialov committed Nov 30, 2019 963  _ -> L l (BangPat noExtField lp)  Ben Gamari committed Jun 27, 2017 964   Ryan Scott committed Jul 30, 2018 965 966 967 968 969 970 971 972 isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr) -- Returns Just {..} if we're sure that the expression is True -- I.e. * 'True' datacon -- * 'otherwise' Id -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated.  Vladislav Zavialov committed Nov 30, 2019 973 isTrueLHsExpr (L _ (HsVar _ (L _ v)))  Shayan-Najd committed Nov 24, 2018 974 975  | v hasKey otherwiseIdKey || v hasKey getUnique trueDataConId  Ryan Scott committed Jul 30, 2018 976 977  = Just return -- trueDataConId doesn't have the same unique as trueDataCon  Vladislav Zavialov committed Nov 30, 2019 978 isTrueLHsExpr (L _ (HsConLikeOut _ con))  Ryan Scott committed Jul 30, 2018 979  | con hasKey getUnique trueDataCon = Just return  Vladislav Zavialov committed Nov 30, 2019 980 isTrueLHsExpr (L _ (HsTick _ tickish e))  Ryan Scott committed Jul 30, 2018 981 982 983 984 985  | Just ticks <- isTrueLHsExpr e = Just (\x -> do wrapped <- ticks x return (Tick tickish wrapped)) -- This encodes that the result is constant True for Hpc tick purposes; -- which is specifically what isTrueLHsExpr is trying to find out.  Vladislav Zavialov committed Nov 30, 2019 986 isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))  Ryan Scott committed Jul 30, 2018 987 988 989 990 991  | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e))  Vladislav Zavialov committed Nov 30, 2019 992 993 isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e isTrueLHsExpr _ = Nothing