X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWwLib.lhs;h=e7bd24f389069f575fe73596d75869fb44a0486d;hb=33770e2e376005ff14a1d16b89f32b0d474425e2;hp=ec8f6227deee1211ee2652fcb2d48250d8adf6af;hpb=bc4cb1faefbe99fea6f207dfa4d754c2cc2865c1;p=ghc-hetmet.git diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index ec8f622..e7bd24f 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser} +\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser} \begin{code} module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where @@ -23,11 +23,12 @@ import TysWiredIn ( tupleCon ) import Type import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe ) import BasicTypes ( Boxity(..) ) -import Var ( Var, isId ) +import Var ( Var, isIdVar ) import UniqSupply import Unique import Util ( zipWithEqual, notNull ) import Outputable +import FastString import List ( zipWith4 ) \end{code} @@ -43,7 +44,7 @@ Here's an example. The original function is: \begin{verbatim} g :: forall a . Int -> [a] -> a -g = /\ a -> \ x ys -> +g = \/\ a -> \ x ys -> case x of 0 -> head ys _ -> head (tail ys) @@ -54,7 +55,7 @@ From this, we want to produce: -- wrapper (an unfolding) g :: forall a . Int -> [a] -> a -g = /\ a -> \ x ys -> +g = \/\ a -> \ x ys -> case x of I# x# -> $wg a x# ys -- call the worker; don't forget the type args! @@ -62,7 +63,7 @@ g = /\ a -> \ x ys -> -- worker $wg :: forall a . Int# -> [a] -> a -$wg = /\ a -> \ x# ys -> +$wg = \/\ a -> \ x# ys -> let x = I# x# in @@ -97,7 +98,7 @@ the unusable strictness-info into the interfaces. %* * %************************************************************************ -@mkWwBodies@ is called when doing the worker/wrapper split inside a module. +@mkWwBodies@ is called when doing the worker\/wrapper split inside a module. \begin{code} mkWwBodies :: Type -- Type of original function @@ -122,16 +123,16 @@ mkWwBodies :: Type -- Type of original function mkWwBodies fun_ty demands res_info one_shots = do (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs fun_ty demands one_shots' (work_args, wrap_fn_str, work_fn_str) <- mkWWstr wrap_args - let (work_lam_args, work_call_args) = do mkWorkerArgs work_args res_ty + let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty -- Don't do CPR if the worker doesn't have any value arguments -- Then the worker is just a constant, so we don't want to unbox it. (wrap_fn_cpr, work_fn_cpr, _cpr_res_ty) - <- if any isId work_args then + <- if any isIdVar work_args then mkWWcpr res_ty res_info else return (id, id, res_ty) - return ([idNewDemandInfo v | v <- work_call_args, isId v], + return ([idNewDemandInfo v | v <- work_call_args, isIdVar v], Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) -- We use an INLINE unconditionally, even if the wrapper turns out to be @@ -169,7 +170,7 @@ mkWorkerArgs :: [Var] -> ([Var], -- Lambda bound args [Var]) -- Args at call site mkWorkerArgs args res_ty - | any isId args || not (isUnLiftedType res_ty) + | any isIdVar args || not (isUnLiftedType res_ty) = (args, args) | otherwise = (args ++ [voidArgId], args ++ [realWorldPrimId]) @@ -277,7 +278,7 @@ applyToVars vars fn = mkVarApps fn vars mk_wrap_arg :: Unique -> Type -> NewDemand.Demand -> Bool -> Id mk_wrap_arg uniq ty dmd one_shot - = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd) + = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd) where set_one_shot True id = setOneShotLambda id set_one_shot False id = id @@ -501,5 +502,5 @@ sanitiseCaseBndr :: Id -> Id sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo mk_ww_local :: Unique -> Type -> Id -mk_ww_local uniq ty = mkSysLocal FSLIT("ww") uniq ty +mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty \end{code}