This module exports some utility functions of no great interest.
\begin{code}
+
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,
mkIntExpr, mkCharExpr,
mkStringExpr, mkStringExprFS, mkIntegerExpr,
- mkSelectorBinds, mkTupleExpr, mkTupleSelector,
- mkTupleType, mkTupleCase, mkBigCoreTup,
- mkCoreTup, mkCoreTupTy, seqVar,
+ seqVar,
+
+ -- Core tuples
+ mkCoreVarTup, mkCoreTup, mkCoreVarTupTy, mkCoreTupTy,
+ mkBigCoreVarTup, mkBigCoreTup, mkBigCoreVarTupTy, mkBigCoreTupTy,
+
+ -- LHs tuples
+ mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
+ mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
+
+ -- Tuple bindings
+ mkSelectorBinds, mkTupleSelector,
+ mkSmallTupleCase, mkTupleCase,
dsSyntaxTable, lookupEvidence,
import Util
import ListSetOps
import FastString
+import StaticFlags
+
import Data.Char
-#ifdef DEBUG
-import Util
-#endif
+infixl 4 `mkDsApp`, `mkDsApps`
\end{code}
\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
+ 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 :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
+mk_val_app fun arg arg_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 _ `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.
+
%************************************************************************
%* *
selectMatchVars :: [Pat Id] -> DsM [Id]
selectMatchVars ps = mapM selectMatchVar ps
+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 (AsPat var pat) = return (unLoc var)
+selectMatchVar (AsPat var _) = return (unLoc var)
selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
-- OK, better make up one...
\end{code}
\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
alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
cantFailMatchResult :: CoreExpr -> MatchResult
-cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
+cantFailMatchResult expr = MatchResult CantFail (\_ -> returnDs expr)
extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
-extractMatchResult (MatchResult CantFail match_fn) fail_expr
+extractMatchResult (MatchResult CantFail match_fn) _
= match_fn (error "It can't fail!")
extractMatchResult (MatchResult CanFail match_fn) fail_expr
body_fn1 duplicatable_expr `thenDs` \ body1 ->
returnDs (Let fail_bind body1)
-combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
+combineMatchResults match_result1@(MatchResult CantFail _) _
= match_result1
adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
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)])
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
-mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
+mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
= MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
returnDs (mkIfThenElse pred_expr body fail))
-- 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)
case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
(True , True ) -> True
(False, False) -> False
- _ ->
- panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
+ _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
+ isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
--
mk_parrCase fail =
dsLookupGlobalId lengthPName `thenDs` \lengthP ->
in
returnDs (horner tARGET_MAX_INT i)
+mkSmallIntegerLit :: DataCon -> Integer -> CoreExpr
mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
mkStringExpr str = mkStringExprFS (mkFastString str)
returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
where
binders = collectPatBinders pat
- local_tuple = mkTupleExpr binders
+ local_tuple = mkBigCoreVarTup binders
tuple_ty = exprType local_tuple
mk_bind scrut_var err_var bndr_var
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
+ is_simple_pat (ParPat p) = is_simple_lpat p
+ is_simple_pat _ = False
is_triv_lpat p = is_triv_pat (unLoc p)
- is_triv_pat (VarPat v) = True
+ is_triv_pat (VarPat _) = True
is_triv_pat (WildPat _) = True
is_triv_pat (ParPat p) = is_triv_lpat p
- is_triv_pat other = False
+ is_triv_pat _ = False
\end{code}
%************************************************************************
%* *
- Tuples
+ Big Tuples
%* *
%************************************************************************
-@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
-
-* If it has only one element, it is the identity function.
-
-* If there are more elements than a big tuple can have, it nests
- the tuples.
-
Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
\begin{code}
-mkTupleExpr :: [Id] -> CoreExpr
-mkTupleExpr ids = mkBigCoreTup (map Var ids)
-
--- corresponding type
-mkTupleType :: [Id] -> Type
-mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
-
-mkBigCoreTup :: [CoreExpr] -> CoreExpr
-mkBigCoreTup = mkBigTuple mkCoreTup
mkBigTuple :: ([a] -> a) -> [a] -> a
mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
-- But there may be more than mAX_TUPLE_SIZE sub-lists
chunkify xs
| n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
- | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
+ | otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
where
n_xs = length xs
split [] = []
split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
+
+\end{code}
+
+Creating tuples and their types for Core expressions
+
+@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
+
+* If it has only one element, it is the identity function.
+
+* If there are more elements than a big tuple can have, it nests
+ the tuples.
+
+\begin{code}
+
+-- Small tuples: build exactly the specified tuple
+mkCoreVarTup :: [Id] -> CoreExpr
+mkCoreVarTup ids = mkCoreTup (map Var ids)
+
+mkCoreVarTupTy :: [Id] -> Type
+mkCoreVarTupTy ids = mkCoreTupTy (map idType ids)
+
+
+mkCoreTup :: [CoreExpr] -> CoreExpr
+mkCoreTup [] = Var unitDataConId
+mkCoreTup [c] = c
+mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
+ (map (Type . exprType) cs ++ cs)
+
+mkCoreTupTy :: [Type] -> Type
+mkCoreTupTy [ty] = ty
+mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
+
+
+
+-- Big tuples
+mkBigCoreVarTup :: [Id] -> CoreExpr
+mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
+
+mkBigCoreVarTupTy :: [Id] -> Type
+mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
+
+
+mkBigCoreTup :: [CoreExpr] -> CoreExpr
+mkBigCoreTup = mkBigTuple mkCoreTup
+
+mkBigCoreTupTy :: [Type] -> Type
+mkBigCoreTupTy = mkBigTuple mkCoreTupTy
+
+\end{code}
+
+Creating tuples and their types for full Haskell expressions
+
+\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 = noLoc $ 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 [lpat] = lpat
+mkLHsPatTup lpats = noLoc $ mkVanillaTuplePat lpats Boxed -- Handles the case where lpats = [] gracefully
+
+
+-- The Big equivalents for the source tuple expressions
+mkBigLHsVarTup :: [Id] -> LHsExpr Id
+mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
+
+mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
+mkBigLHsTup = mkBigTuple mkLHsTup
+
+
+-- The Big equivalents for the source tuple patterns
+mkBigLHsVarPatTup :: [Id] -> LPat Id
+mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
+
+mkBigLHsPatTup :: [LPat Id] -> LPat Id
+mkBigLHsPatTup = mkBigTuple mkLHsPatTup
+
\end{code}
mkTupleCase uniqs vars body scrut_var scrut
= mk_tuple_case uniqs (chunkify vars) body
where
- mk_tuple_case us [vars] body
+ -- This is the case where don't need any nesting
+ mk_tuple_case _ [vars] body
= mkSmallTupleCase vars body scrut_var scrut
+
+ -- This is the case where we must make nest tuples at least once
mk_tuple_case us vars_s body
- = let
- (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
- in
- mk_tuple_case us' (chunkify vars') body'
+ = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
+ in mk_tuple_case us' (chunkify vars') body'
+
one_tuple_case chunk_vars (us, vs, body)
- = let
- (us1, us2) = splitUniqSupply us
- scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
- (mkCoreTupTy (map idType chunk_vars))
- body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
- in (us2, scrut_var:vs, body')
+ = let (us1, us2) = splitUniqSupply us
+ scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
+ (mkCoreTupTy (map idType chunk_vars))
+ body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
+ in (us2, scrut_var:vs, body')
\end{code}
The same, but with a tuple small enough not to need nesting.
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
-
-
--- The next three functions make tuple types, constructors and selectors,
--- with the rule that a 1-tuple is represented by the thing itselg
-mkCoreTupTy :: [Type] -> Type
-mkCoreTupTy [ty] = ty
-mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
-
-mkCoreTup :: [CoreExpr] -> CoreExpr
--- Builds exactly the specified tuple.
--- No fancy business for big tuples
-mkCoreTup [] = Var unitDataConId
-mkCoreTup [c] = c
-mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
- (map (Type . exprType) cs ++ cs)
mkCoreSel :: [Id] -- The tuple args
- -> Id -- The selected one
- -> Id -- A variable of the same type as the scrutinee
+ -> Id -- The selected one
+ -> Id -- A variable of the same type as the scrutinee
-> CoreExpr -- Scrutinee
-> CoreExpr
--- mkCoreSel [x,y,z] x v e
--- ===> case e of v { (x,y,z) -> x
-mkCoreSel [var] should_be_the_same_var scrut_var scrut
+
+-- mkCoreSel [x] x v e
+-- ===> e
+mkCoreSel [var] should_be_the_same_var _ scrut
= ASSERT(var == should_be_the_same_var)
scrut
+-- mkCoreSel [x,y,z] x v e
+-- ===> case e of v { (x,y,z) -> x
mkCoreSel vars the_var scrut_var scrut
= ASSERT( notNull vars )
Case scrut scrut_var (idType the_var)
[(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
-
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
\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
+mkTickBox :: Int -> [Id] -> CoreExpr -> DsM CoreExpr
+mkTickBox ix vars e = do
+ uq <- newUnique
mod <- getModuleDs
- return $ Note (TickBox mod ix) e
+ let tick | opt_Hpc = mkTickBoxOpId uq mod ix
+ | otherwise = mkBreakPointOpId uq mod ix
+ uq2 <- newUnique
+ let occName = mkVarOcc "tick"
+ let name = mkInternalName uq2 occName noSrcSpan -- use mkSysLocal?
+ let var = Id.mkLocalId name realWorldStatePrimTy
+ 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
- return $ Note (BinaryTickBox mod ixT ixF) e
-\end{code}
\ No newline at end of file
+ uq <- newUnique
+ 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}
projects / ghc-hetmet.git / blobdiff