1{-# LANGUAGE CPP #-} 2 3-- | Handy functions for creating much Core syntax 4module MkCore ( 5 -- * Constructing normal syntax 6 mkCoreLet, mkCoreLets, 7 mkCoreApp, mkCoreApps, mkCoreConApps, 8 mkCoreLams, mkWildCase, mkIfThenElse, 9 mkWildValBinder, mkWildEvBinder, 10 mkSingleAltCase, 11 sortQuantVars, castBottomExpr, 12 13 -- * Constructing boxed literals 14 mkWordExpr, mkWordExprWord, 15 mkIntExpr, mkIntExprInt, 16 mkIntegerExpr, mkNaturalExpr, 17 mkFloatExpr, mkDoubleExpr, 18 mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, 19 20 -- * Floats 21 FloatBind(..), wrapFloat, wrapFloats, floatBindings, 22 23 -- * Constructing small tuples 24 mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, 25 mkCoreTupBoxity, unitExpr, 26 27 -- * Constructing big tuples 28 mkBigCoreVarTup, mkBigCoreVarTup1, 29 mkBigCoreVarTupTy, mkBigCoreTupTy, 30 mkBigCoreTup, 31 32 -- * Deconstructing small tuples 33 mkSmallTupleSelector, mkSmallTupleCase, 34 35 -- * Deconstructing big tuples 36 mkTupleSelector, mkTupleSelector1, mkTupleCase, 37 38 -- * Constructing list expressions 39 mkNilExpr, mkConsExpr, mkListExpr, 40 mkFoldrExpr, mkBuildExpr, 41 42 -- * Constructing Maybe expressions 43 mkNothingExpr, mkJustExpr, 44 45 -- * Error Ids 46 mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, 47 rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, 48 nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, 49 pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, 50 tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID 51 ) where 52 53#include "GhclibHsVersions.h" 54 55import GhcPrelude 56 57import Id 58import Var ( EvVar, setTyVarUnique ) 59 60import CoreSyn 61import CoreUtils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) 62import Literal 63import HscTypes 64 65import TysWiredIn 66import PrelNames 67 68import GHC.Hs.Utils ( mkChunkified, chunkify ) 69import Type 70import Coercion ( isCoVar ) 71import TysPrim 72import DataCon ( DataCon, dataConWorkId ) 73import IdInfo 74import Demand 75import Name hiding ( varName ) 76import Outputable 77import FastString 78import UniqSupply 79import BasicTypes 80import Util 81import DynFlags 82import Data.List 83 84import Data.Char ( ord ) 85import Control.Monad.Fail as MonadFail ( MonadFail ) 86 87infixl 4 `mkCoreApp`, `mkCoreApps` 88 89{- 90************************************************************************ 91* * 92\subsection{Basic CoreSyn construction} 93* * 94************************************************************************ 95-} 96sortQuantVars :: [Var] -> [Var] 97-- Sort the variables, putting type and covars first, in scoped order, 98-- and then other Ids 99-- It is a deterministic sort, meaining it doesn't look at the values of 100-- Uniques. For explanation why it's important See Note [Unique Determinism] 101-- in Unique. 102sortQuantVars vs = sorted_tcvs ++ ids 103 where 104 (tcvs, ids) = partition (isTyVar <||> isCoVar) vs 105 sorted_tcvs = scopedSort tcvs 106 107-- | Bind a binding group over an expression, using a @let@ or @case@ as 108-- appropriate (see "CoreSyn#let_app_invariant") 109mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr 110mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] 111 = bindNonRec bndr rhs body 112mkCoreLet bind body 113 = Let bind body 114 115-- | Create a lambda where the given expression has a number of variables 116-- bound over it. The leftmost binder is that bound by the outermost 117-- lambda in the result 118mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr 119mkCoreLams = mkLams 120 121-- | Bind a list of binding groups over an expression. The leftmost binding 122-- group becomes the outermost group in the resulting expression 123mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr 124mkCoreLets binds body = foldr mkCoreLet body binds 125 126-- | Construct an expression which represents the application of a number of 127-- expressions to that of a data constructor expression. The leftmost expression 128-- in the list is applied first 129mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr 130mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args 131 132-- | Construct an expression which represents the application of a number of 133-- expressions to another. The leftmost expression in the list is applied first 134-- Respects the let/app invariant by building a case expression where necessary 135-- See CoreSyn Note [CoreSyn let/app invariant] 136mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr 137mkCoreApps fun args 138 = fst $ 139 foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args 140 where 141 doc_string = ppr fun_ty $$ ppr fun $$ ppr args 142 fun_ty = exprType fun 143 144-- | Construct an expression which represents the application of one expression 145-- to the other 146-- Respects the let/app invariant by building a case expression where necessary 147-- See CoreSyn Note [CoreSyn let/app invariant] 148mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr 149mkCoreApp s fun arg 150 = fst $ mkCoreAppTyped s (fun, exprType fun) arg 151 152-- | Construct an expression which represents the application of one expression 153-- paired with its type to an argument. The result is paired with its type. This 154-- function is not exported and used in the definition of 'mkCoreApp' and 155-- 'mkCoreApps'. 156-- Respects the let/app invariant by building a case expression where necessary 157-- See CoreSyn Note [CoreSyn let/app invariant] 158mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) 159mkCoreAppTyped _ (fun, fun_ty) (Type ty) 160 = (App fun (Type ty), piResultTy fun_ty ty) 161mkCoreAppTyped _ (fun, fun_ty) (Coercion co) 162 = (App fun (Coercion co), funResultTy fun_ty) 163mkCoreAppTyped d (fun, fun_ty) arg 164 = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) 165 (mkValApp fun arg arg_ty res_ty, res_ty) 166 where 167 (arg_ty, res_ty) = splitFunTy fun_ty 168 169mkValApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr 170-- Build an application (e1 e2), 171-- or a strict binding (case e2 of x -> e1 x) 172-- using the latter when necessary to respect the let/app invariant 173-- See Note [CoreSyn let/app invariant] 174mkValApp fun arg arg_ty res_ty 175 | not (needsCaseBinding arg_ty arg) 176 = App fun arg -- The vastly common case 177 | otherwise 178 = mkStrictApp fun arg arg_ty res_ty 179 180{- ********************************************************************* 181* * 182 Building case expressions 183* * 184********************************************************************* -} 185 186mkWildEvBinder :: PredType -> EvVar 187mkWildEvBinder pred = mkWildValBinder pred 188 189-- | Make a /wildcard binder/. This is typically used when you need a binder 190-- that you expect to use only at a *binding* site. Do not use it at 191-- occurrence sites because it has a single, fixed unique, and it's very 192-- easy to get into difficulties with shadowing. That's why it is used so little. 193-- See Note [WildCard binders] in SimplEnv 194mkWildValBinder :: Type -> Id 195mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty 196 197mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr 198-- Make a case expression whose case binder is unused 199-- The alts and res_ty should not have any occurrences of WildId 200mkWildCase scrut scrut_ty res_ty alts 201 = Case scrut (mkWildValBinder scrut_ty) res_ty alts 202 203mkStrictApp :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr 204-- Build a strict application (case e2 of x -> e1 x) 205mkStrictApp fun arg arg_ty res_ty 206 = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] 207 -- mkDefaultCase looks attractive here, and would be sound. 208 -- But it uses (exprType alt_rhs) to compute the result type, 209 -- whereas here we already know that the result type is res_ty 210 where 211 arg_id = mkWildValBinder arg_ty 212 -- Lots of shadowing, but it doesn't matter, 213 -- because 'fun' and 'res_ty' should not have a free wild-id 214 -- 215 -- This is Dangerous. But this is the only place we play this 216 -- game, mkStrictApp returns an expression that does not have 217 -- a free wild-id. So the only way 'fun' could get a free wild-id 218 -- would be if you take apart this case expression (or some other 219 -- expression that uses mkWildValBinder, of which there are not 220 -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. 221 222mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr 223mkIfThenElse guard then_expr else_expr 224-- Not going to be refining, so okay to take the type of the "then" clause 225 = mkWildCase guard boolTy (exprType then_expr) 226 [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! 227 (DataAlt trueDataCon, [], then_expr) ] 228 229castBottomExpr :: CoreExpr -> Type -> CoreExpr 230-- (castBottomExpr e ty), assuming that 'e' diverges, 231-- return an expression of type 'ty' 232-- See Note [Empty case alternatives] in CoreSyn 233castBottomExpr e res_ty 234 | e_ty `eqType` res_ty = e 235 | otherwise = Case e (mkWildValBinder e_ty) res_ty [] 236 where 237 e_ty = exprType e 238 239{- 240************************************************************************ 241* * 242\subsection{Making literals} 243* * 244************************************************************************ 245-} 246 247-- | Create a 'CoreExpr' which will evaluate to the given @Int@ 248mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int 249mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] 250 251-- | Create a 'CoreExpr' which will evaluate to the given @Int@ 252mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int 253mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] 254 255-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value 256mkWordExpr :: DynFlags -> Integer -> CoreExpr 257mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] 258 259-- | Create a 'CoreExpr' which will evaluate to the given @Word@ 260mkWordExprWord :: DynFlags -> Word -> CoreExpr 261mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] 262 263-- | Create a 'CoreExpr' which will evaluate to the given @Integer@ 264mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer 265mkIntegerExpr i = do t <- lookupTyCon integerTyConName 266 return (Lit (mkLitInteger i (mkTyConTy t))) 267 268-- | Create a 'CoreExpr' which will evaluate to the given @Natural@ 269mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr 270mkNaturalExpr i = do t <- lookupTyCon naturalTyConName 271 return (Lit (mkLitNatural i (mkTyConTy t))) 272 273-- | Create a 'CoreExpr' which will evaluate to the given @Float@ 274mkFloatExpr :: Float -> CoreExpr 275mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] 276 277-- | Create a 'CoreExpr' which will evaluate to the given @Double@ 278mkDoubleExpr :: Double -> CoreExpr 279mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] 280 281 282-- | Create a 'CoreExpr' which will evaluate to the given @Char@ 283mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int 284mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] 285 286-- | Create a 'CoreExpr' which will evaluate to the given @String@ 287mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String 288 289-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ 290mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String 291 292mkStringExpr str = mkStringExprFS (mkFastString str) 293 294mkStringExprFS = mkStringExprFSWith lookupId 295 296mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr 297mkStringExprFSWith lookupM str 298 | nullFS str 299 = return (mkNilExpr charTy) 300 301 | all safeChar chars 302 = do unpack_id <- lookupM unpackCStringName 303 return (App (Var unpack_id) lit) 304 305 | otherwise 306 = do unpack_utf8_id <- lookupM unpackCStringUtf8Name 307 return (App (Var unpack_utf8_id) lit) 308 309 where 310 chars = unpackFS str 311 safeChar c = ord c >= 1 && ord c <= 0x7F 312 lit = Lit (LitString (bytesFS str)) 313 314{- 315************************************************************************ 316* * 317\subsection{Tuple constructors} 318* * 319************************************************************************ 320-} 321 322{- 323Creating tuples and their types for Core expressions 324 325@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. 326 327* If it has only one element, it is the identity function. 328 329* If there are more elements than a big tuple can have, it nests 330 the tuples. 331 332Note [Flattening one-tuples] 333~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 334This family of functions creates a tuple of variables/expressions/types. 335 mkCoreTup [e1,e2,e3] = (e1,e2,e3) 336What if there is just one variable/expression/type in the argument? 337We could do one of two things: 338 339* Flatten it out, so that 340 mkCoreTup [e1] = e1 341 342* Build a one-tuple (see Note [One-tuples] in TysWiredIn) 343 mkCoreTup1 [e1] = Unit e1 344 We use a suffix "1" to indicate this. 345 346Usually we want the former, but occasionally the latter. 347 348NB: The logic in tupleDataCon knows about () and Unit and (,), etc. 349 350Note [Don't flatten tuples from HsSyn] 351~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 352If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell), 353we should treat it really as a 1-tuple, without flattening. Note that a 3541-tuple and a flattened value have different performance and laziness 355characteristics, so should just do what we're asked. 356 357This arose from discussions in #16881. 358 359One-tuples that arise internally depend on the circumstance; often flattening 360is a good idea. Decisions are made on a case-by-case basis. 361 362-} 363 364-- | Build the type of a small tuple that holds the specified variables 365-- One-tuples are flattened; see Note [Flattening one-tuples] 366mkCoreVarTupTy :: [Id] -> Type 367mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) 368 369-- | Build a small tuple holding the specified expressions 370-- One-tuples are flattened; see Note [Flattening one-tuples] 371mkCoreTup :: [CoreExpr] -> CoreExpr 372mkCoreTup [c] = c 373mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform 374 375-- | Build a small tuple holding the specified expressions 376-- One-tuples are *not* flattened; see Note [Flattening one-tuples] 377-- See also Note [Don't flatten tuples from HsSyn] 378mkCoreTup1 :: [CoreExpr] -> CoreExpr 379mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs)) 380 (map (Type . exprType) cs ++ cs) 381 382-- | Build a small unboxed tuple holding the specified expressions, 383-- with the given types. The types must be the types of the expressions. 384-- Do not include the RuntimeRep specifiers; this function calculates them 385-- for you. 386-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] 387mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr 388mkCoreUbxTup tys exps 389 = ASSERT( tys `equalLength` exps) 390 mkCoreConApps (tupleDataCon Unboxed (length tys)) 391 (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) 392 393-- | Make a core tuple of the given boxity; don't flatten 1-tuples 394mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr 395mkCoreTupBoxity Boxed exps = mkCoreTup1 exps 396mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps 397 398-- | Build a big tuple holding the specified variables 399-- One-tuples are flattened; see Note [Flattening one-tuples] 400mkBigCoreVarTup :: [Id] -> CoreExpr 401mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) 402 403mkBigCoreVarTup1 :: [Id] -> CoreExpr 404-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened 405-- see Note [Flattening one-tuples] 406mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) 407 [Type (idType id), Var id] 408mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) 409 410-- | Build the type of a big tuple that holds the specified variables 411-- One-tuples are flattened; see Note [Flattening one-tuples] 412mkBigCoreVarTupTy :: [Id] -> Type 413mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) 414 415-- | Build a big tuple holding the specified expressions 416-- One-tuples are flattened; see Note [Flattening one-tuples] 417mkBigCoreTup :: [CoreExpr] -> CoreExpr 418mkBigCoreTup = mkChunkified mkCoreTup 419 420-- | Build the type of a big tuple that holds the specified type of thing 421-- One-tuples are flattened; see Note [Flattening one-tuples] 422mkBigCoreTupTy :: [Type] -> Type 423mkBigCoreTupTy = mkChunkified mkBoxedTupleTy 424 425-- | The unit expression 426unitExpr :: CoreExpr 427unitExpr = Var unitDataConId 428 429{- 430************************************************************************ 431* * 432\subsection{Tuple destructors} 433* * 434************************************************************************ 435-} 436 437-- | Builds a selector which scrutises the given 438-- expression and extracts the one name from the list given. 439-- If you want the no-shadowing rule to apply, the caller 440-- is responsible for making sure that none of these names 441-- are in scope. 442-- 443-- If there is just one 'Id' in the tuple, then the selector is 444-- just the identity. 445-- 446-- If necessary, we pattern match on a \"big\" tuple. 447mkTupleSelector, mkTupleSelector1 448 :: [Id] -- ^ The 'Id's to pattern match the tuple against 449 -> Id -- ^ The 'Id' to select 450 -> Id -- ^ A variable of the same type as the scrutinee 451 -> CoreExpr -- ^ Scrutinee 452 -> CoreExpr -- ^ Selector expression 453 454-- mkTupleSelector [a,b,c,d] b v e 455-- = case e of v { 456-- (p,q) -> case p of p { 457-- (a,b) -> b }} 458-- We use 'tpl' vars for the p,q, since shadowing does not matter. 459-- 460-- In fact, it's more convenient to generate it innermost first, getting 461-- 462-- case (case e of v 463-- (p,q) -> p) of p 464-- (a,b) -> b 465mkTupleSelector vars the_var scrut_var scrut 466 = mk_tup_sel (chunkify vars) the_var 467 where 468 mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut 469 mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ 470 mk_tup_sel (chunkify tpl_vs) tpl_v 471 where 472 tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] 473 tpl_vs = mkTemplateLocals tpl_tys 474 [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, 475 the_var `elem` gp ] 476-- ^ 'mkTupleSelector1' is like 'mkTupleSelector' 477-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) 478mkTupleSelector1 vars the_var scrut_var scrut 479 | [_] <- vars 480 = mkSmallTupleSelector1 vars the_var scrut_var scrut 481 | otherwise 482 = mkTupleSelector vars the_var scrut_var scrut 483 484-- | Like 'mkTupleSelector' but for tuples that are guaranteed 485-- never to be \"big\". 486-- 487-- > mkSmallTupleSelector [x] x v e = [| e |] 488-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] 489mkSmallTupleSelector, mkSmallTupleSelector1 490 :: [Id] -- The tuple args 491 -> Id -- The selected one 492 -> Id -- A variable of the same type as the scrutinee 493 -> CoreExpr -- Scrutinee 494 -> CoreExpr 495mkSmallTupleSelector [var] should_be_the_same_var _ scrut 496 = ASSERT(var == should_be_the_same_var) 497 scrut -- Special case for 1-tuples 498mkSmallTupleSelector vars the_var scrut_var scrut 499 = mkSmallTupleSelector1 vars the_var scrut_var scrut 500 501-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' 502-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) 503mkSmallTupleSelector1 vars the_var scrut_var scrut 504 = ASSERT( notNull vars ) 505 Case scrut scrut_var (idType the_var) 506 [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] 507 508-- | A generalization of 'mkTupleSelector', allowing the body 509-- of the case to be an arbitrary expression. 510-- 511-- To avoid shadowing, we use uniques to invent new variables. 512-- 513-- If necessary we pattern match on a \"big\" tuple. 514mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables 515 -> [Id] -- ^ The tuple identifiers to pattern match on 516 -> CoreExpr -- ^ Body of the case 517 -> Id -- ^ A variable of the same type as the scrutinee 518 -> CoreExpr -- ^ Scrutinee 519 -> CoreExpr 520-- ToDo: eliminate cases where none of the variables are needed. 521-- 522-- mkTupleCase uniqs [a,b,c,d] body v e 523-- = case e of v { (p,q) -> 524-- case p of p { (a,b) -> 525-- case q of q { (c,d) -> 526-- body }}} 527mkTupleCase uniqs vars body scrut_var scrut 528 = mk_tuple_case uniqs (chunkify vars) body 529 where 530 -- This is the case where don't need any nesting 531 mk_tuple_case _ [vars] body 532 = mkSmallTupleCase vars body scrut_var scrut 533 534 -- This is the case where we must make nest tuples at least once 535 mk_tuple_case us vars_s body 536 = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s 537 in mk_tuple_case us' (chunkify vars') body' 538 539 one_tuple_case chunk_vars (us, vs, body) 540 = let (uniq, us') = takeUniqFromSupply us 541 scrut_var = mkSysLocal (fsLit "ds") uniq 542 (mkBoxedTupleTy (map idType chunk_vars)) 543 body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) 544 in (us', scrut_var:vs, body') 545 546-- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed 547-- not to need nesting. 548mkSmallTupleCase 549 :: [Id] -- ^ The tuple args 550 -> CoreExpr -- ^ Body of the case 551 -> Id -- ^ A variable of the same type as the scrutinee 552 -> CoreExpr -- ^ Scrutinee 553 -> CoreExpr 554 555mkSmallTupleCase [var] body _scrut_var scrut 556 = bindNonRec var scrut body 557mkSmallTupleCase vars body scrut_var scrut 558-- One branch no refinement? 559 = Case scrut scrut_var (exprType body) 560 [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] 561 562{- 563************************************************************************ 564* * 565 Floats 566* * 567************************************************************************ 568-} 569 570data FloatBind 571 = FloatLet CoreBind 572 | FloatCase CoreExpr Id AltCon [Var] 573 -- case e of y { C ys -> ... } 574 -- See Note [Floating single-alternative cases] in SetLevels 575 576instance Outputable FloatBind where 577 ppr (FloatLet b) = text "LET" <+> ppr b 578 ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) 579 2 (ppr c <+> ppr bs) 580 581wrapFloat :: FloatBind -> CoreExpr -> CoreExpr 582wrapFloat (FloatLet defns) body = Let defns body 583wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body 584 585-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] 586-- u = let b1 in let b2 in … in let bn in u@ 587wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr 588wrapFloats floats expr = foldr wrapFloat expr floats 589 590bindBindings :: CoreBind -> [Var] 591bindBindings (NonRec b _) = [b] 592bindBindings (Rec bnds) = map fst bnds 593 594floatBindings :: FloatBind -> [Var] 595floatBindings (FloatLet bnd) = bindBindings bnd 596floatBindings (FloatCase _ b _ bs) = b:bs 597 598{- 599************************************************************************ 600* * 601\subsection{Common list manipulation expressions} 602* * 603************************************************************************ 604 605Call the constructor Ids when building explicit lists, so that they 606interact well with rules. 607-} 608 609-- | Makes a list @[]@ for lists of the specified type 610mkNilExpr :: Type -> CoreExpr 611mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] 612 613-- | Makes a list @(:)@ for lists of the specified type 614mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr 615mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] 616 617-- | Make a list containing the given expressions, where the list has the given type 618mkListExpr :: Type -> [CoreExpr] -> CoreExpr 619mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs 620 621-- | Make a fully applied 'foldr' expression 622mkFoldrExpr :: MonadThings m 623 => Type -- ^ Element type of the list 624 -> Type -- ^ Fold result type 625 -> CoreExpr -- ^ "Cons" function expression for the fold 626 -> CoreExpr -- ^ "Nil" expression for the fold 627 -> CoreExpr -- ^ List expression being folded acress 628 -> m CoreExpr 629mkFoldrExpr elt_ty result_ty c n list = do 630 foldr_id <- lookupId foldrName 631 return (Var foldr_id `App` Type elt_ty 632 `App` Type result_ty 633 `App` c 634 `App` n 635 `App` list) 636 637-- | Make a 'build' expression applied to a locally-bound worker function 638mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m) 639 => Type -- ^ Type of list elements to be built 640 -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's 641 -- of the binders for the build worker function, returns 642 -- the body of that worker 643 -> m CoreExpr 644mkBuildExpr elt_ty mk_build_inside = do 645 [n_tyvar] <- newTyVars [alphaTyVar] 646 let n_ty = mkTyVarTy n_tyvar 647 c_ty = mkVisFunTys [elt_ty, n_ty] n_ty 648 [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] 649 650 build_inside <- mk_build_inside (c, c_ty) (n, n_ty) 651 652 build_id <- lookupId buildName 653 return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside 654 where 655 newTyVars tyvar_tmpls = do 656 uniqs <- getUniquesM 657 return (zipWith setTyVarUnique tyvar_tmpls uniqs) 658 659{- 660************************************************************************ 661* * 662 Manipulating Maybe data type 663* * 664************************************************************************ 665-} 666 667 668-- | Makes a Nothing for the specified type 669mkNothingExpr :: Type -> CoreExpr 670mkNothingExpr ty = mkConApp nothingDataCon [Type ty] 671 672-- | Makes a Just from a value of the specified type 673mkJustExpr :: Type -> CoreExpr -> CoreExpr 674mkJustExpr ty val = mkConApp justDataCon [Type ty, val] 675 676 677{- 678************************************************************************ 679* * 680 Error expressions 681* * 682************************************************************************ 683-} 684 685mkRuntimeErrorApp 686 :: Id -- Should be of type (forall a. Addr# -> a) 687 -- where Addr# points to a UTF8 encoded string 688 -> Type -- The type to instantiate 'a' 689 -> String -- The string to print 690 -> CoreExpr 691 692mkRuntimeErrorApp err_id res_ty err_msg 693 = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) 694 , Type res_ty, err_string ] 695 where 696 err_string = Lit (mkLitString err_msg) 697 698mkImpossibleExpr :: Type -> CoreExpr 699mkImpossibleExpr res_ty 700 = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" 701 702{- 703************************************************************************ 704* * 705 Error Ids 706* * 707************************************************************************ 708 709GHC randomly injects these into the code. 710 711@patError@ is just a version of @error@ for pattern-matching 712failures. It knows various ``codes'' which expand to longer 713strings---this saves space! 714 715@absentErr@ is a thing we put in for ``absent'' arguments. They jolly 716well shouldn't be yanked on, but if one is, then you will get a 717friendly message from @absentErr@ (rather than a totally random 718crash). 719 720@parError@ is a special version of @error@ which the compiler does 721not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ 722templates, but we don't ever expect to generate code for it. 723-} 724 725errorIds :: [Id] 726errorIds 727 = [ rUNTIME_ERROR_ID, 728 nON_EXHAUSTIVE_GUARDS_ERROR_ID, 729 nO_METHOD_BINDING_ERROR_ID, 730 pAT_ERROR_ID, 731 rEC_CON_ERROR_ID, 732 rEC_SEL_ERROR_ID, 733 aBSENT_ERROR_ID, 734 tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 735 ] 736 737recSelErrorName, runtimeErrorName, absentErrorName :: Name 738recConErrorName, patErrorName :: Name 739nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name 740typeErrorName :: Name 741absentSumFieldErrorName :: Name 742 743recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID 744absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID 745absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey 746 aBSENT_SUM_FIELD_ERROR_ID 747runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID 748recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID 749patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID 750typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID 751 752noMethodBindingErrorName = err_nm "noMethodBindingError" 753 noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID 754nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" 755 nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID 756 757err_nm :: String -> Unique -> Id -> Name 758err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id 759 760rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id 761pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id 762tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id 763rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName 764rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName 765rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName 766pAT_ERROR_ID = mkRuntimeErrorId patErrorName 767nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName 768nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName 769tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName 770 771-- Note [aBSENT_SUM_FIELD_ERROR_ID] 772-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 773-- Absent argument error for unused unboxed sum fields are different than absent 774-- error used in dummy worker functions (see `mkAbsentErrorApp`): 775-- 776-- - `absentSumFieldError` can't take arguments because it's used in unarise for 777-- unused pointer fields in unboxed sums, and applying an argument would 778-- require allocating a thunk. 779-- 780-- - `absentSumFieldError` can't be CAFFY because that would mean making some 781-- non-CAFFY definitions that use unboxed sums CAFFY in unarise. 782-- 783-- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in 784-- RtsStartup.c and mark it as non-CAFFY here. 785-- 786-- Getting this wrong causes hard-to-debug runtime issues, see #15038. 787-- 788-- TODO: Remove stable pointer hack after fixing #9718. 789-- However, we should still be careful about not making things CAFFY just 790-- because they use unboxed sums. Unboxed objects are supposed to be 791-- efficient, and none of the other unboxed literals make things CAFFY. 792 793aBSENT_SUM_FIELD_ERROR_ID 794 = mkVanillaGlobalWithInfo absentSumFieldErrorName 795 (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a 796 (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes 797 `setArityInfo` 0 798 `setCafInfo` NoCafRefs) -- #15038 799 800mkRuntimeErrorId :: Name -> Id 801-- Error function 802-- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a 803-- with arity: 1 804-- which diverges after being given one argument 805-- The Addr# is expected to be the address of 806-- a UTF8-encoded error string 807mkRuntimeErrorId name 808 = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info 809 where 810 bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig 811 `setArityInfo` 1 812 -- Make arity and strictness agree 813 814 -- Do *not* mark them as NoCafRefs, because they can indeed have 815 -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, 816 -- which has some CAFs 817 -- In due course we may arrange that these error-y things are 818 -- regarded by the GC as permanently live, in which case we 819 -- can give them NoCaf info. As it is, any function that calls 820 -- any pc_bottoming_Id will itself have CafRefs, which bloats 821 -- SRTs. 822 823 strict_sig = mkClosedStrictSig [evalDmd] botRes 824 825runtimeErrorTy :: Type 826-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a 827-- See Note [Error and friends have an "open-tyvar" forall] 828runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] 829 (mkVisFunTy addrPrimTy openAlphaTy) 830 831{- Note [Error and friends have an "open-tyvar" forall] 832~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 833'error' and 'undefined' have types 834 error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a 835 undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a 836Notice the runtime-representation polymorphism. This ensures that 837"error" can be instantiated at unboxed as well as boxed types. 838This is OK because it never returns, so the return type is irrelevant. 839 840 841************************************************************************ 842* * 843 aBSENT_ERROR_ID 844* * 845************************************************************************ 846 847Note [aBSENT_ERROR_ID] 848~~~~~~~~~~~~~~~~~~~~~~ 849We use aBSENT_ERROR_ID to build dummy values in workers. E.g. 850 851 f x = (case x of (a,b) -> b) + 1::Int 852 853The demand analyser figures ot that only the second component of x is 854used, and does a w/w split thus 855 856 f x = case x of (a,b) -> $wf b 857 858 $wf b = let a = absentError "blah" 859 x = (a,b) 860 in <the original RHS of f> 861 862After some simplification, the (absentError "blah") thunk goes away. 863 864------ Tricky wrinkle ------- 865#14285 had, roughly 866 867 data T a = MkT a !a 868 {-# INLINABLE f #-} 869 f x = case x of MkT a b -> g (MkT b a) 870 871It turned out that g didn't use the second component, and hence f doesn't use 872the first. But the stable-unfolding for f looks like 873 \x. case x of MkT a b -> g ($WMkT b a) 874where $WMkT is the wrapper for MkT that evaluates its arguments. We 875apply the same w/w split to this unfolding (see Note [Worker-wrapper 876for INLINEABLE functions] in WorkWrap) so the template ends up like 877 \b. let a = absentError "blah" 878 x = MkT a b 879 in case x of MkT a b -> g ($WMkT b a) 880 881After doing case-of-known-constructor, and expanding $WMkT we get 882 \b -> g (case absentError "blah" of a -> MkT b a) 883 884Yikes! That bogusly appears to evaluate the absentError! 885 886This is extremely tiresome. Another way to think of this is that, in 887Core, it is an invariant that a strict data contructor, like MkT, must 888be applied only to an argument in HNF. So (absentError "blah") had 889better be non-bottom. 890 891So the "solution" is to add a special case for absentError to exprIsHNFlike. 892This allows Simplify.rebuildCase, in the Note [Case to let transformation] 893branch, to convert the case on absentError into a let. We also make 894absentError *not* be diverging, unlike the other error-ids, so that we 895can be sure not to remove the case branches before converting the case to 896a let. 897 898If, by some bug or bizarre happenstance, we ever call absentError, we should 899throw an exception. This should never happen, of course, but we definitely 900can't return anything. e.g. if somehow we had 901 case absentError "foo" of 902 Nothing -> ... 903 Just x -> ... 904then if we return, the case expression will select a field and continue. 905Seg fault city. Better to throw an exception. (Even though we've said 906it is in HNF :-) 907 908It might seem a bit surprising that seq on absentError is simply erased 909 910 absentError "foo" `seq` x ==> x 911 912but that should be okay; since there's no pattern match we can't really 913be relying on anything from it. 914-} 915 916aBSENT_ERROR_ID 917 = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info 918 where 919 absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy) 920 -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for 921 -- lifted-type things; see Note [Absent errors] in WwLib 922 arity_info = vanillaIdInfo `setArityInfo` 1 923 -- NB: no bottoming strictness info, unlike other error-ids. 924 -- See Note [aBSENT_ERROR_ID] 925 926mkAbsentErrorApp :: Type -- The type to instantiate 'a' 927 -> String -- The string to print 928 -> CoreExpr 929 930mkAbsentErrorApp res_ty err_msg 931 = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] 932 where 933 err_string = Lit (mkLitString err_msg) 934