DsUtils.hs 36.1 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 13 {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}  Ian Lynagh committed Nov 04, 2011 14   batterseapower committed Jul 31, 2008 15 -- | Utility functions for constructing Core syntax, principally for desugaring  partain committed Jan 08, 1996 16 module DsUtils (  Simon Peyton Jones committed Sep 26, 2014 17 18  EquationInfo(..), firstPat, shiftEqns,  simonpj committed May 18, 1999 19   Simon Peyton Jones committed Sep 26, 2014 20 21 22 23 24 25 26 27  MatchResult(..), CanItFail(..), CaseAlt(..), cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, wrapBind, wrapBinds,  simonm committed Dec 02, 1998 28   Simon Peyton Jones committed Jul 30, 2015 29  mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,  batterseapower committed Jul 31, 2008 30 31 32 33  seqVar, -- LHs tuples  simonpj@microsoft.com committed Jul 23, 2009 34  mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,  Simon Marlow committed Sep 17, 2015 35  mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,  batterseapower committed Jul 31, 2008 36 37 38  mkSelectorBinds,  Simon Peyton Jones committed Sep 26, 2014 39  selectSimpleMatchVarL, selectMatchVars, selectMatchVar,  Ryan Scott committed Jul 30, 2018 40 41  mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang, isTrueLHsExpr  partain committed Jan 08, 1996 42 43  ) where  simonm committed Jan 08, 1998 44 45 #include "HsVersions.h"  Herbert Valerio Riedel committed Sep 19, 2017 46 47 import GhcPrelude  Simon Peyton Jones committed Jan 05, 2017 48 49 import {-# SOURCE #-} Match ( matchSimply ) import {-# SOURCE #-} DsExpr ( dsLExpr )  partain committed Mar 19, 1996 50   simonmar committed Nov 09, 1999 51 import HsSyn  Simon Marlow committed Oct 11, 2006 52 import TcHsSyn  simonpj@microsoft.com committed Sep 15, 2008 53 import TcType( tcSplitTyConApp )  partain committed Mar 19, 1996 54 55 56 import CoreSyn import DsMonad  Simon Marlow committed Oct 11, 2006 57 import CoreUtils  batterseapower committed Jul 31, 2008 58 import MkCore  Simon Marlow committed Oct 11, 2006 59 60 61 62 63 import MkId import Id import Literal import TyCon import DataCon  Gergő Érdi committed Jan 20, 2014 64 import PatSyn  Simon Marlow committed Oct 11, 2006 65 import Type  eir@cis.upenn.edu committed Dec 11, 2015 66 import Coercion  Simon Marlow committed Oct 11, 2006 67 68 69 import TysPrim import TysWiredIn import BasicTypes  Simon Peyton Jones committed Feb 26, 2016 70 import ConLike  Simon Marlow committed Oct 11, 2006 71 72 import UniqSet import UniqSupply  ian@well-typed.com committed Nov 06, 2012 73 import Module  Simon Marlow committed Oct 11, 2006 74 import PrelNames  Simon Peyton Jones committed Jan 05, 2017 75 import Name( isInternalName )  sof committed May 19, 1997 76 import Outputable  Simon Marlow committed Oct 11, 2006 77 78 import SrcLoc import Util  Ian Lynagh committed Jun 12, 2012 79 import DynFlags  simonmar committed Apr 29, 2002 80 import FastString  Ben Gamari committed Dec 15, 2015 81 import qualified GHC.LanguageExtensions as LangExt  Simon Marlow committed Nov 02, 2011 82   Gergő Érdi committed Jan 20, 2014 83 84 import TcEvidence  Simon Marlow committed Nov 02, 2011 85 import Control.Monad ( zipWithM )  sof committed May 19, 1997 86   Austin Seipp committed Dec 03, 2014 87 88 89 {- ************************************************************************ * *  simonmar committed Jun 17, 1999 90 \subsection{ Selecting match variables}  Austin Seipp committed Dec 03, 2014 91 92 * * ************************************************************************  sof committed May 19, 1997 93 94 95 96 97  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 98 -}  sof committed May 19, 1997 99   Alan Zimmerman committed Jun 06, 2017 100 selectSimpleMatchVarL :: LPat GhcTc -> DsM Id  Simon Peyton Jones committed Jul 27, 2018 101 -- Postcondition: the returned Id has an Internal Name  chak@cse.unsw.edu.au. committed Aug 04, 2006 102 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)  simonpj committed Sep 30, 2004 103 104 105 106  -- (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 107 108 109 -- -- OLD, but interesting note: -- But even if it is a variable, its type might not match. Consider  Simon Peyton Jones committed Sep 26, 2014 110 111 112 -- data T a where -- T1 :: Int -> T Int -- T2 :: a -> T a  simonpj committed Sep 30, 2004 113 --  Simon Peyton Jones committed Sep 26, 2014 114 115 116 -- 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 117 118 119 -- 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 120 selectMatchVars :: [Pat GhcTc] -> DsM [Id]  Simon Peyton Jones committed Jul 27, 2018 121 -- Postcondition: the returned Ids have Internal Names  chak@cse.unsw.edu.au. committed Aug 04, 2006 122 123 selectMatchVars ps = mapM selectMatchVar ps  Alan Zimmerman committed Jun 06, 2017 124 selectMatchVar :: Pat GhcTc -> DsM Id  Simon Peyton Jones committed Jul 27, 2018 125 -- Postcondition: the returned Id has an Internal Name  Alan Zimmerman committed Apr 09, 2018 126 127 128 129 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 130  -- Note [Localise pattern binders]  Alan Zimmerman committed Apr 09, 2018 131 132 selectMatchVar (AsPat _ var _) = return (unLoc var) selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat)  Simon Peyton Jones committed Sep 26, 2014 133  -- OK, better make up one...  sof committed May 19, 1997 134   Simon Peyton Jones committed Jul 27, 2018 135 136 {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Oct 21, 2010 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 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 154 of is tc003 compiled with the 'hpc' way -- but that only makes it  simonpj@microsoft.com committed Oct 21, 2010 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 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} In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr runs on the output of the desugarer, so all is well by the end of the desugaring pass.  Simon Peyton Jones committed Jul 27, 2018 172 See also Note [MatchIds] in Match.hs  sof committed May 19, 1997 173   Austin Seipp committed Dec 03, 2014 174 175 176 177 178 ************************************************************************ * * * type synonym EquationInfo and access functions for its pieces * * * ************************************************************************  partain committed Jan 08, 1996 179 180 181 182 \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 183 -}  partain committed Jan 08, 1996 184   Alan Zimmerman committed Jun 06, 2017 185 firstPat :: EquationInfo -> Pat GhcTc  simonpj@microsoft.com committed May 02, 2007 186 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)  simonm committed Dec 02, 1998 187   simonpj committed Sep 30, 2004 188 shiftEqns :: [EquationInfo] -> [EquationInfo]  simonpj committed Mar 01, 2005 189 190 -- Drop the first pattern in each equation shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]  partain committed Jan 08, 1996 191   Austin Seipp committed Dec 03, 2014 192 -- Functions on MatchResults  simonm committed Dec 02, 1998 193   simonpj committed Apr 04, 2005 194 195 196 197 matchCanFail :: MatchResult -> Bool matchCanFail (MatchResult CanFail _) = True matchCanFail (MatchResult CantFail _) = False  simonpj committed Sep 30, 2004 198 alwaysFailMatchResult :: MatchResult  twanvl committed Jan 17, 2008 199 alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)  simonpj committed Sep 30, 2004 200   simonm committed Dec 02, 1998 201 cantFailMatchResult :: CoreExpr -> MatchResult  twanvl committed Jan 17, 2008 202 cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)  partain committed Jan 08, 1996 203   simonm committed Dec 02, 1998 204 extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr  simonpj@microsoft.com committed Dec 20, 2007 205 extractMatchResult (MatchResult CantFail match_fn) _  simonm committed Dec 02, 1998 206  = match_fn (error "It can't fail!")  partain committed Jan 08, 1996 207   twanvl committed Jan 17, 2008 208 209 210 extractMatchResult (MatchResult CanFail match_fn) fail_expr = do (fail_bind, if_it_fails) <- mkFailurePair fail_expr body <- match_fn if_it_fails  batterseapower committed Jul 31, 2008 211  return (mkCoreLet fail_bind body)  partain committed Jan 08, 1996 212   simonm committed Dec 02, 1998 213 214 215  combineMatchResults :: MatchResult -> MatchResult -> MatchResult combineMatchResults (MatchResult CanFail body_fn1)  twanvl committed Jan 17, 2008 216  (MatchResult can_it_fail2 body_fn2)  simonm committed Dec 02, 1998 217 218  = MatchResult can_it_fail2 body_fn where  twanvl committed Jan 17, 2008 219 220 221 222  body_fn fail = do body2 <- body_fn2 fail (fail_bind, duplicatable_expr) <- mkFailurePair body2 body1 <- body_fn1 duplicatable_expr return (Let fail_bind body1)  simonm committed Dec 02, 1998 223   simonpj@microsoft.com committed Dec 20, 2007 224 combineMatchResults match_result1@(MatchResult CantFail _) _  simonm committed Dec 02, 1998 225 226  = match_result1  chak@cse.unsw.edu.au. committed Aug 04, 2006 227 adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult  simonm committed Dec 02, 1998 228 adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)  twanvl committed Jan 17, 2008 229  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)  simonm committed Dec 02, 1998 230 231 232  adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)  twanvl committed Jan 17, 2008 233  = MatchResult can_it_fail (\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 245 seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = Case (Var var) var (exprType body)  Simon Peyton Jones committed Sep 26, 2014 246  [(DEFAULT, [], body)]  simonpj@microsoft.com committed Feb 03, 2006 247   simonpj committed Sep 30, 2004 248 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult  batterseapower committed Jul 31, 2008 249 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)  chak@cse.unsw.edu.au. committed Aug 04, 2006 250   eir@cis.upenn.edu committed Jan 27, 2016 251 252 253 254 255 -- (mkViewMatchResult var' viewExpr mr) makes the expression -- let var' = viewExpr in mr mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult mkViewMatchResult var' viewExpr = adjustMatchResult (mkCoreLet (NonRec var' viewExpr))  Dan Licata committed Oct 10, 2007 256   chak@cse.unsw.edu.au. committed Aug 04, 2006 257 258 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult mkEvalMatchResult var ty  Simon Peyton Jones committed Sep 26, 2014 259  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])  simonm committed Dec 02, 1998 260 261  mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult  simonpj@microsoft.com committed Dec 20, 2007 262 mkGuardedMatchResult pred_expr (MatchResult _ body_fn)  twanvl committed Jan 17, 2008 263 264  = MatchResult CanFail (\fail -> do body <- body_fn fail return (mkIfThenElse pred_expr body fail))  partain committed Jan 08, 1996 265   Alan Zimmerman committed Jun 06, 2017 266 mkCoPrimCaseMatchResult :: Id -- Scrutinee  eir@cis.upenn.edu committed Dec 11, 2015 267 268 269  -> Type -- Type of the case -> [(Literal, MatchResult)] -- Alternatives -> MatchResult -- Literals are all unlifted  simonpj committed Sep 30, 2004 270 mkCoPrimCaseMatchResult var ty match_alts  simonm committed Dec 02, 1998 271  = MatchResult CanFail mk_case  partain committed Jan 08, 1996 272  where  twanvl committed Jan 17, 2008 273 274 275  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 276   Simon Peyton Jones committed Sep 26, 2014 277  sorted_alts = sortWith fst match_alts -- Right order for a Case  Simon Peyton Jones committed Nov 09, 2011 278 279 280 281  mk_alt fail (lit, MatchResult _ body_fn) = ASSERT( not (litIsLifted lit) ) do body <- body_fn fail return (LitAlt lit, [], body)  partain committed Jan 08, 1996 282   Gergő Érdi committed Jan 20, 2014 283 data CaseAlt a = MkCaseAlt{ alt_pat :: a,  eir@cis.upenn.edu committed Dec 11, 2015 284  alt_bndrs :: [Var],  Gergő Érdi committed Jan 20, 2014 285 286  alt_wrapper :: HsWrapper, alt_result :: MatchResult }  partain committed Jan 08, 1996 287   Simon Peyton Jones committed Sep 26, 2014 288 mkCoAlgCaseMatchResult  Ben Gamari committed Jun 02, 2018 289  :: Id -- Scrutinee  Gergő Érdi committed Jan 20, 2014 290 291  -> Type -- Type of exp -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts)  Simon Peyton Jones committed May 12, 2011 292  -> MatchResult  Ben Gamari committed Jun 02, 2018 293 mkCoAlgCaseMatchResult var ty match_alts  Gergő Érdi committed Jan 20, 2014 294  | isNewtype -- Newtype case; use a let  simonpj committed Sep 30, 2004 295  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )  simonpj committed Mar 01, 2005 296  mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1  simonm committed Dec 02, 1998 297   Gergő Érdi committed Jan 20, 2014 298 299  | otherwise = mkDataConCase var ty match_alts  partain committed Jan 08, 1996 300  where  Gergő Érdi committed Jan 20, 2014 301 302  isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))  Simon Peyton Jones committed Sep 26, 2014 303 304  -- [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 305   Gergő Érdi committed Jan 20, 2014 306 307 308 309 310  alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } = ASSERT( notNull match_alts ) head match_alts -- Stuff for newtype arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 var_ty = idType var  Simon Peyton Jones committed Sep 26, 2014 311 312  (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 313  newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)  chak committed Feb 11, 2002 314   Gergő Érdi committed Jan 20, 2014 315 316 317 318 319 320 321 322 mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult mkCoSynCaseMatchResult var ty alt = MatchResult CanFail$ mkPatSynCase var ty alt sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon] sort_alts = sortWith (dataConTag . alt_pat) mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do  eir@cis.upenn.edu committed Dec 11, 2015 323  matcher <- dsLExpr $mkLHsWrap wrapper$  Simon Peyton Jones committed Aug 29, 2017 324  nlHsTyApp matcher [getRuntimeRep ty, ty]  Gergő Érdi committed Jan 20, 2014 325 326  let MatchResult _ mkCont = match_result cont <- mkCoreLams bndrs <$> mkCont fail  Ben Gamari committed Oct 30, 2015 327  return$ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]  Gergő Érdi committed Jan 20, 2014 328 329 330 331 332  where MkCaseAlt{ alt_pat = psyn, alt_bndrs = bndrs, alt_wrapper = wrapper, alt_result = match_result} = alt  Simon Peyton Jones committed Nov 21, 2014 333  (matcher, needs_void_lam) = patSynMatcher psyn  Gergő Érdi committed Jan 20, 2014 334   Simon Peyton Jones committed Nov 21, 2014 335  -- See Note [Matchers and builders for pattern synonyms] in PatSyns  Gergő Érdi committed Nov 08, 2014 336  -- on these extra Void# arguments  Simon Peyton Jones committed Nov 21, 2014 337 338  ensure_unstrict cont | needs_void_lam = Lam voidArgId cont | otherwise = cont  Gergő Érdi committed Nov 08, 2014 339   Gergő Érdi committed Jan 20, 2014 340 341 342 343 344 345 346 347 348 349 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 375 376 377 378 379 380 381 382 383 384 385 386 387 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives" mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case where con1 = alt_pat alt1 tycon = dataConTyCon con1 data_cons = tyConDataCons tycon match_results = map alt_result alts sorted_alts :: [CaseAlt DataCon] sorted_alts = sort_alts alts var_ty = idType var (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes -- (not that splitTyConApp does, these days) mk_case :: CoreExpr -> DsM CoreExpr mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts return $mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts) mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt mk_alt fail MkCaseAlt{ alt_pat = con, alt_bndrs = args, alt_result = MatchResult _ body_fn } = do { body <- body_fn fail ; 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 :: CoreExpr -> [CoreAlt] mk_default fail | exhaustive_case = [] | otherwise = [(DEFAULT, [], fail)] fail_flag :: CanItFail fail_flag | exhaustive_case = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results] | otherwise = CanFail mentioned_constructors = mkUniqSet$ map alt_pat alts un_mentioned_constructors = mkUniqSet data_cons minusUniqSet mentioned_constructors exhaustive_case = isEmptyUniqSet un_mentioned_constructors  Austin Seipp committed Dec 03, 2014 388 389 390 {- ************************************************************************ * *  partain committed Mar 19, 1996 391 \subsection{Desugarer's versions of some Core functions}  Austin Seipp committed Dec 03, 2014 392 393 394 * * ************************************************************************ -}  partain committed Jan 08, 1996 395   Simon Peyton Jones committed Sep 26, 2014 396 397 398 399 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 400   twanvl committed Jan 17, 2008 401 402 mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs  Ian Lynagh committed Jun 12, 2012 403  dflags <- getDynFlags  partain committed Apr 08, 1996 404  let  msosn committed Nov 18, 2015 405  full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])  Sylvain Henry committed Nov 22, 2018 406 407  core_msg = Lit (mkLitString full_msg) -- mkLitString returns a result of type String#  Simon Peyton Jones committed Aug 29, 2017 408  return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])  simonpj committed Sep 22, 2000 409   Austin Seipp committed Dec 03, 2014 410 {-  simonpj@microsoft.com committed Jun 03, 2009 411 412 413 414 415 416 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'. Note [Desugaring seq (1)] cf Trac #1031 ~~~~~~~~~~~~~~~~~~~~~~~~~ f x y = x seq (y seq (# x,y #))  Simon Peyton Jones committed Sep 26, 2014 417 The [CoreSyn let/app invariant] means that, other things being equal, because  simonpj@microsoft.com committed Jun 03, 2009 418 419 420 421 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  Simon Peyton Jones committed Sep 26, 2014 422 423 But that is bad for two reasons: (a) we now evaluate y before x, and  simonpj@microsoft.com committed Jun 03, 2009 424 425 426 427 428  (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 #)  simonpj@microsoft.com committed Oct 02, 2009 429 Note [Desugaring seq (2)] cf Trac #2273  simonpj@microsoft.com committed Jun 03, 2009 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 ~~~~~~~~~~~~~~~~~~~~~~~~~ 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  simonpj@microsoft.com committed Oct 02, 2009 457 458 459 460 461 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:  simonpj@microsoft.com committed Jun 03, 2009 462 463  let chp = case b of { True -> fst x; False -> 0 } case chp of chp { I# -> ...chp... }  simonpj@microsoft.com committed Oct 02, 2009 464 And now all is well.  simonpj@microsoft.com committed Jun 03, 2009 465 466  The reason it's a hack is because if you define mySeq=seq, the hack  Simon Peyton Jones committed Sep 26, 2014 467 won't work on mySeq.  simonpj@microsoft.com committed Jun 03, 2009 468 469 470  Note [Desugaring seq (3)] cf Trac #2409 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  Simon Peyton Jones committed Sep 26, 2014 471 The isLocalId ensures that we don't turn  simonpj@microsoft.com committed Jun 03, 2009 472 473 474  True seq e into case True of True { ... }  Simon Peyton Jones committed Sep 26, 2014 475 which stupidly tries to bind the datacon 'True'.  Austin Seipp committed Dec 03, 2014 476 -}  simonpj@microsoft.com committed Jun 03, 2009 477   Richard Eisenberg committed Mar 17, 2017 478 -- NB: Make sure the argument is not levity polymorphic  Ben Gamari committed Oct 30, 2015 479 480 mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f App Type ty1 App Type ty2 App arg1) arg2  simonpj@microsoft.com committed Jun 03, 2009 481 482 483 484  | f hasKey seqIdKey -- Note [Desugaring seq (1), (2)] = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] where case_bndr = case arg1 of  Simon Peyton Jones committed Jan 05, 2017 485 486 487  Var v1 | isInternalName (idName v1) -> v1 -- Note [Desugaring seq (2) and (3)] _ -> mkWildValBinder ty1  simonpj@microsoft.com committed Jun 03, 2009 488   Ben Gamari committed Oct 30, 2015 489 mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore  simonpj@microsoft.com committed Jun 03, 2009 490   Richard Eisenberg committed Mar 17, 2017 491 -- NB: No argument can be levity polymorphic  Ben Gamari committed Oct 30, 2015 492 mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr  Andreas Klebinger committed Aug 21, 2018 493 mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args  simonpj@microsoft.com committed Jun 03, 2009 494   Simon Peyton Jones committed Jul 30, 2015 495 mkCastDs :: CoreExpr -> Coercion -> CoreExpr  Gabor Greif committed Feb 11, 2016 496 -- We define a desugarer-specific version of CoreUtils.mkCast,  Simon Peyton Jones committed Jul 30, 2015 497 498 499 500 501 502 503 504 505 506 -- 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 -- CoreUtils.mkCast; and we do less peephole optimisation too mkCastDs e co | isReflCo co = e | otherwise = Cast e co  Austin Seipp committed Dec 03, 2014 507 508 509 {- ************************************************************************ * *  Simon Peyton Jones committed Jul 30, 2015 510  Tuples and selector bindings  Austin Seipp committed Dec 03, 2014 511 512 * * ************************************************************************  partain committed Jan 08, 1996 513 514 515  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 516 \begin{verbatim}  partain committed Jan 08, 1996 517  b = case v of pat' -> b'  simonmar committed Jun 17, 1999 518 519 \end{verbatim} where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.  partain committed Jan 08, 1996 520 521 522 523 524 525 526 527 528 529  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 530 531 Note [mkSelectorBinds] ~~~~~~~~~~~~~~~~~~~~~~  Simon Peyton Jones committed Feb 26, 2016 532 533 534 535 536 537 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 538 539 540 541 542 543 ------ 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 544   Simon Peyton Jones committed Sep 30, 2016 545 ------ Special case (B) -------  Simon Peyton Jones committed Feb 26, 2016 546 547 548 549 550 551 552 553 554 555 556  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 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 ------ 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 The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn 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 589 590 591 592 593 594 595 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 657 658 659  * !(_, (_, 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 (see Note [One-tuples] in TysWiredIn) * !(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 660 -}  Simon Peyton Jones committed Sep 05, 2011 661   Simon Peyton Jones committed Feb 26, 2016 662 mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly  Alan Zimmerman committed Jun 06, 2017 663  -> LPat GhcTc -- ^ The pattern  ase committed Nov 14, 2015 664  -> CoreExpr -- ^ Expression to which the pattern is bound  Simon Peyton Jones committed Feb 26, 2016 665  -> DsM (Id,[(Id,CoreExpr)])  ase committed Nov 14, 2015 666 667 668 669  -- ^ Id the rhs is bound to, for desugaring strict -- binds (see Note [Desugar Strict binds] in DsBinds) -- and all the desugared binds  Simon Peyton Jones committed Feb 26, 2016 670 mkSelectorBinds ticks pat val_expr  Alan Zimmerman committed Apr 09, 2018 671  | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)  Simon Peyton Jones committed Sep 30, 2016 672 673 674 675  = return (v, [(v, val_expr)]) | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat'  Richard Eisenberg committed Jan 19, 2017 676  ; val_var <- newSysLocalDsNoLP pat_ty  Simon Peyton Jones committed Feb 26, 2016 677   Simon Peyton Jones committed Sep 30, 2016 678  ; let mk_bind tick bndr_var  Simon Peyton Jones committed Feb 26, 2016 679 680  -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } -- Remember, 'pat' binds 'bv'  Simon Peyton Jones committed Sep 30, 2016 681  = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'  Simon Peyton Jones committed Feb 26, 2016 682 683 684 685 686 687 688 689  (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 690  ; binds <- zipWithM mk_bind ticks' binders  Simon Peyton Jones committed Feb 26, 2016 691 692  ; return ( val_var, (val_var, val_expr) : binds) }  Simon Peyton Jones committed Sep 30, 2016 693  | otherwise -- General case (C)  Simon Peyton Jones committed Feb 26, 2016 694  = do { tuple_var <- newSysLocalDs tuple_ty  David Feuer committed Jan 15, 2018 695  ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')  Simon Peyton Jones committed Feb 26, 2016 696  ; tuple_expr <- matchSimply val_expr PatBindRhs pat  Simon Peyton Jones committed Feb 18, 2016 697  local_tuple error_expr  Simon Marlow committed Nov 02, 2011 698  ; let mk_tup_bind tick binder  Simon Peyton Jones committed Feb 18, 2016 699  = (binder, mkOptTickBox tick $ Simon Peyton Jones committed Feb 26, 2016 700 701 702 703  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 704  where  Simon Peyton Jones committed Sep 30, 2016 705 706 707 708 709  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 710  ticks' = ticks ++ repeat []  Simon Marlow committed Nov 02, 2011 711 712  local_binders = map localiseId binders -- See Note [Localise pattern binders]  Simon Peyton Jones committed Feb 26, 2016 713  local_tuple = mkBigCoreVarTup1 binders  simonpj@microsoft.com committed Oct 21, 2010 714  tuple_ty = exprType local_tuple  simonpj committed Feb 24, 1998 715   Simon Peyton Jones committed Sep 30, 2016 716 717 strip_bangs :: LPat a -> LPat a -- Remove outermost bangs and parens  Alan Zimmerman committed Apr 09, 2018 718 719 720 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 721   Simon Peyton Jones committed Sep 30, 2016 722 723 is_flat_prod_lpat :: LPat a -> Bool is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)  simonmar committed Dec 10, 2003 724   Simon Peyton Jones committed Sep 30, 2016 725 is_flat_prod_pat :: Pat a -> Bool  Alan Zimmerman committed Apr 09, 2018 726 727 728 is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPatOut { pat_con = L _ pcon, pat_args = ps})  Simon Peyton Jones committed Sep 30, 2016 729 730 731 732  | RealDataCon con <- pcon , isProductTyCon (dataConTyCon con) = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False  simonpj committed Feb 24, 1998 733   Simon Peyton Jones committed Feb 26, 2016 734 735 is_triv_lpat :: LPat a -> Bool is_triv_lpat p = is_triv_pat (unLoc p)  simonmar committed Dec 10, 2003 736   Simon Peyton Jones committed Feb 26, 2016 737 is_triv_pat :: Pat a -> Bool  Alan Zimmerman committed Apr 09, 2018 738 739 740 741 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 742   Simon Peyton Jones committed Feb 26, 2016 743 744 745 746 747 748 749 750  {- ********************************************************************* * * Creating big tuples and their types for full Haskell expressions. They work over *Ids*, and create tuples replete with their types, which is whey they are not in HsUtils. * * ********************************************************************* -}  simonpj@microsoft.com committed Dec 20, 2007 751   Alan Zimmerman committed Jun 06, 2017 752 mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc  simonpj@microsoft.com committed Jun 05, 2008 753 mkLHsPatTup [] = noLoc$ mkVanillaTuplePat [] Boxed  simonpj@microsoft.com committed Dec 20, 2007 754 mkLHsPatTup [lpat] = lpat  Simon Peyton Jones committed Sep 26, 2014 755 756 mkLHsPatTup lpats = L (getLoc (head lpats)) $mkVanillaTuplePat lpats Boxed  simonpj@microsoft.com committed Dec 20, 2007 757   Alan Zimmerman committed Jun 06, 2017 758 mkLHsVarPatTup :: [Id] -> LPat GhcTc  simonpj@microsoft.com committed Jul 23, 2009 759 760 mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)  Alan Zimmerman committed Jun 06, 2017 761 mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc  simonpj@microsoft.com committed Jul 23, 2009 762 -- A vanilla tuple pattern simply gets its type from its sub-patterns  Alan Zimmerman committed Apr 09, 2018 763 mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box  simonpj@microsoft.com committed Jul 23, 2009 764   simonpj@microsoft.com committed Dec 20, 2007 765 -- The Big equivalents for the source tuple expressions  Alan Zimmerman committed Jun 06, 2017 766 mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc  Simon Marlow committed Sep 17, 2015 767 mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)  simonpj@microsoft.com committed Dec 20, 2007 768   Alan Zimmerman committed Jun 06, 2017 769 mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc  Simon Marlow committed Sep 17, 2015 770 mkBigLHsTupId = mkChunkified mkLHsTupleExpr  simonpj@microsoft.com committed Dec 20, 2007 771 772  -- The Big equivalents for the source tuple patterns  Alan Zimmerman committed Jun 06, 2017 773 mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc  Simon Marlow committed Sep 17, 2015 774 mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)  simonpj@microsoft.com committed Dec 20, 2007 775   Alan Zimmerman committed Jun 06, 2017 776 mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc  Simon Marlow committed Sep 17, 2015 777 mkBigLHsPatTupId = mkChunkified mkLHsPatTup  simonpj committed May 18, 1999 778   Austin Seipp committed Dec 03, 2014 779 780 781 {- ************************************************************************ * *  Simon Peyton Jones committed Jul 30, 2015 782  Code for pattern-matching and other failures  Austin Seipp committed Dec 03, 2014 783 784 * * ************************************************************************  partain committed Jan 08, 1996 785 786 787 788  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 789 790 791 792 793 794 795  let fail.33 = error "Help" in case x of p1 -> ... p2 -> fail.33 p3 -> fail.33 p4 -> ...  partain committed Jan 08, 1996 796 797 798 799 \end{verbatim} Then \begin{itemize} \item  simonmar committed Jun 17, 1999 800 If the case can't fail, then there'll be no mention of @fail.33@, and the  partain committed Jan 08, 1996 801 802 803 804 805 806 807 808 809 810 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 811 unboxed type. Then the type of @fail.33@ is unboxed too, and  partain committed Jan 08, 1996 812 813 there is every chance that someone will change the let into a case: \begin{verbatim}  Simon Peyton Jones committed Sep 26, 2014 814 815  case error "Help" of fail.33 -> case ....  partain committed Jan 08, 1996 816 817 818 \end{verbatim} which is of course utterly wrong. Rather than drop the condition that  partain committed Mar 19, 1996 819 only boxed types can be let-bound, we just turn the fail into a function  partain committed Jan 08, 1996 820 821 for the primitive case: \begin{verbatim}  Simon Peyton Jones committed Sep 26, 2014 822 823 824 825 826 827 828 829  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 830 831 \end{verbatim}  simonmar committed Jun 17, 1999 832 Now @fail.33@ is a function, so it can be let-bound.  lukemaurer committed Feb 01, 2017 833 834 835 836 837 838 839 840 841  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 842 -}  partain committed Jan 08, 1996 843   Simon Peyton Jones committed Sep 26, 2014 844 845 846 847 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 848 -- See Note [Failure thunks and CPR]  simonm committed Dec 02, 1998 849 mkFailurePair expr  Simon Peyton Jones committed Nov 22, 2013 850 851 852 853 854  = do { fail_fun_var <- newFailLocalDs (voidPrimTy mkFunTy ty) ; 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 855  where  simonpj committed Mar 23, 2000 856  ty = exprType expr  partain committed Jun 05, 1996 857   Austin Seipp committed Dec 03, 2014 858 {-  simonpj@microsoft.com committed Sep 08, 2009 859 860 Note [Failure thunks and CPR] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  lukemaurer committed Feb 01, 2017 861 862 863 864 865 (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 join points] in WorkWrap.)  simonpj@microsoft.com committed Sep 08, 2009 866 867 868 869 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 870  in case x of  simonpj@microsoft.com committed Sep 08, 2009 871 872  [] -> fail realWorld# (y:ys) -> case ys of  Simon Peyton Jones committed Sep 26, 2014 873  [] -> fail realWorld#  simonpj@microsoft.com committed Sep 08, 2009 874 875 876 877 878 879 880  (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 the tail call property. For example, see Trac #3403.  Simon Peyton Jones committed Jul 30, 2015 881 882 883 884 885 886 887  ************************************************************************ * * Ticks * * ********************************************************************* -}  simonpj@microsoft.com committed Sep 08, 2009 888   Peter Wortmann committed Dec 16, 2014 889 890 mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr mkOptTickBox = flip (foldr Tick)  andy@galois.com committed Oct 24, 2006 891 892 893  mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do  Simon Peyton Jones committed Sep 26, 2014 894  uq <- newUnique  ian@well-typed.com committed Nov 06, 2012 895  this_mod <- getModule  Simon Marlow committed Nov 02, 2011 896 897 898 899 900  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 901 902 903 904  return$ Case e bndr1 boolTy [ (DataAlt falseDataCon, [], falseBox) , (DataAlt trueDataCon, [], trueBox) ]  ase committed Nov 14, 2015 905 906 907 908 909  -- *******************************************************************  Simon Peyton Jones committed Jul 27, 2018 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 {- 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, * Just before constructing an EqnInfo, in Match (matchWrapper and matchSinglePat) * When desugaring a pattern-binding in DsBinds.dsHsBind 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 940 -- | Use -XStrict to add a ! or remove a ~  Simon Peyton Jones committed Jul 27, 2018 941 -- See Note [decideBangHood]  Simon Peyton Jones committed Feb 26, 2016 942 decideBangHood :: DynFlags  Alan Zimmerman committed Apr 09, 2018 943 944  -> LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- Pattern with bang if necessary  Simon Peyton Jones committed Feb 26, 2016 945 decideBangHood dflags lpat  Simon Peyton Jones committed Sep 30, 2016 946 947 948  | not (xopt LangExt.Strict dflags) = lpat | otherwise -- -XStrict  Simon Peyton Jones committed Feb 26, 2016 949 950 951 952  = go lpat where go lp@(L l p) = case p of  Alan Zimmerman committed Apr 09, 2018 953 954 955 956  ParPat x p -> L l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp _ -> L l (BangPat noExt lp)  Ben Gamari committed Jun 27, 2017 957 958  -- | Unconditionally make a 'Pat' strict.  Alan Zimmerman committed Apr 09, 2018 959 960 addBang :: LPat GhcTc -- ^ Original pattern -> LPat GhcTc -- ^ Banged pattern  Ben Gamari committed Jun 27, 2017 961 962 963 964 addBang = go where go lp@(L l p) = case p of  Alan Zimmerman committed Apr 09, 2018 965 966 967 968 969  ParPat x p -> L l (ParPat x (go p)) LazyPat _ lp' -> L l (BangPat noExt lp') -- Should we bring the extension value over? BangPat _ _ -> lp _ -> L l (BangPat noExt lp)  Ryan Scott committed Jul 30, 2018 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998  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. isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v hasKey otherwiseIdKey || v hasKey getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon isTrueLHsExpr (L _ (HsConLikeOut _ con)) | con hasKey getUnique trueDataCon = Just return isTrueLHsExpr (L _ (HsTick _ tickish e)) | 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. isTrueLHsExpr (L _ (HsBinTick _ ixT _ e)) | Just ticks <- isTrueLHsExpr e = Just (\x -> do e <- ticks x this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e isTrueLHsExpr _ = Nothing