X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=3a976878e3ead7625a96703c5621a5ae8bec3f0a;hp=d932ab1fdbad0b310ca0d1816990220116d3e09d;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=90ce88a0a9b5611416e592a6ff96781ba884975f diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index d932ab1..3a97687 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, @@ -144,12 +144,49 @@ selectMatchVar :: Pat Id -> DsM Id 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. + %************************************************************************ %* * @@ -221,7 +258,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 @@ -346,7 +383,7 @@ mkCoAlgCaseMatchResult var ty match_alts 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 @@ -358,7 +395,7 @@ mkCoAlgCaseMatchResult var ty match_alts -- 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 @@ -419,7 +456,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 +484,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 +512,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,14 +587,14 @@ 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 - = (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 @@ -583,37 +624,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 +715,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