seqVar,
-- LHs tuples
- mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
+ mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
mkSelectorBinds,
import MkCore
import MkId
import Id
-import Var
import Name
import Literal
import TyCon
\end{code}
-
%************************************************************************
%* *
Rebindable syntax
selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var) = return var
+selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders]
selectMatchVar (AsPat var _) = return (unLoc var)
selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
-- OK, better make up one...
\end{code}
+Note [Localise pattern binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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
+of is tc003 compiled with the 'hpc' way -- but that only makes it
+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.
+
%************************************************************************
%* *
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body -- Can deal with term variables *or* type variables
- | new==old = body
- | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
- | otherwise = Let (NonRec new (Var old)) body
+wrapBind new old body -- NB: this function must deal with term
+ | new==old = body -- variables, type variables or coercion variables
+ | otherwise = Let (NonRec new (varToCoreExpr old)) body
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = Case (Var var) var (exprType body)
return (LitAlt lit, [], body)
-mkCoAlgCaseMatchResult :: Id -- Scrutinee
- -> Type -- Type of exp
- -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
- -> MatchResult
+mkCoAlgCaseMatchResult
+ :: Id -- Scrutinee
+ -> Type -- Type of exp
+ -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts)
+ -> MatchResult
mkCoAlgCaseMatchResult var ty match_alts
| isNewTyCon tycon -- Newtype case; use a let
= ASSERT( null (tail match_alts) && null (tail arg_ids1) )
isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
--
mk_parrCase fail = do
- lengthP <- dsLookupGlobalId lengthPName
+ lengthP <- dsLookupDPHId lengthPName
alt <- unboxAlt
return (mkWildCase (len lengthP) intTy ty [alt])
where
--
unboxAlt = do
l <- newSysLocalDs intPrimTy
- indexP <- dsLookupGlobalId indexPName
+ indexP <- dsLookupDPHId indexPName
alts <- mapM (mkAlt indexP) sorted_alts
return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
where
Seq is very, very special! So we recognise it right here, and desugar to
case x of _ -> case y of _ -> (# x,y #)
-Note [Desugaring seq (2)] cf Trac #2231
+Note [Desugaring seq (2)] cf Trac #2273
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
let chp = case b of { True -> fst x; False -> 0 }
But that's painful. So the code here does a little hack to make seq
more robust: a saturated application of 'seq' is turned *directly* into
-the case expression. So we desugar to:
+the case expression, thus:
+ x `seq` e2 ==> case x of x -> e2 -- Note shadowing!
+ e1 `seq` e2 ==> case x of _ -> e2
+
+So we desugar our example to:
let chp = case b of { True -> fst x; False -> 0 }
case chp of chp { I# -> ...chp... }
-Notice the shadowing of the case binder! And now all is well.
+And now all is well.
The reason it's a hack is because if you define mySeq=seq, the hack
won't work on mySeq.
where
case_bndr = case arg1 of
Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]
- _ -> mkWildBinder ty1
+ _ -> mkWildValBinder ty1
mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore
error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
tuple_var <- newSysLocalDs tuple_ty
- let
- mk_tup_bind binder
- = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
+ let mk_tup_bind binder
+ = (binder, mkTupleSelector local_binders binder tuple_var (Var tuple_var))
return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
where
- binders = collectPatBinders pat
- local_tuple = mkBigCoreVarTup binders
- tuple_ty = exprType local_tuple
+ binders = collectPatBinders pat
+ local_binders = map localiseId binders -- See Note [Localise pattern binders]
+ local_tuple = mkBigCoreVarTup binders
+ tuple_ty = exprType local_tuple
mk_bind scrut_var err_var bndr_var = do
-- (mk_bind sv err_var) generates
return (bndr_var, rhs_expr)
where
error_expr = mkCoerce co (Var err_var)
- co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
+ co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
is_simple_lpat p = is_simple_pat (unLoc p)
\end{code}
-Creating tuples and their types for full Haskell expressions
+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.
\begin{code}
-
--- Smart constructors for source tuple expressions
-mkLHsVarTup :: [Id] -> LHsExpr Id
-mkLHsVarTup ids = mkLHsTup (map nlHsVar ids)
-
-mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
-mkLHsTup [] = nlHsVar unitDataConId
-mkLHsTup [lexp] = lexp
-mkLHsTup lexps = L (getLoc (head lexps)) $
- ExplicitTuple lexps Boxed
-
--- Smart constructors for source tuple patterns
-mkLHsVarPatTup :: [Id] -> LPat Id
-mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
-
mkLHsPatTup :: [LPat Id] -> LPat Id
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $
mkVanillaTuplePat lpats Boxed
+mkLHsVarPatTup :: [Id] -> LPat Id
+mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
+
+mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
+-- A vanilla tuple pattern simply gets its type from its sub-patterns
+mkVanillaTuplePat pats box
+ = TuplePat pats box (mkTupleTy box (map hsLPatType pats))
+
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
-mkBigLHsTup = mkChunkified mkLHsTup
-
+mkBigLHsTup = mkChunkified mkLHsTupleExpr
-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [Id] -> LPat Id
\begin{code}
mkFailurePair :: CoreExpr -- Result type of the whole case expression
-> DsM (CoreBind, -- Binds the newly-created fail variable
- -- to either the expression or \ _ -> expression
- CoreExpr) -- Either the fail variable, or fail variable
- -- applied to unit tuple
+ -- to \ _ -> expression
+ CoreExpr) -- Fail variable applied to realWorld#
+-- See Note [Failure thunks and CPR]
mkFailurePair expr
- | isUnLiftedType ty = do
- fail_fun_var <- newFailLocalDs (unitTy `mkFunTy` ty)
- fail_fun_arg <- newSysLocalDs unitTy
- return (NonRec fail_fun_var (Lam fail_fun_arg expr),
- App (Var fail_fun_var) (Var unitDataConId))
-
- | otherwise = do
- fail_var <- newFailLocalDs ty
- return (NonRec fail_var expr, Var fail_var)
+ = do { fail_fun_var <- newFailLocalDs (realWorldStatePrimTy `mkFunTy` ty)
+ ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy
+ ; return (NonRec fail_fun_var (Lam fail_fun_arg expr),
+ App (Var fail_fun_var) (Var realWorldPrimId)) }
where
ty = exprType expr
\end{code}
+Note [Failure thunks and CPR]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we make a failure point we ensure that it
+does not look like a thunk. Example:
+
+ let fail = \rw -> error "urk"
+ in case x of
+ [] -> fail realWorld#
+ (y:ys) -> case ys of
+ [] -> fail realWorld#
+ (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.
+
\begin{code}
mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr
mkOptTickBox Nothing e = return e
projects / ghc-hetmet.git / blobdiff