import Util
import ListSetOps
import FastString
-import Data.Char
-import DynFlags
+import StaticFlags
-#ifdef DEBUG
-import Util
-#endif
+import Data.Char
infixl 4 `mkDsApp`, `mkDsApps`
\end{code}
\begin{code}
mkDsLet :: CoreBind -> CoreExpr -> CoreExpr
-mkDsLet (NonRec bndr rhs) body
+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
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
- | 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
+ = 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.
+
%************************************************************************
%* *
mkTickBox ix 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 var = Id.mkLocalId name realWorldStatePrimTy
- return $ Case (Var tick)
- var
- ty
- [(DEFAULT,[],e)]
+ scrut <-
+ if opt_Hpc
+ then return (Var tick)
+ else do
+ locals <- getLocalBindsDs
+ let tickVar = Var tick
+ let tickType = mkFunTys (map idType locals) realWorldStatePrimTy
+ let scrutApTy = App tickVar (Type tickType)
+ return (mkApps scrutApTy (map Var locals) :: Expr Id)
+ return $ Case scrut var ty [(DEFAULT,[],e)]
where
ty = exprType e
[ (DataAlt falseDataCon, [], falseBox)
, (DataAlt trueDataCon, [], trueBox)
]
-\end{code}
\ No newline at end of file
+\end{code}