X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=9d787add263e25e9e29d67c6391bdeb66e244b5f;hp=6bc70e2b8f56932cbe3ab2d2d3e83277ce65e896;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=8100cd4395e46ae747be4298c181a4730d6206bc diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 6bc70e2..9d787ad 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -8,17 +8,24 @@ Utilities for desugaring This module exports some utility functions of no great interest. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module DsUtils ( EquationInfo(..), firstPat, shiftEqns, - mkDsLet, mkDsLets, + mkDsLet, mkDsLets, mkDsApp, mkDsApps, MatchResult(..), CanItFail(..), cantFailMatchResult, alwaysFailMatchResult, extractMatchResult, combineMatchResults, adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkGuardedMatchResult, + mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, matchCanFail, mkEvalMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, wrapBind, wrapBinds, @@ -69,12 +76,11 @@ import SrcLoc import Util import ListSetOps import FastString +import StaticFlags + import Data.Char -import DynFlags -#ifdef DEBUG -import Util -#endif +infixl 4 `mkDsApp`, `mkDsApps` \end{code} @@ -121,16 +127,71 @@ back again. \begin{code} mkDsLet :: CoreBind -> CoreExpr -> CoreExpr -mkDsLet (NonRec bndr rhs) body - | isUnLiftedType (idType bndr) +mkDsLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] + | isUnLiftedType (idType bndr) && not (exprOkForSpeculation rhs) = Case rhs bndr (exprType body) [(DEFAULT,[],body)] mkDsLet bind body = Let bind body mkDsLets :: [CoreBind] -> CoreExpr -> CoreExpr mkDsLets binds body = foldr mkDsLet body binds + +----------- +mkDsApp :: CoreExpr -> CoreExpr -> CoreExpr +-- Check the invariant that the arg of an App is ok-for-speculation if unlifted +-- See CoreSyn Note [CoreSyn let/app invariant] +mkDsApp fun (Type ty) = App fun (Type ty) +mkDsApp fun arg = mk_val_app fun arg arg_ty res_ty + where + (arg_ty, res_ty) = splitFunTy (exprType fun) + +----------- +mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr +-- Slightly more efficient version of (foldl mkDsApp) +mkDsApps fun args + = go fun (exprType fun) args + where + go fun fun_ty [] = fun + go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args + go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args + where + (arg_ty, res_ty) = splitFunTy fun_ty +----------- +mk_val_app fun arg arg_ty res_ty -- See Note [CoreSyn let/app invariant] + | not (isUnLiftedType arg_ty) || exprOkForSpeculation arg + = App fun arg -- The vastly common case + +mk_val_app (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 _ res_ty + | f == seqId -- Note [Desugaring seq] + = Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)] + +mk_val_app fun arg arg_ty res_ty + = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))] + where + arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id \end{code} +Note [Desugaring seq] cf Trac #1031 +~~~~~~~~~~~~~~~~~~~~~ + f x y = x `seq` (y `seq` (# x,y #)) + +The [CoreSyn let/app invariant] means that, other things being equal, because +the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + +But that is bad for two reasons: + (a) we now evaluate y before x, and + (b) we can't bind v to an unboxed pair + +Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + +The special case would be valid for all calls to 'seq', but it's only *necessary* +for ones whose second argument has an unlifted type. So we only catch the latter +case here, to avoid unnecessary tests. + %************************************************************************ %* * @@ -188,7 +249,7 @@ worthy of a type synonym and a few handy functions. \begin{code} firstPat :: EquationInfo -> Pat Id -firstPat eqn = head (eqn_pats eqn) +firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn) shiftEqns :: [EquationInfo] -> [EquationInfo] -- Drop the first pattern in each equation @@ -258,6 +319,12 @@ seqVar var body = Case (Var var) var (exprType body) mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult mkCoLetMatchResult bind = adjustMatchResult (mkDsLet bind) +-- (mkViewMatchResult var' viewExpr var mr) makes the expression +-- let var' = viewExpr var in mr +mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult +mkViewMatchResult var' viewExpr var = + adjustMatchResult (mkDsLet (NonRec var' (mkDsApp viewExpr (Var var)))) + mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult mkEvalMatchResult var ty = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)]) @@ -303,8 +370,8 @@ mkCoAlgCaseMatchResult var ty match_alts -- the scrutinised Id to be sufficiently refined to have a TyCon in it] -- Stuff for newtype - (con1, arg_ids1, match_result1) = head match_alts - arg_id1 = head arg_ids1 + (con1, arg_ids1, match_result1) = ASSERT( notNull match_alts ) head match_alts + arg_id1 = ASSERT( notNull arg_ids1 ) head arg_ids1 var_ty = idType var (tc, ty_args) = splitNewTyConApp var_ty newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) @@ -593,7 +660,7 @@ mkSelectorBinds pat val_expr is_simple_lpat p = is_simple_pat (unLoc p) is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps - is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConArgs ps) + is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps) is_simple_pat (VarPat _) = True is_simple_pat (ParPat p) = is_simple_lpat p is_simple_pat other = False @@ -807,7 +874,6 @@ mkCoreSel vars the_var scrut_var scrut [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} - %************************************************************************ %* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} @@ -883,33 +949,42 @@ mkFailurePair expr \end{code} \begin{code} -mkOptTickBox :: Maybe Int -> CoreExpr -> DsM CoreExpr +mkOptTickBox :: Maybe (Int,[Id]) -> CoreExpr -> DsM CoreExpr mkOptTickBox Nothing e = return e -mkOptTickBox (Just ix) e = mkTickBox ix e +mkOptTickBox (Just (ix,ids)) e = mkTickBox ix ids e -mkTickBox :: Int -> CoreExpr -> DsM CoreExpr -mkTickBox ix e = do - dflags <- getDOptsDs +mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr +mkTickBox ix vars e = do uq <- newUnique mod <- getModuleDs - let tick = mkTickBoxOpId uq mod ix + let tick | opt_Hpc = mkTickBoxOpId uq mod ix + | otherwise = mkBreakPointOpId uq mod ix uq2 <- newUnique let occName = mkVarOcc "tick" - let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal? + let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal? let var = Id.mkLocalId name realWorldStatePrimTy - return $ Case (Var tick) - var - ty - [(DEFAULT,[],e)] + scrut <- + if opt_Hpc + then return (Var tick) + else do + let tickVar = Var tick + let tickType = mkFunTys (map idType vars) realWorldStatePrimTy + let scrutApTy = App tickVar (Type tickType) + return (mkApps scrutApTy (map Var vars) :: Expr Id) + return $ Case scrut var ty [(DEFAULT,[],e)] where ty = exprType e mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do mod <- getModuleDs - dflags <- getDOptsDs uq <- newUnique mod <- getModuleDs - let tick = mkBinaryTickBoxOpId uq mod ixT ixF - return $ App (Var tick) e -\end{code} \ No newline at end of file + let bndr1 = mkSysLocal FSLIT("t1") uq boolTy + falseBox <- mkTickBox ixF [] $ Var falseDataConId + trueBox <- mkTickBox ixT [] $ Var trueDataConId + return $ Case e bndr1 boolTy + [ (DataAlt falseDataCon, [], falseBox) + , (DataAlt trueDataCon, [], trueBox) + ] +\end{code}