EquationInfo(..),
firstPat, shiftEqns,
- mkDsLet, mkDsLets,
+ mkDsLet, mkDsLets, mkDsApp, mkDsApps,
MatchResult(..), CanItFail(..),
cantFailMatchResult, alwaysFailMatchResult,
import ListSetOps
import FastString
import Data.Char
+import DynFlags
#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)
+ | 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
+ | isUnLiftedType arg_ty && not (exprOkForSpeculation arg)
+ = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
+ | otherwise -- The common case
+ = App fun arg
+ 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}
[(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
-
%************************************************************************
%* *
\subsection[mkFailurePair]{Code for pattern-matching and other failures}
mkTickBox :: Int -> CoreExpr -> DsM CoreExpr
mkTickBox ix e = do
+ uq <- newUnique
mod <- getModuleDs
- return $ Note (TickBox mod ix) e
+ let tick = mkTickBoxOpId uq mod ix
+ uq2 <- newUnique
+ let occName = mkVarOcc "tick"
+ let name = mkInternalName uq2 occName noSrcLoc -- use mkSysLocal?
+ let var = Id.mkLocalId name realWorldStatePrimTy
+ return $ Case (Var tick)
+ 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
+ uq <- newUnique
+ mod <- getModuleDs
+ 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}
\ No newline at end of file