X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsUtils.lhs;h=071953f20112fc5b8aa545b452230bf4113f47ff;hb=1375f908c01f6373e257832fb24c641d2e23700b;hp=f63b8842d69f5b5de5836e48f15c7fe7abb8cd0c;hpb=591c501950c7d6f884bb4531f66b666bab5b4928;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index f63b884..071953f 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -27,6 +27,7 @@ module DsUtils ( mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr, mkIntExpr, mkCharExpr, mkStringExpr, mkStringExprFS, mkIntegerExpr, + mkBuildExpr, mkFoldrExpr, seqVar, @@ -116,7 +117,7 @@ lookupEvidence :: [(Name, Id)] -> Name -> Id 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} @@ -162,14 +163,18 @@ mkDsApps fun args (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 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] + _ -> 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 @@ -177,8 +182,8 @@ mk_val_app fun arg arg_ty res_ty -- 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 @@ -193,9 +198,49 @@ But that is bad for two reasons: 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. Perhaps 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. + +Note [Desugaring seq (3)] cf Trac #2409 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The isLocalId ensures that we don't turn + True `seq` e +into + case True of True { ... } +which stupidly tries to bind the datacon 'True'. %************************************************************************ @@ -311,10 +356,10 @@ wrapBinds [] e = e wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body +wrapBind new old body -- Can deal with term variables *or* type variables | new==old = body - | isTyVar new = App (Lam new body) (Type (mkTyVarTy old)) - | otherwise = Let (NonRec new (Var old)) body + | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body + | otherwise = Let (NonRec new (Var old)) body seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = Case (Var var) var (exprType body) @@ -496,15 +541,15 @@ mkErrorAppDs err_id ty msg = do \end{code} -************************************************************* +%************************************************************************ %* * \subsection{Making literals} %* * %************************************************************************ \begin{code} -mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int -mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int +mkCharExpr :: Char -> CoreExpr -- Returns @C# c :: Int@ +mkIntExpr :: Integer -> CoreExpr -- Returns @I# i :: Int@ mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer mkStringExpr :: String -> DsM CoreExpr -- Result :: String mkStringExprFS :: FastString -> DsM CoreExpr -- Result :: String @@ -514,8 +559,8 @@ mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)] 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 @@ -524,9 +569,9 @@ mkIntegerExpr i | 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 @@ -542,8 +587,8 @@ mkIntegerExpr i 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) @@ -761,17 +806,18 @@ mkLHsVarTup ids = mkLHsTup (map nlHsVar ids) mkLHsTup :: [LHsExpr Id] -> LHsExpr Id mkLHsTup [] = nlHsVar unitDataConId mkLHsTup [lexp] = lexp -mkLHsTup lexps = noLoc $ ExplicitTuple lexps Boxed - +mkLHsTup lexps = L (getLoc (head lexps)) $ + 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 [] = noLoc $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = noLoc $ mkVanillaTuplePat lpats Boxed -- Handles the case where lpats = [] gracefully - +mkLHsPatTup lpats = L (getLoc (head lpats)) $ + mkVanillaTuplePat lpats Boxed -- The Big equivalents for the source tuple expressions mkBigLHsVarTup :: [Id] -> LHsExpr Id @@ -787,7 +833,6 @@ mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) mkBigLHsPatTup :: [LPat Id] -> LPat Id mkBigLHsPatTup = mkBigTuple mkLHsPatTup - \end{code} @@ -871,7 +916,7 @@ mkTupleCase uniqs vars body scrut_var scrut 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') @@ -913,6 +958,27 @@ mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl] 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 @@ -1037,7 +1103,7 @@ mkTickBox ix vars e = do 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