MkId.lhs 49.4 KB
 Thomas Schilling committed Jul 20, 2008 1 %  Simon Marlow committed Oct 11, 2006 2 % (c) The University of Glasgow 2006  simonm committed Dec 02, 1998 3 % (c) The AQUA Project, Glasgow University, 1998  simonpj committed Mar 19, 1998 4 5 6 7 8 % This module contains definitions for the IdInfo for things that have a standard form, namely:  Thomas Schilling committed Jul 20, 2008 9 10 11 12 - data constructors - record selectors - method and superclass selectors - primitive operations  simonpj committed Mar 19, 1998 13 14  \begin{code}  Ian Lynagh committed Nov 04, 2011 15 16 17 18 19 20 21 {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details  simonpj committed Mar 19, 1998 22 module MkId (  Simon Peyton Jones committed Apr 19, 2011 23  mkDictFunId, mkDictFunTy, mkDictSelId,  simonpj committed Mar 19, 1998 24   Simon Peyton Jones committed Dec 14, 2012 25  mkPrimOpId, mkFCallId,  simonpj committed May 18, 1999 26   Simon Peyton Jones committed Dec 14, 2012 27  wrapNewTypeBody, unwrapNewTypeBody,  rl@cse.unsw.edu.au committed Jul 12, 2007 28  wrapFamInstBody, unwrapFamInstScrut,  eir@cis.upenn.edu committed Dec 21, 2012 29 30  wrapTypeFamInstBody, wrapTypeUnbranchedFamInstBody, unwrapTypeFamInstScrut, unwrapTypeUnbranchedFamInstScrut,  Simon Peyton Jones committed Dec 14, 2012 31 32  DataConBoxer(..), mkDataConRep, mkDataConWorkId,  simonpj committed Apr 01, 2002 33   Ian Lynagh committed Feb 19, 2008 34 35  -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds,  simonpj@microsoft.com committed Sep 13, 2010 36  unsafeCoerceName, unsafeCoerceId, realWorldPrimId,  37  voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,  Iavor S. Diatchki committed May 30, 2013 38  coercionTokenId, magicSingIId,  39 40 41  -- Re-export error Ids module PrelRules  simonpj committed Mar 19, 1998 42 43 44 45  ) where #include "HsVersions.h"  Simon Marlow committed Oct 11, 2006 46 47 import Rules import TysPrim  Ian Lynagh committed Sep 13, 2011 48 import TysWiredIn  Simon Marlow committed Oct 11, 2006 49 50 import PrelRules import Type  Simon Peyton Jones committed Dec 23, 2012 51 52 import FamInstEnv import Coercion  Simon Marlow committed Oct 11, 2006 53 import TcType  simonpj@microsoft.com committed Sep 13, 2010 54 import MkCore  dimitris committed Nov 16, 2011 55 import CoreUtils ( exprType, mkCast )  Simon Marlow committed Oct 11, 2006 56 57 58 import CoreUnfold import Literal import TyCon  eir@cis.upenn.edu committed Dec 21, 2012 59 import CoAxiom  Simon Marlow committed Oct 11, 2006 60 import Class  Simon Peyton Jones committed Dec 23, 2012 61 import NameSet  Simon Marlow committed Oct 11, 2006 62 63 64 65 66 67 import VarSet import Name import PrimOp import ForeignCall import DataCon import Id  68 import Var ( mkExportedLocalVar )  Simon Marlow committed Oct 11, 2006 69 import IdInfo  simonpj@microsoft.com committed Nov 19, 2009 70 import Demand  simonm committed Dec 02, 1998 71 import CoreSyn  Simon Marlow committed Oct 11, 2006 72 import Unique  Simon Peyton Jones committed Dec 14, 2012 73 import UniqSupply  simonpj committed Sep 28, 2000 74 import PrelNames  Simon Marlow committed Oct 11, 2006 75 76 import BasicTypes hiding ( SuccessFlag(..) ) import Util  77 import Pair  Ian Lynagh committed Jun 12, 2012 78 import DynFlags  simonpj committed Mar 19, 1998 79 import Outputable  simonmar committed Apr 29, 2002 80 import FastString  Simon Marlow committed Oct 11, 2006 81 import ListSetOps  pcapriotti committed Jul 24, 2012 82 83  import Data.Maybe ( maybeToList )  chak@cse.unsw.edu.au. committed Jun 27, 2007 84 \end{code}  simonpj committed Mar 19, 1998 85   simonpj committed May 18, 1999 86 %************************************************************************  Ian Lynagh committed Feb 19, 2008 87 %* *  simonpj committed May 18, 1999 88 \subsection{Wired in Ids}  Ian Lynagh committed Feb 19, 2008 89 %* *  simonpj committed May 18, 1999 90 91 %************************************************************************  simonpj@microsoft.com committed May 27, 2009 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 Note [Wired-in Ids] ~~~~~~~~~~~~~~~~~~~ There are several reasons why an Id might appear in the wiredInIds: (1) The ghcPrimIds are wired in because they can't be defined in Haskell at all, although the can be defined in Core. They have compulsory unfoldings, so they are always inlined and they have no definition site. Their home module is GHC.Prim, so they also have a description in primops.txt.pp, where they are called 'pseudoops'. (2) The 'error' function, eRROR_ID, is wired in because we don't yet have a way to express in an interface file that the result type variable is 'open'; that is can be unified with an unboxed type [The interface file format now carry such information, but there's no way yet of expressing at the definition site for these error-reporting functions that they have an 'open' result type. -- sof 1/99] (3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because the desugarer generates code that mentiones them directly, and (b) for the same reason as eRROR_ID (4) lazyId is wired in because the wired-in version overrides the strictness of the version defined in GHC.Base In cases (2-4), the function has a definition in a library module, and can be called; but the wired-in version means that the details are never read from that module's interface file; instead, the full definition is right here.  simonpj committed May 18, 1999 124 \begin{code}  batterseapower committed Jul 31, 2008 125 wiredInIds :: [Id]  simonpj committed May 18, 1999 126 wiredInIds  simonpj@microsoft.com committed Sep 14, 2010 127 128 129  = [lazyId] ++ errorIds -- Defined in MkCore ++ ghcPrimIds  simonmar committed Mar 05, 2002 130 131  -- These Ids are exported from GHC.Prim  batterseapower committed Jul 31, 2008 132 ghcPrimIds :: [Id]  simonmar committed Mar 05, 2002 133 ghcPrimIds  Ian Lynagh committed Feb 19, 2008 134 135  = [ -- These can't be defined in Haskell, but they have -- perfectly reasonable unfoldings in Core  simonmar committed Mar 05, 2002 136 137 138  realWorldPrimId, unsafeCoerceId, nullAddrId,  Iavor S. Diatchki committed May 30, 2013 139 140  seqId, magicSingIId  simonpj committed May 18, 1999 141 142 143  ] \end{code}  simonpj committed Mar 19, 1998 144 %************************************************************************  Ian Lynagh committed Feb 19, 2008 145 %* *  simonpj committed Mar 19, 1998 146 \subsection{Data constructors}  Ian Lynagh committed Feb 19, 2008 147 %* *  simonpj committed Mar 19, 1998 148 149 %************************************************************************  simonpj committed Mar 23, 2000 150 151 152 153 The wrapper for a constructor is an ordinary top-level binding that evaluates any strict args, unboxes any args that are going to be flattened, and calls the worker.  simonpj committed Mar 19, 1998 154 155 We're going to build a constructor that looks like:  Ian Lynagh committed Feb 19, 2008 156  data (Data a, C b) => T a b = T1 !a !Int b  simonpj committed Mar 19, 1998 157   Ian Lynagh committed Feb 19, 2008 158 159 160 161 162  T1 = /\ a b -> \d1::Data a, d2::C b -> \p q r -> case p of { p -> case q of { q -> Con T1 [a,b] [p,q,r]}}  simonpj committed Mar 19, 1998 163 164 165 166 167 168 169 170 171 172  Notice that * d2 is thrown away --- a context in a data decl is used to make sure one *could* construct dictionaries at the site the constructor is used, but the dictionary isn't actually used. * We have to check that we can construct Data dictionaries for the types a and Int. Once we've done that we can throw d1 away too.  simonpj committed May 18, 1999 173 * We use (case p of q -> ...) to evaluate p, rather than "seq" because  simonpj committed Mar 19, 1998 174 175 176 177  all that matters is that the arguments are evaluated. "seq" is very careful to preserve evaluation order, which we don't need to be here.  simonpj committed May 18, 1999 178 179 180 181 182 183 184 185 186  You might think that we could simply give constructors some strictness info, like PrimOps, and let CoreToStg do the let-to-case transformation. But we don't do that because in the case of primops and functions strictness is a *property* not a *requirement*. In the case of constructors we need to do something active to evaluate the argument. Making an explicit case expression allows the simplifier to eliminate it in the (common) case where the constructor arg is already evaluated.  simonpj@microsoft.com committed Apr 22, 2007 187 188 Note [Wrappers for data instance tycons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  chak@cse.unsw.edu.au. committed Sep 20, 2006 189 190 In the case of data instances, the wrapper also applies the coercion turning the representation type into the family instance type to cast the result of  chak@cse.unsw.edu.au. committed Sep 20, 2006 191 192 193 194 195 the wrapper. For example, consider the declarations data family Map k :: * -> * data instance Map (a, b) v = MapPair (Map a (Pair b v))  simonpj@microsoft.com committed Apr 22, 2007 196 197 198 199 200 201 202 The tycon to which the datacon MapPair belongs gets a unique internal name of the form :R123Map, and we call it the representation tycon. In contrast, Map is the family tycon (accessible via tyConFamInst_maybe). A coercion allows you to move between representation and family type. It is accessible from :R123Map via tyConFamilyCoercion_maybe and has kind  simonpj@microsoft.com committed Sep 20, 2008 203  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}  simonpj@microsoft.com committed Apr 22, 2007 204 205  The wrapper and worker of MapPair get the types  chak@cse.unsw.edu.au. committed Sep 20, 2006 206   Ian Lynagh committed Feb 19, 2008 207  -- Wrapper  chak@cse.unsw.edu.au. committed Sep 20, 2006 208  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v  simonpj@microsoft.com committed May 02, 2007 209 $WMapPair a b v = MapPair a b v cast sym (Co123Map a b v)  simonpj@microsoft.com committed Apr 22, 2007 210   Ian Lynagh committed Feb 19, 2008 211  -- Worker  simonpj@microsoft.com committed May 02, 2007 212  MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v  chak@cse.unsw.edu.au. committed Sep 20, 2006 213   simonpj@microsoft.com committed Apr 22, 2007 214 This coercion is conditionally applied by wrapFamInstBody.  chak@cse.unsw.edu.au. committed Sep 20, 2006 215   simonpj@microsoft.com committed Apr 22, 2007 216 It's a bit more complicated if the data instance is a GADT as well!  chak@cse.unsw.edu.au. committed Sep 20, 2006 217   simonpj@microsoft.com committed Apr 22, 2007 218  data instance T [a] where  Ian Lynagh committed Feb 19, 2008 219  T1 :: forall b. b -> T [Maybe b]  simonpj@microsoft.com committed Apr 22, 2007 220   simonpj@microsoft.com committed Aug 23, 2010 221 Hence we translate to  simonpj@microsoft.com committed Apr 22, 2007 222   Ian Lynagh committed Feb 19, 2008 223  -- Wrapper  simonpj@microsoft.com committed Apr 22, 2007 224  $WT1 :: forall b. b -> T [Maybe b]  simonpj@microsoft.com committed May 02, 2007 225 $WT1 b v = T1 (Maybe b) b (Maybe b) v  Ian Lynagh committed Feb 19, 2008 226  cast sym (Co7T (Maybe b))  simonpj@microsoft.com committed Apr 22, 2007 227   Ian Lynagh committed Feb 19, 2008 228  -- Worker  simonpj@microsoft.com committed May 02, 2007 229  T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c  simonpj committed Oct 09, 2003 230   simonpj@microsoft.com committed Aug 23, 2010 231 232 233  -- Coercion from family type to representation type Co7T a :: T [a] ~ :R7T a  simonpj@microsoft.com committed Jan 02, 2009 234 235 236 237 238 239 240 241 242 243 244 Note [Newtype datacons] ~~~~~~~~~~~~~~~~~~~~~~~ The "data constructor" for a newtype should always be vanilla. At one point this wasn't true, because the newtype arising from class C a => D a looked like newtype T:D a = D:D (C a) so the data constructor for T:C had a single argument, namely the predicate (C a). But now we treat that as an ordinary argument, not part of the theta-type, so all is well.  simonpj committed Mar 19, 1998 245 246  %************************************************************************  Ian Lynagh committed Feb 19, 2008 247 %* *  simonpj@microsoft.com committed Jan 02, 2009 248 \subsection{Dictionary selectors}  Ian Lynagh committed Feb 19, 2008 249 %* *  simonpj committed Mar 19, 1998 250 251 %************************************************************************  simonpj@microsoft.com committed Jan 02, 2009 252 253 Selecting a field for a dictionary. If there is just one field, then there's nothing to do.  simonpj committed Oct 14, 2005 254   simonpj@microsoft.com committed Jan 02, 2009 255 Dictionary selectors may get nested forall-types. Thus:  simonpj committed Oct 14, 2005 256   simonpj@microsoft.com committed Jan 02, 2009 257 258  class Foo a where op :: forall b. Ord b => a -> b -> b  simonpj committed Oct 14, 2005 259   simonpj@microsoft.com committed Jan 02, 2009 260 Then the top-level type for op is  simonpj@microsoft.com committed Aug 11, 2008 261   simonpj@microsoft.com committed Jan 02, 2009 262 263 264  op :: forall a. Foo a => forall b. Ord b => a -> b -> b  simonpj@microsoft.com committed Aug 11, 2008 265   simonpj@microsoft.com committed Jan 02, 2009 266 267 268 This is unlike ordinary record selectors, which have all the for-alls at the outside. When dealing with classes it's very convenient to recover the original type signature from the class op selector.  simonpj@microsoft.com committed Aug 11, 2008 269   simonpj@microsoft.com committed Jan 02, 2009 270 \begin{code}  ian@well-typed.com committed Oct 09, 2012 271 272 mkDictSelId :: DynFlags -> Bool -- True <=> don't include the unfolding  simonpj@microsoft.com committed Sep 13, 2010 273 274 275 276 277  -- Little point on imports without -O, because the -- dictionary itself won't be visible -> Name -- Name of one of the *value* selectors -- (dictionary superclass or method) -> Class -> Id  ian@well-typed.com committed Oct 09, 2012 278 mkDictSelId dflags no_unf name clas  simonpj@microsoft.com committed Jan 02, 2009 279 280 281 282 283 284 285 286  = mkGlobalId (ClassOpId clas) name sel_ty info where sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) -- We can't just say (exprType rhs), because that would give a type -- C a -> C a -- for a single-op class (after all, the selector is the identity) -- But it's type must expose the representation of the dictionary -- to get (say) C a -> (a -> a)  simonpj@microsoft.com committed Aug 11, 2008 287   288  base_info = noCafIdInfo  Simon Peyton Jones committed Jan 17, 2013 289 290 291 292  setArityInfo 1 setStrictnessInfo strict_sig setUnfoldingInfo (if no_unf then noUnfolding else mkImplicitUnfolding dflags rhs)  293 294  -- In module where class op is defined, we must add -- the unfolding, even though it'll never be inlined  Gabor Greif committed Jan 30, 2013 295  -- because we use that to generate a top-level binding  296 297  -- for the ClassOp  simonpj@microsoft.com committed Nov 01, 2010 298  info | new_tycon = base_info setInlinePragInfo alwaysInlinePragma  Simon Peyton Jones committed Jun 13, 2011 299 300  -- See Note [Single-method classes] in TcInstDcls -- for why alwaysInlinePragma  simonpj@microsoft.com committed Nov 01, 2010 301 302 303 304 305  | otherwise = base_info setSpecInfo mkSpecInfo [rule] setInlinePragInfo neverInlinePragma -- Add a magic BuiltinRule, and never inline it -- so that the rule is always available to fire. -- See Note [ClassOp/DFun selection] in TcInstDcls  simonpj@microsoft.com committed Aug 11, 2008 306   simonpj@microsoft.com committed Oct 29, 2009 307 308 309 310 311 312 313 314  n_ty_args = length tyvars -- This is the built-in rule that goes -- op (dfT d1 d2) ---> opT d1 d2 rule = BuiltinRule { ru_name = fsLit "Class op " appendFS occNameFS (getOccName name) , ru_fn = name , ru_nargs = n_ty_args + 1  315  , ru_try = dictSelRule val_index n_ty_args }  simonpj@microsoft.com committed Oct 29, 2009 316   simonpj@microsoft.com committed Jan 02, 2009 317 318 319 320  -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting -- It's worth giving one, so that absence info etc is generated -- even if the selector isn't inlined  Simon Peyton Jones committed Jan 17, 2013 321 322  strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] topRes)  323  arg_dmd | new_tycon = evalDmd  Simon Peyton Jones committed Jun 06, 2013 324 325  | otherwise = mkManyUsedDmd $mkProdDmd [ if the_arg_id == id then evalDmd else absDmd  Simon Peyton Jones committed Jan 17, 2013 326 327  | id <- arg_ids ]  simonpj@microsoft.com committed Sep 13, 2010 328 329 330 331 332  tycon = classTyCon clas new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses  simonpj@microsoft.com committed Apr 22, 2007 333   simonpj@microsoft.com committed Sep 13, 2010 334 335 336  -- 'index' is a 0-index into the *value* arguments of the dictionary val_index = assoc "MkId.mkDictSelId" sel_index_prs name sel_index_prs = map idName (classAllSelIds clas) zip [0..]  simonpj committed Oct 14, 2005 337   Simon Peyton Jones committed Jan 02, 2013 338  the_arg_id = getNth arg_ids val_index  simonpj@microsoft.com committed Sep 13, 2010 339  pred = mkClassPred clas (mkTyVarTys tyvars)  batterseapower committed Sep 06, 2011 340  dict_id = mkTemplateLocal 1 pred  simonpj@microsoft.com committed Sep 13, 2010 341  arg_ids = mkTemplateLocalsNum 2 arg_tys  simonpj committed Oct 14, 2005 342   simonpj@microsoft.com committed Jan 02, 2009 343  rhs = mkLams tyvars (Lam dict_id rhs_body)  344 345  rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)  Simon Peyton Jones committed Jun 22, 2011 346 347 348  [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] -- varToCoreExpr needed for equality superclass selectors -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }  simonpj@microsoft.com committed Oct 29, 2009 349   Simon Peyton Jones committed May 30, 2013 350 dictSelRule :: Int -> Arity -> RuleFun  simonpj@microsoft.com committed Dec 13, 2010 351 352 353 -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it  simonpj@microsoft.com committed Sep 13, 2010 354 -- sel_i t1..tk (D t1..tk op1 ... opm) = opi  simonpj@microsoft.com committed Oct 29, 2009 355 --  Simon Peyton Jones committed May 30, 2013 356 dictSelRule val_index n_ty_args _ id_unf _ args  simonpj@microsoft.com committed Oct 29, 2009 357  | (dict_arg : _) <- drop n_ty_args args  simonpj@microsoft.com committed Sep 13, 2010 358  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg  Simon Peyton Jones committed Jan 02, 2013 359  = Just (getNth con_args val_index)  simonpj@microsoft.com committed Oct 29, 2009 360 361  | otherwise = Nothing  simonpj@microsoft.com committed Jan 02, 2009 362 \end{code}  simonpj@microsoft.com committed Apr 22, 2007 363 364   simonpj@microsoft.com committed Jan 02, 2009 365 366 367 368 369 %************************************************************************ %* * Boxing and unboxing %* * %************************************************************************  simonpj@microsoft.com committed Apr 22, 2007 370   Simon Peyton Jones committed Dec 14, 2012 371 372 373 374 375 376 377 378 379  \begin{code} mkDataConWorkId :: Name -> DataCon -> Id mkDataConWorkId wkr_name data_con | isNewTyCon tycon = mkGlobalId (DataConWrapId data_con) wkr_name nt_wrap_ty nt_work_info | otherwise = mkGlobalId (DataConWorkId data_con) wkr_name alg_wkr_ty wkr_info  chak@cse.unsw.edu.au. committed Sep 20, 2006 380  where  Simon Peyton Jones committed Dec 14, 2012 381 382 383 384 385 386 387  tycon = dataConTyCon data_con ----------- Workers for data types -------------- alg_wkr_ty = dataConRepType data_con wkr_arity = dataConRepArity data_con wkr_info = noCafIdInfo setArityInfo wkr_arity  Simon Peyton Jones committed Jan 17, 2013 388  setStrictnessInfo wkr_sig  Simon Peyton Jones committed Dec 14, 2012 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424  setUnfoldingInfo evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) (dataConCPR data_con)) -- Note [Data-con worker strictness] -- Notice that we do *not* say the worker is strict -- even if the data constructor is declared strict -- e.g. data T = MkT !(Int,Int) -- Why? Because the *wrapper* is strict (and its unfolding has case -- expresssions that do the evals) but the *worker* itself is not. -- If we pretend it is strict then when we see -- case x of y ->$wMkT y -- the simplifier thinks that y is "sure to be evaluated" (because -- $wMkT is strict) and drops the case. No,$wMkT is not strict. -- -- When the simplifer sees a pattern -- case e of MkT x -> ... -- it uses the dataConRepStrictness of MkT to mark x as evaluated; -- but that's fine... dataConRepStrictness comes from the data con -- not from the worker Id. ----------- Workers for newtypes -------------- (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con res_ty_args = mkTyVarTys nt_tvs nt_wrap_ty = dataConUserType data_con nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo setArityInfo 1 -- Arity 1 setInlinePragInfo alwaysInlinePragma setUnfoldingInfo newtype_unf id_arg1 = mkTemplateLocal 1 (head nt_arg_tys) newtype_unf = ASSERT2( isVanillaDataCon data_con && isSingleton nt_arg_tys, ppr data_con ) -- Note [Newtype datacons] mkCompulsoryUnfolding $mkLams nt_tvs$ Lam id_arg1 $wrapNewTypeBody tycon res_ty_args (Var id_arg1)  simonpj committed May 18, 2001 425   Simon Peyton Jones committed Dec 14, 2012 426 427 dataConCPR :: DataCon -> DmdResult dataConCPR con  Simon Peyton Jones committed Jan 24, 2013 428 429 430  | isDataTyCon tycon -- Real data types only; that is, -- not unboxed tuples or newtypes , isVanillaDataCon con -- No existentials  Simon Peyton Jones committed Dec 14, 2012 431 432  , wkr_arity > 0 , wkr_arity <= mAX_CPR_SIZE  Simon Peyton Jones committed Jan 24, 2013 433 434  = if is_prod then cprProdRes else cprSumRes (dataConTag con)  Simon Peyton Jones committed Dec 14, 2012 435  | otherwise  Simon Peyton Jones committed Jan 17, 2013 436  = topRes  Simon Peyton Jones committed Dec 14, 2012 437  where  Simon Peyton Jones committed Jan 24, 2013 438  is_prod = isProductTyCon tycon  Simon Peyton Jones committed Dec 14, 2012 439 440 441 442 443 444 445 446 447 448 449 450 451 452  tycon = dataConTyCon con wkr_arity = dataConRepArity con mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 -- We do not treat very big tuples as CPR-ish: -- a) for a start we get into trouble because there aren't -- "enough" unboxed tuple types (a tiresome restriction, -- but hard to fix), -- b) more importantly, big unboxed tuples get returned mainly -- on the stack, and are often then allocated in the heap -- by the caller. So doing CPR for them may in fact make -- things worse. \end{code}  simonpj committed May 18, 2001 453   Simon Peyton Jones committed Dec 23, 2012 454 455 456 457 458 459 460 461 462 ------------------------------------------------- -- Data constructor representation -- -- This is where we decide how to wrap/unwrap the -- constructor fields -- --------------------------------------------------  Simon Peyton Jones committed Dec 14, 2012 463 \begin{code}  Simon Peyton Jones committed Dec 23, 2012 464 465 466 467 468 469 470 471 472 473 474 475 type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) -- Unbox: bind rep vars by decomposing src var data Boxer = UnitBox | Boxer (TvSubst -> UniqSM ([Var], CoreExpr)) -- Box: build src arg using these rep vars newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) -- Bind these src-level vars, returning the -- rep-level vars to bind in the pattern mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep mkDataConRep dflags fam_envs wrap_name data_con  Simon Peyton Jones committed Dec 14, 2012 476 477  | not wrapper_reqd = return NoDataConRep  simonpj committed May 18, 2001 478   simonpj committed Apr 01, 2002 479  | otherwise  Simon Peyton Jones committed Dec 14, 2012 480 481 482 483 484 485 486 487 488 489 490  = do { wrap_args <- mapM newLocal wrap_arg_tys ; wrap_body <- mk_rep_app (wrap_args zip dropList eq_spec unboxers) initial_wrap_app ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info wrap_info = noCafIdInfo setArityInfo wrap_arity -- It's important to specify the arity, so that partial -- applications are treated as values setInlinePragInfo alwaysInlinePragma setUnfoldingInfo wrap_unf  Simon Peyton Jones committed Jan 17, 2013 491  setStrictnessInfo wrap_sig  Simon Peyton Jones committed Dec 14, 2012 492 493 494 495 496 497 498  -- We need to get the CAF info right here because TidyPgm -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds (dataConCPR data_con)) wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs) mk_dmd str | isBanged str = evalDmd  Simon Peyton Jones committed Jan 17, 2013 499  | otherwise = topDmd  Simon Peyton Jones committed Dec 14, 2012 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520  -- The Cpr info can be important inside INLINE rhss, where the -- wrapper constructor isn't inlined. -- And the argument strictness can be important too; we -- may not inline a contructor when it is partially applied. -- For example: -- data W = C !Int !Int !Int -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments wrap_unf = mkInlineUnfolding (Just wrap_arity) wrap_rhs wrap_tvs = (univ_tvs minusList map fst eq_spec) ++ ex_tvs wrap_rhs = mkLams wrap_tvs$ mkLams wrap_args $wrapFamInstBody tycon res_ty_args$ wrap_body ; return (DCR { dcr_wrap_id = wrap_id , dcr_boxer = mk_boxer boxers , dcr_arg_tys = rep_tys , dcr_stricts = rep_strs , dcr_bangs = dropList ev_tys wrap_bangs }) }  simonpj committed May 18, 2001 521   simonpj committed Apr 01, 2002 522  where  Simon Peyton Jones committed Dec 14, 2012 523 524 525 526 527 528 529 530 531 532 533 534 535 536  (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs tycon = dataConTyCon data_con -- The representation TyCon (not family) wrap_ty = dataConUserType data_con ev_tys = eqSpecPreds eq_spec ++ theta all_arg_tys = ev_tys ++ orig_arg_tys orig_bangs = map mk_pred_strict_mark ev_tys ++ dataConStrictMarks data_con wrap_arg_tys = theta ++ orig_arg_tys wrap_arity = length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the -- wrapper  Simon Peyton Jones committed Dec 23, 2012 537 538 539  (wrap_bangs, rep_tys_w_strs, wrappers) = unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs) (unboxers, boxers) = unzip wrappers  Simon Peyton Jones committed Dec 14, 2012 540 541 542 543 544 545 546 547 548 549  (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker && (any isBanged orig_bangs -- Some forcing/unboxing -- (includes eq_spec) || isFamInstTyCon tycon) -- Cast result initial_wrap_app = Var (dataConWorkId data_con) mkTyApps res_ty_args mkVarApps ex_tvs  eir@cis.upenn.edu committed Aug 02, 2013 550  mkCoApps map (mkReflCo Nominal . snd) eq_spec  Simon Peyton Jones committed Dec 14, 2012 551 552 553 554 555 556 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  -- Dont box the eq_spec coercions since they are -- marked as HsUnpack by mk_dict_strict_mark mk_boxer :: [Boxer] -> DataConBoxer mk_boxer boxers = DCB (\ ty_args src_vars -> do { let ex_vars = takeList ex_tvs src_vars subst1 = mkTopTvSubst (univ_tvs zip ty_args) subst2 = extendTvSubstList subst1 ex_tvs (mkTyVarTys ex_vars) ; (rep_ids, binds) <- go subst2 boxers (dropList ex_tvs src_vars) ; return (ex_vars ++ rep_ids, binds) } ) go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) go subst (UnitBox : boxers) (src_var : src_vars) = do { (rep_ids2, binds) <- go subst boxers src_vars ; return (src_var : rep_ids2, binds) } go subst (Boxer boxer : boxers) (src_var : src_vars) = do { (rep_ids1, arg) <- boxer subst ; (rep_ids2, binds) <- go subst boxers src_vars ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr mk_rep_app [] con_app = return con_app mk_rep_app ((wrap_arg, unboxer) : prs) con_app = do { (rep_ids, unbox_fn) <- unboxer wrap_arg ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) ; return (unbox_fn expr) } ------------------------- newLocal :: Type -> UniqSM Var newLocal ty = do { uniq <- getUniqueUs ; return (mkSysLocal (fsLit "dt") uniq ty) } ------------------------- dataConArgRep :: DynFlags  Simon Peyton Jones committed Dec 23, 2012 589  -> FamInstEnvs  Simon Peyton Jones committed Dec 14, 2012 590 591 592  -> Type -> HsBang -> ( HsBang -- Like input but with HsUnpackFailed if necy , [(Type, StrictnessMark)] -- Rep types  Simon Peyton Jones committed Dec 23, 2012 593 594 595 596 597  , (Unboxer, Boxer) ) dataConArgRep _ _ arg_ty HsNoBang = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))  Simon Peyton Jones committed Jan 14, 2013 598 599 600 601 602 dataConArgRep _ _ arg_ty (HsUserBang _ False) -- No '!' = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) dataConArgRep dflags fam_envs arg_ty (HsUserBang unpk_prag True) -- {-# UNPACK #-} !  Simon Peyton Jones committed Dec 23, 2012 603  | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas  604 605  -- Don't unpack if we aren't optimising; rather arbitrarily, -- we use -fomit-iface-pragmas as the indication  Simon Peyton Jones committed Dec 23, 2012 606  , let mb_co = topNormaliseType fam_envs arg_ty  607  -- Unwrap type families and newtypes  Simon Peyton Jones committed Dec 23, 2012 608 609 610  arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } , isUnpackableType fam_envs arg_ty' , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'  Simon Peyton Jones committed Jan 14, 2013 611 612 613 614 615  , case unpk_prag of Nothing -> gopt Opt_UnboxStrictFields dflags || (gopt Opt_UnboxSmallStrictFields dflags && length rep_tys <= 1) -- See Note [Unpack one-wide fields] Just unpack_me -> unpack_me  Simon Peyton Jones committed Dec 23, 2012 616 617 618  = case mb_co of Nothing -> (HsUnpack Nothing, rep_tys, wrappers) Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)  Simon Peyton Jones committed Dec 14, 2012 619 620 621 622  | otherwise -- Record the strict-but-no-unpack decision = strict_but_not_unpacked arg_ty  Simon Peyton Jones committed Dec 23, 2012 623 624 dataConArgRep _ _ arg_ty HsStrict = strict_but_not_unpacked arg_ty  Simon Peyton Jones committed Dec 14, 2012 625   Simon Peyton Jones committed Dec 23, 2012 626 627 628 dataConArgRep _ _ arg_ty (HsUnpack Nothing) | (rep_tys, wrappers) <- dataConArgUnpack arg_ty = (HsUnpack Nothing, rep_tys, wrappers)  Simon Peyton Jones committed Dec 14, 2012 629   Simon Peyton Jones committed Dec 23, 2012 630 631 632 633 dataConArgRep _ _ _ (HsUnpack (Just co)) | let co_rep_ty = pSnd (coercionKind co) , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)  Simon Peyton Jones committed Dec 14, 2012 634   Simon Peyton Jones committed Dec 23, 2012 635 strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], (Unboxer, Boxer))  Simon Peyton Jones committed Dec 14, 2012 636 strict_but_not_unpacked arg_ty  Simon Peyton Jones committed Dec 23, 2012 637  = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))  Simon Peyton Jones committed Dec 14, 2012 638 639  -------------------------  Simon Peyton Jones committed Dec 23, 2012 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty = (unboxer, boxer) where unboxer arg_id = do { rep_id <- newLocal rep_ty ; (rep_ids, rep_fn) <- unbox_rep rep_id ; let co_bind = NonRec rep_id (Var arg_id Cast co) ; return (rep_ids, Let co_bind . rep_fn) } boxer = Boxer $\ subst -> do { (rep_ids, rep_expr) <- case box_rep of UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) ; return ([rep_id], Var rep_id) } Boxer boxer -> boxer subst ; let sco = substCo (tvCvSubst subst) co ; return (rep_ids, rep_expr Cast mkSymCo sco) } ------------------------  Simon Peyton Jones committed Dec 14, 2012 658 659 660 661 662 663 664 665 666 667 668 669 seqUnboxer :: Unboxer seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)]) unitUnboxer :: Unboxer unitUnboxer v = return ([v], \e -> e) unitBoxer :: Boxer unitBoxer = UnitBox ------------------------- dataConArgUnpack :: Type  Simon Peyton Jones committed Dec 23, 2012 670 671  -> ( [(Type, StrictnessMark)] -- Rep types , (Unboxer, Boxer) )  Simon Peyton Jones committed Dec 14, 2012 672 673  dataConArgUnpack arg_ty  Simon Peyton Jones committed Dec 23, 2012 674  | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty  675 676 677 678  , Just con <- tyConSingleAlgDataCon_maybe tc -- NB: check for an *algebraic* data type -- A recursive newtype might mean that -- 'arg_ty' is a newtype  Simon Peyton Jones committed Dec 23, 2012 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699  , let rep_tys = dataConInstArgTys con tc_args = ASSERT( isVanillaDataCon con ) ( rep_tys zip dataConRepStrictness con ,( \ arg_id -> do { rep_ids <- mapM newLocal rep_tys ; let unbox_fn body = Case (Var arg_id) arg_id (exprType body) [(DataAlt con, rep_ids, body)] ; return (rep_ids, unbox_fn) } , Boxer$ \ subst -> do { rep_ids <- mapM (newLocal . TcType.substTy subst) rep_tys ; return (rep_ids, Var (dataConWorkId con) mkTyApps (substTys subst tc_args) mkVarApps rep_ids ) } ) ) | otherwise = pprPanic "dataConArgUnpack" (ppr arg_ty) -- An interface file specified Unpacked, but we couldn't unpack it isUnpackableType :: FamInstEnvs -> Type -> Bool -- True if we can unpack the UNPACK fields of the constructor -- without involving the NameSet tycons  Simon Peyton Jones committed Jan 14, 2013 700 701 702 703 -- See Note [Recursive unboxing] -- We look "deeply" inside rather than relying on the DataCons -- we encounter on the way, because otherwise we might well -- end up relying on ourselves!  Simon Peyton Jones committed Dec 23, 2012 704 705 isUnpackableType fam_envs ty | Just (tc, _) <- splitTyConApp_maybe ty  706  , Just con <- tyConSingleAlgDataCon_maybe tc  Simon Peyton Jones committed Dec 23, 2012 707 708 709 710  , isVanillaDataCon con = ok_con_args (unitNameSet (getName tc)) con | otherwise = False  Simon Peyton Jones committed Dec 14, 2012 711  where  Simon Peyton Jones committed Jan 14, 2013 712  ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty  Simon Peyton Jones committed Dec 23, 2012 713 714 715 716 717 718 719 720  where norm_ty = case topNormaliseType fam_envs ty of Just (_, ty) -> ty Nothing -> ty ok_ty tcs ty | Just (tc, _) <- splitTyConApp_maybe ty , let tc_name = getName tc = not (tc_name elemNameSet tcs)  721  && case tyConSingleAlgDataCon_maybe tc of  Simon Peyton Jones committed Dec 23, 2012 722 723 724 725 726 727 728 729  Just con | isVanillaDataCon con -> ok_con_args (tcs addOneToNameSet getName tc) con _ -> True | otherwise = True ok_con_args tcs con = all (ok_arg tcs) (dataConOrigArgTys con zip dataConStrictMarks con)  Simon Peyton Jones committed Jan 14, 2013 730 731  -- NB: dataConStrictMarks gives the *user* request; -- We'd get a black hole if we used dataConRepBangs  Simon Peyton Jones committed Dec 23, 2012 732   Simon Peyton Jones committed Jan 14, 2013 733 734 735  attempt_unpack (HsUnpack {}) = True attempt_unpack (HsUserBang (Just unpk) _) = unpk attempt_unpack _ = False  simonpj committed Mar 19, 1998 736 737 \end{code}  Simon Peyton Jones committed Dec 14, 2012 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 Note [Unpack one-wide fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The flag UnboxSmallStrictFields ensures that any field that can (safely) be unboxed to a word-sized unboxed field, should be so unboxed. For example: data A = A Int# newtype B = B A data C = C !B data D = D !C data E = E !() data F = F !D data G = G !F !F All of these should have an Int# as their representation, except G which should have two Int#s. However data T = T !(S Int) data S = S !a Here we can represent T with an Int#. Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful not to try to unbox this! data T = MkT {-# UNPACK #-} !T Int Reason: consider data R = MkR {-# UNPACK #-} !S Int data S = MkS {-# UNPACK #-} !Int The representation arguments of MkR are the *representation* arguments of S (plus Int); the rep args of MkS are Int#. This is obviously no good for T, because then we'd get an infinite number of arguments. But it's the *argument* type that matters. This is fine: data S = MkS S !Int because Int is non-recursive. Note [Unpack equality predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have a GADT with a contructor C :: (a~[b]) => b -> T a we definitely want that equality predicate *unboxed* so that it takes no space at all. This is easily done: just give it an UNPACK pragma. The rest of the unpack/repack code does the heavy lifting. This one line makes every GADT take a word less space for each equality predicate, so it's pretty important! \begin{code} mk_pred_strict_mark :: PredType -> HsBang mk_pred_strict_mark pred  Simon Peyton Jones committed Dec 23, 2012 791  | isEqPred pred = HsUnpack Nothing -- Note [Unpack equality predicates]  Simon Peyton Jones committed Dec 14, 2012 792 793  | otherwise = HsNoBang \end{code}  simonpj committed Mar 19, 1998 794   simonpj@microsoft.com committed Apr 22, 2007 795 %************************************************************************  Ian Lynagh committed Feb 19, 2008 796 797 798 %* * Wrapping and unwrapping newtypes and type families %* *  simonpj@microsoft.com committed Apr 22, 2007 799 800 801 %************************************************************************ \begin{code}  chak@cse.unsw.edu.au. committed Sep 18, 2006 802 803 wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- The wrapper for the data constructor for a newtype looks like this:  Ian Lynagh committed Feb 19, 2008 804 805 806 -- newtype T a = MkT (a,Int) -- MkT :: forall a. (a,Int) -> T a -- MkT = /\a. \(x:(a,Int)). x cast sym (CoT a)  chak@cse.unsw.edu.au. committed Sep 18, 2006 807 808 809 810 -- where CoT is the coercion TyCon assoicated with the newtype -- -- The call (wrapNewTypeBody T [a] e) returns the -- body of the wrapper, namely  Ian Lynagh committed Feb 19, 2008 811 -- e cast (CoT [a])  chak@cse.unsw.edu.au. committed Sep 18, 2006 812 --  simonpj@microsoft.com committed Apr 22, 2007 813 -- If a coercion constructor is provided in the newtype, then we use  chak@cse.unsw.edu.au. committed Sep 20, 2006 814 -- it, otherwise the wrap/unwrap are both no-ops  chak@cse.unsw.edu.au. committed Sep 18, 2006 815 --  simonpj@microsoft.com committed Apr 22, 2007 816 -- If the we are dealing with a newtype *instance*, we have a second coercion  chak@cse.unsw.edu.au. committed Sep 20, 2006 817 818 819 -- identifying the family instance with the constructor of the newtype -- instance. This coercion is applied in any case (ie, composed with the -- coercion constructor of the newtype or applied by itself).  simonpj@microsoft.com committed Apr 22, 2007 820   chak@cse.unsw.edu.au. committed Sep 18, 2006 821 wrapNewTypeBody tycon args result_expr  822 823  = ASSERT( isNewTyCon tycon ) wrapFamInstBody tycon args $ dimitris committed Nov 16, 2011 824  mkCast result_expr (mkSymCo co)  chak@cse.unsw.edu.au. committed Sep 20, 2006 825  where  eir@cis.upenn.edu committed Aug 02, 2013 826  co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args  chak@cse.unsw.edu.au. committed Sep 18, 2006 827   chak@cse.unsw.edu.au. committed Sep 20, 2006 828 829 830 831 -- When unwrapping, we do *not* apply any family coercion, because this will -- be done via a CoPat by the type checker. We have to do it this way as -- computing the right type arguments for the coercion requires more than just -- a spliting operation (cf, TcPat.tcConPat).  simonpj@microsoft.com committed Apr 22, 2007 832   chak@cse.unsw.edu.au. committed Sep 18, 2006 833 834 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr  835  = ASSERT( isNewTyCon tycon )  eir@cis.upenn.edu committed Aug 02, 2013 836  mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args)  chak@cse.unsw.edu.au. committed Sep 20, 2006 837   simonpj@microsoft.com committed Apr 22, 2007 838 839 840 841 842 843 844 845 -- If the type constructor is a representation type of a data instance, wrap -- the expression into a cast adjusting the expression type, which is an -- instance of the representation type, to the corresponding instance of the -- family instance type. -- See Note [Wrappers for data instance tycons] wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody tycon args body | Just co_con <- tyConFamilyCoercion_maybe tycon  eir@cis.upenn.edu committed Aug 02, 2013 846  = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))  simonpj@microsoft.com committed Apr 22, 2007 847 848  | otherwise = body  chak@cse.unsw.edu.au. committed Sep 20, 2006 849   Simon Peyton Jones committed Jan 03, 2012 850 851 -- Same as wrapFamInstBody, but for type family instances, which are -- represented by a CoAxiom, and not a TyCon  eir@cis.upenn.edu committed Dec 21, 2012 852 853 wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr wrapTypeFamInstBody axiom ind args body  eir@cis.upenn.edu committed Aug 02, 2013 854  = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))  eir@cis.upenn.edu committed Dec 21, 2012 855 856 857 858  wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr wrapTypeUnbranchedFamInstBody axiom = wrapTypeFamInstBody axiom 0  Simon Peyton Jones committed Jan 03, 2012 859   simonpj@microsoft.com committed Apr 22, 2007 860 861 862 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut tycon args scrut | Just co_con <- tyConFamilyCoercion_maybe tycon  eir@cis.upenn.edu committed Aug 02, 2013 863  = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only  simonpj@microsoft.com committed Apr 22, 2007 864 865  | otherwise = scrut  Simon Peyton Jones committed Jan 03, 2012 866   eir@cis.upenn.edu committed Dec 21, 2012 867 868 unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr unwrapTypeFamInstScrut axiom ind args scrut  eir@cis.upenn.edu committed Aug 02, 2013 869  = mkCast scrut (mkAxInstCo Representational axiom ind args)  eir@cis.upenn.edu committed Dec 21, 2012 870 871 872 873  unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr unwrapTypeUnbranchedFamInstScrut axiom = unwrapTypeFamInstScrut axiom 0  simonpj committed Mar 19, 1998 874 875 876 877 \end{code} %************************************************************************  Ian Lynagh committed Feb 19, 2008 878 %* *  batterseapower committed Jul 31, 2008 879 \subsection{Primitive operations}  Ian Lynagh committed Feb 19, 2008 880 %* *  simonpj committed Mar 19, 1998 881 882 883 %************************************************************************ \begin{code}  simonpj committed Mar 23, 2000 884 885 mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op  simonm committed Dec 02, 1998 886  = id  simonpj committed Mar 19, 1998 887  where  simonmar committed Dec 10, 2001 888  (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op  simonpj committed May 18, 1999 889  ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)  simonpj committed Oct 09, 2003 890  name = mkWiredInName gHC_PRIM (primOpOcc prim_op)  Ian Lynagh committed Feb 19, 2008 891 892  (mkPrimOpIdUnique (primOpTag prim_op)) (AnId id) UserSyntax  simonpj committed Mar 08, 2001 893  id = mkGlobalId (PrimOpId prim_op) name ty info  Ian Lynagh committed Feb 19, 2008 894   simonpj committed Jun 14, 2002 895  info = noCafIdInfo  Simon Peyton Jones committed Jan 17, 2013 896 897 898 899  setSpecInfo mkSpecInfo (maybeToList$ primOpRules name prim_op) setArityInfo arity setStrictnessInfo strict_sig setInlinePragInfo neverInlinePragma  Simon Peyton Jones committed Oct 02, 2012 900 901 902 903  -- We give PrimOps a NOINLINE pragma so that we don't -- get silly warnings from Desugar.dsRule (the inline_shadows_rule -- test) about a RULE conflicting with a possible inlining -- cf Trac #7287  simonpj committed Nov 01, 1999 904   simonpj committed Mar 23, 2000 905 906 907 908 909 910 911 912 913 -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, -- and a CCall structure that gives the correct details about calling -- convention etc. -- -- The *name* of this Id is a local name whose OccName gives the full -- details of the ccall, type and all. This means that the interface -- file reader can reconstruct a suitable Id  Ian Lynagh committed Jun 12, 2012 914 915 mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id mkFCallId dflags uniq fcall ty  simonpj committed Mar 23, 2000 916  = ASSERT( isEmptyVarSet (tyVarsOfType ty) )  Ian Lynagh committed Feb 19, 2008 917 918  -- A CCallOpId should have no free type variables; -- when doing substitutions won't substitute over it  simonpj committed Sep 07, 2001 919  mkGlobalId (FCallId fcall) name ty info  simonpj committed Mar 23, 2000 920  where  Ian Lynagh committed Jun 12, 2012 921  occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))  Ian Lynagh committed Feb 19, 2008 922 923  -- The "occurrence name" of a ccall is the full info about the -- ccall; it is encoded, but may have embedded spaces etc!  simonpj committed Jan 04, 2000 924   simonpj committed May 22, 2001 925  name = mkFCallName uniq occ_str  simonpj committed Mar 19, 1998 926   simonpj committed Jun 14, 2002 927  info = noCafIdInfo  Ian Lynagh committed Feb 19, 2008 928  setArityInfo arity  Simon Peyton Jones committed Jan 17, 2013 929  setStrictnessInfo strict_sig  simonpj committed Mar 23, 2000 930   Simon Peyton Jones committed Jan 17, 2013 931 932 933 934  (_, tau) = tcSplitForAllTys ty (arg_tys, _) = tcSplitFunTys tau arity = length arg_tys strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) topRes)  simonm committed Dec 02, 1998 935 936 \end{code}  simonpj committed Mar 19, 1998 937 938  %************************************************************************  Ian Lynagh committed Feb 19, 2008 939 %* *  simonpj committed Mar 08, 2001 940 \subsection{DictFuns and default methods}  Ian Lynagh committed Feb 19, 2008 941 %* *  simonpj committed Mar 19, 1998 942 943 %************************************************************************  simonpj committed Sep 07, 2001 944 945 946 947 948 949 Important notes about dict funs and default methods ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Dict funs and default methods are *not* ImplicitIds. Their definition involves user-written code, so we can't figure out their strictness etc based on fixed info, as we can for constructors and record selectors (say).  simonpj committed Apr 28, 2005 950 951 952 We build them as LocalIds, but with External Names. This ensures that they are taken to account by free-variable finding and dependency analysis (e.g. CoreFVs.exprFreeVars).  simonpj committed Sep 07, 2001 953 954 955 956 957 958 959 960 961 962 963 964  Why shouldn't they be bound as GlobalIds? Because, in particular, if they are globals, the specialiser floats dict uses above their defns, which prevents good simplifications happening. Also the strictness analyser treats a occurrence of a GlobalId as imported and assumes it contains strictness in its IdInfo, which isn't true if the thing is bound in the same module as the occurrence. It's OK for dfuns to be LocalIds, because we form the instance-env to pass on to the next module (md_insts) in CoreTidy, afer tidying and globalising the top-level Ids.  simonpj committed Dec 24, 2004 965 BUT make sure they are *exported* LocalIds (mkExportedLocalId) so  simonpj committed Sep 07, 2001 966 967 that they aren't discarded by the occurrence analyser.  simonpj committed Mar 19, 1998 968 \begin{code}  Ian Lynagh committed Feb 19, 2008 969 970 971 972 973 974 mkDictFunId :: Name -- Name to use for the dict fun; -> [TyVar] -> ThetaType -> Class -> [Type] -> Id  simonpj@microsoft.com committed Dec 13, 2010 975 -- Implements the DFun Superclass Invariant (see TcInstDcls)  simonm committed Dec 02, 1998 976   simonpj@microsoft.com committed Dec 13, 2010 977 mkDictFunId dfun_name tvs theta clas tys  Simon Peyton Jones committed Jun 27, 2012 978  = mkExportedLocalVar (DFunId n_silent is_nt)  simonpj@microsoft.com committed Dec 13, 2010 979 980 981  dfun_name dfun_ty vanillaIdInfo  simonm committed Dec 02, 1998 982  where  simonpj@microsoft.com committed Oct 29, 2009 983  is_nt = isNewTyCon (classTyCon clas)  Simon Peyton Jones committed Jun 27, 2012 984  (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys  simonpj@microsoft.com committed Dec 13, 2010 985   Simon Peyton Jones committed Jun 27, 2012 986 mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)  simonpj@microsoft.com committed Dec 13, 2010 987 mkDictFunTy tvs theta clas tys  Simon Peyton Jones committed Jun 27, 2012 988 989 990 991 992 993 994 995 996 997 998 999 1000  = (length silent_theta, dfun_ty) where dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys) silent_theta | null tvs, null theta = [] | otherwise = filterOut discard \$ substTheta (zipTopTvSubst (classTyVars clas) tys) (classSCTheta clas) -- See Note [Silent Superclass Arguments] discard pred = any (eqPred pred) theta -- See the DFun Superclass Invariant in TcInstDcls  simonpj committed Mar 19, 1998 1001 \end{code}  simonpj committed May 18, 1999 1002 1003 1004  %************************************************************************  Ian Lynagh committed Feb 19, 2008 1005 %* *  simonpj committed May 18, 1999 1006 \subsection{Un-definable}  Ian Lynagh committed Feb 19, 2008 1007 %* *  simonpj committed May 18, 1999 1008 1009 %************************************************************************  simonmar committed Mar 18, 2002 1010 1011 1012 1013 1014 1015 These Ids can't be defined in Haskell. They could be defined in unfoldings in the wired-in GHC.Prim interface file, but we'd have to ensure that they were definitely, definitely inlined, because there is no curried identifier for them. That's what mkCompulsoryUnfolding does. If we had a way to get a compulsory unfolding from an interface file, we could do that, but we don't right now.  simonpj committed May 18, 1999 1016 1017 1018 1019 1020 1021 1022 1023 1024  unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that just gets expanded into a type coercion wherever it occurs. Hence we add it as a built-in Id with an unfolding here. The type variables we use here are "open" type variables: this means they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot.  simonpj committed Oct 09, 2003 1025 \begin{code}  Iavor S. Diatchki committed May 30, 2013 1026 lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName, magicSingIName :: Name  1027 1028 1029 1030 unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId  1031 lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId  1032 coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId  Iavor S. Diatchki committed May 30, 2013 1033 magicSingIName = mkWiredInIdName gHC_PRIM (fsLit "magicSingI") magicSingIKey magicSingIId  simonpj committed Oct 09, 2003 1034 1035 \end{code}  simonpj committed May 18, 1999 1036 \begin{code}  simonpj@microsoft.com committed May 16, 2008 1037 ------------------------------------------------  simonpj committed Oct 15, 2001 1038 -- unsafeCoerce# :: forall a b. a -> b  simonpj@microsoft.com committed Jul 07, 2010 1039 unsafeCoerceId :: Id  simonpj committed May 18, 1999 1040 unsafeCoerceId  simonpj committed Sep 13, 2002 1041  = pcMiscPrelId unsafeCoerceName ty info  simonpj committed May 18, 1999 1042  where  simonpj@microsoft.com committed Dec 21, 2010 1043 1044  info = noCafIdInfo setInlinePragInfo alwaysInlinePragma setUnfoldingInfo mkCompulsoryUnfolding rhs  Ian Lynagh committed Feb 19, 2008 1045   simonpj committed May 18, 1999 1046