mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr,
mkIntExpr, mkCharExpr,
mkStringExpr, mkStringExprFS, mkIntegerExpr,
+ mkBuildExpr, mkFoldrExpr,
seqVar,
lookupEvidence prs std_name
= assocDefault (mk_panic std_name) prs std_name
where
- mk_panic std_name = pprPanic "dsSyntaxTable" (ptext SLIT("Not found:") <+> ppr std_name)
+ mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name)
\end{code}
(arg_ty, res_ty) = splitFunTy fun_ty
-----------
mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
+mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty
+ | f == seqId -- Note [Desugaring seq (1), (2)]
+ = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)]
+ where
+ case_bndr = case arg1 of
+ Var v1 -> v1 -- Note [Desugaring seq (2)]
+ _ -> mkWildId ty1
+
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
-- because 'fun ' should not have a free wild-id
\end{code}
-Note [Desugaring seq] cf Trac #1031
-~~~~~~~~~~~~~~~~~~~~~
+Note [Desugaring seq (1)] cf Trac #1031
+~~~~~~~~~~~~~~~~~~~~~~~~~
f x y = x `seq` (y `seq` (# x,y #))
The [CoreSyn let/app invariant] means that, other things being equal, because
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.
-
+Note [Desugaring seq (2)] cf Trac #2231
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ let chp = case b of { True -> fst x; False -> 0 }
+ in chp `seq` ...chp...
+Here the seq is designed to plug the space leak of retaining (snd x)
+for too long.
+
+If we rely on the ordinary inlining of seq, we'll get
+ let chp = case b of { True -> fst x; False -> 0 }
+ case chp of _ { I# -> ...chp... }
+
+But since chp is cheap, and the case is an alluring contet, we'll
+inline chp into the case scrutinee. Now there is only one use of chp,
+so we'll inline a second copy. Alas, we've now ruined the purpose of
+the seq, by re-introducing the space leak:
+ case (case b of {True -> fst x; False -> 0}) of
+ I# _ -> ...case b of {True -> fst x; False -> 0}...
+
+We can try to avoid doing this by ensuring that the binder-swap in the
+case happens, so we get his at an early stage:
+ case chp of chp2 { I# -> ...chp2... }
+But this is fragile. The real culprit is the source program. Perhpas we
+should have said explicitly
+ let !chp2 = chp in ...chp2...
+
+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:
+ 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.
+
+The reason it's a hack is because if you define mySeq=seq, the hack
+won't work on mySeq.
%************************************************************************
%* *
mkIntegerExpr i
| inIntRange i -- Small enough, so start from an Int
- = do integer_dc <- dsLookupDataCon smallIntegerDataConName
- return (mkSmallIntegerLit integer_dc i)
+ = do integer_id <- dsLookupGlobalId smallIntegerName
+ return (mkSmallIntegerLit integer_id i)
-- Special case for integral literals with a large magnitude:
-- They are transformed into an expression involving only smaller
| otherwise = do -- Big, so start from a string
plus_id <- dsLookupGlobalId plusIntegerName
times_id <- dsLookupGlobalId timesIntegerName
- integer_dc <- dsLookupDataCon smallIntegerDataConName
+ integer_id <- dsLookupGlobalId smallIntegerName
let
- lit i = mkSmallIntegerLit integer_dc i
+ lit i = mkSmallIntegerLit integer_id i
plus a b = Var plus_id `App` a `App` b
times a b = Var times_id `App` a `App` b
return (horner tARGET_MAX_INT i)
-mkSmallIntegerLit :: DataCon -> Integer -> CoreExpr
-mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
+mkSmallIntegerLit :: Id -> Integer -> CoreExpr
+mkSmallIntegerLit small_integer i = mkApps (Var small_integer) [mkIntLit i]
mkStringExpr str = mkStringExprFS (mkFastString str)
one_tuple_case chunk_vars (us, vs, body)
= let (us1, us2) = splitUniqSupply us
- scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
+ 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')
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
+mkFoldrExpr :: PostTcType -> PostTcType -> CoreExpr -> CoreExpr -> CoreExpr -> DsM CoreExpr
+mkFoldrExpr elt_ty result_ty c n list = do
+ foldr_id <- dsLookupGlobalId foldrName
+ return (Var foldr_id `App` Type elt_ty
+ `App` Type result_ty
+ `App` c
+ `App` n
+ `App` list)
+
+mkBuildExpr :: Type -> ((Id, Type) -> (Id, Type) -> DsM CoreExpr) -> DsM CoreExpr
+mkBuildExpr elt_ty mk_build_inside = do
+ [n_tyvar] <- newTyVarsDs [alphaTyVar]
+ let n_ty = mkTyVarTy n_tyvar
+ c_ty = mkFunTys [elt_ty, n_ty] n_ty
+ [c, n] <- newSysLocalsDs [c_ty, n_ty]
+
+ build_inside <- mk_build_inside (c, c_ty) (n, n_ty)
+
+ build_id <- dsLookupGlobalId buildName
+ return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside
+
mkCoreSel :: [Id] -- The tuple args
-> Id -- The selected one
-> Id -- A variable of the same type as the scrutinee
mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
mkBinaryTickBox ixT ixF e = do
uq <- newUnique
- let bndr1 = mkSysLocal FSLIT("t1") uq boolTy
+ let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
falseBox <- mkTickBox ixF [] $ Var falseDataConId
trueBox <- mkTickBox ixT [] $ Var trueDataConId
return $ Case e bndr1 boolTy