X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=4c05f5ea5c641d551c22d17b1a42965c4b72983b;hp=d932ab1fdbad0b310ca0d1816990220116d3e09d;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=90ce88a0a9b5611416e592a6ff96781ba884975f diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index d932ab1..4c05f5e 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -27,7 +27,7 @@ module DsUtils ( seqVar, -- LHs tuples - mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup, + mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, mkSelectorBinds, @@ -221,7 +221,7 @@ 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 + | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body | otherwise = Let (NonRec new (Var old)) body seqVar :: Var -> CoreExpr -> CoreExpr @@ -419,7 +419,7 @@ But that is bad for two reasons: 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 } @@ -447,10 +447,14 @@ should have said explicitly 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. @@ -471,7 +475,7 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 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 @@ -546,8 +550,7 @@ mkSelectorBinds pat val_expr 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 + let mk_tup_bind binder = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var)) return ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) where @@ -583,37 +586,31 @@ mkSelectorBinds pat val_expr \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 @@ -680,23 +677,36 @@ Now @fail.33@ is a function, so it can be let-bound. \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