import StgSyn
-import AbsUniType ( splitTypeWithDictsAsArgs, Class,
+import Type ( splitTypeWithDictsAsArgs, Class,
TyVarTemplate, TauType(..)
)
import CostCentre
-import IdEnv
-import Id ( mkSysLocal, getIdUniType, getIdArity, addIdArity )
+import Id ( mkSysLocal, idType, getIdArity, addIdArity )
import IdInfo -- SIGH: ( arityMaybe, ArityInfo, OptIdInfo(..) )
import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
-import SplitUniq
-import Unique
+import UniqSupply
import Util
import Maybes
type ExprArityInfo = Maybe Int -- Just n => This expression has a guaranteed
-- arity of n
-- Nothing => Don't know how many args it needs
-
+
type Id_w_Arity = Id -- An Id with correct arity info pinned on it
type SatEnv = IdEnv Id_w_Arity -- Binds only local, let(rec)-bound things
\end{code}
-This pass
+This pass
\begin{itemize}
\item adds extra args where necessary;
\item pins the correct arity on everything.
%************************************************************************
\begin{code}
-satStgRhs :: PlainStgProgram -> SUniqSM PlainStgProgram
+satStgRhs :: [StgBinding] -> UniqSM [StgBinding]
satStgRhs p = satProgram nullIdEnv p
-satProgram :: SatEnv -> PlainStgProgram -> SUniqSM PlainStgProgram
-satProgram env [] = returnSUs []
+satProgram :: SatEnv -> [StgBinding] -> UniqSM [StgBinding]
+satProgram env [] = returnUs []
-satProgram env (bind:binds)
- = satBinding True{-toplevel-} env bind `thenSUs` \ (env2, bind2) ->
- satProgram env2 binds `thenSUs` \ binds2 ->
- returnSUs (bind2 : binds2)
+satProgram env (bind:binds)
+ = satBinding True{-toplevel-} env bind `thenUs` \ (env2, bind2) ->
+ satProgram env2 binds `thenUs` \ binds2 ->
+ returnUs (bind2 : binds2)
\end{code}
%************************************************************************
\begin{code}
satBinding :: Bool -- True <=> top-level
- -> SatEnv
- -> PlainStgBinding
- -> SUniqSM (SatEnv, PlainStgBinding)
+ -> SatEnv
+ -> StgBinding
+ -> UniqSM (SatEnv, StgBinding)
satBinding top env (StgNonRec b rhs)
- = satRhs top env (b, rhs) `thenSUs` \ (b2, rhs2) ->
+ = satRhs top env (b, rhs) `thenUs` \ (b2, rhs2) ->
let
env2 = addOneToIdEnv env b b2
in
- returnSUs (env2, StgNonRec b2 rhs2)
+ returnUs (env2, StgNonRec b2 rhs2)
satBinding top env (StgRec pairs)
= -- Do it once to get the arities right...
- mapSUs (satRhs top env) pairs `thenSUs` \ pairs2 ->
+ mapUs (satRhs top env) pairs `thenUs` \ pairs2 ->
let
env2 = growIdEnvList env (map fst pairs `zip` map fst pairs2)
in
-- Do it again to *use* those arities:
- mapSUs (satRhs top env2) pairs `thenSUs` \ pairs3 ->
+ mapUs (satRhs top env2) pairs `thenUs` \ pairs3 ->
- returnSUs (env2, StgRec pairs3)
+ returnUs (env2, StgRec pairs3)
-satRhs :: Bool -> SatEnv -> (Id, PlainStgRhs) -> SUniqSM (Id_w_Arity, PlainStgRhs)
+satRhs :: Bool -> SatEnv -> (Id, StgRhs) -> UniqSM (Id_w_Arity, StgRhs)
satRhs top env (b, StgRhsCon cc con args) -- Nothing much to do here
- = let
+ = let
b2 = b `addIdArity` 0 -- bound to a saturated constructor; hence zero.
in
- returnSUs (b2, StgRhsCon cc con (lookupArgs env args))
+ returnUs (b2, StgRhsCon cc con (lookupArgs env args))
satRhs top env (b, StgRhsClosure cc bi fv u args body)
- = satExpr env body `thenSUs` \ (arity_info, body2) ->
+ = satExpr env body `thenUs` \ (arity_info, body2) ->
let
num_args = length args
in
(case arity_info of
Nothing ->
- returnSUs (num_args, StgRhsClosure cc bi fv u args body2)
+ returnUs (num_args, StgRhsClosure cc bi fv u args body2)
Just needed_args ->
ASSERT(needed_args >= 1)
new_arity = num_args + needed_args
-- get type info for this function:
- (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (getIdUniType b)
+ (_,all_arg_tys,_) = splitTypeWithDictsAsArgs (idType b)
-- now, we already have "args"; we drop that many types
args_we_dont_have_tys = drop num_args all_arg_tys
args_to_add_tys = take needed_args args_we_dont_have_tys
in
-- make up names for them
- mapSUs newName args_to_add_tys `thenSUs` \ nns ->
+ mapUs newName args_to_add_tys `thenUs` \ nns ->
-- and do the business
let
- body3 = saturate body2 (map StgVarAtom nns)
+ body3 = saturate body2 (map StgVarArg nns)
new_cc -- if we're adding args, we'd better not
-- keep calling something a CAF! (what about DICTs? ToDo: WDP 95/02)
- = if not (isCafCC cc)
- then cc -- unchanged
+ = if not (isCafCC cc)
+ then cc -- unchanged
else if top then subsumedCosts else useCurrentCostCentre
in
- returnSUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3)
+ returnUs (new_arity, StgRhsClosure new_cc bi fv ReEntrant (args++nns) body3)
)
- `thenSUs` \ (arity, rhs2) ->
- let
+ `thenUs` \ (arity, rhs2) ->
+ let
b2 = b `addIdArity` arity
in
- returnSUs (b2, rhs2)
+ returnUs (b2, rhs2)
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-satExpr :: SatEnv -> PlainStgExpr -> SUniqSM (ExprArityInfo, PlainStgExpr)
+\begin{code}
+satExpr :: SatEnv -> StgExpr -> UniqSM (ExprArityInfo, StgExpr)
-satExpr env app@(StgApp (StgLitAtom lit) [] lvs) = returnSUs (Nothing, app)
+satExpr env app@(StgApp (StgLitArg lit) [] lvs) = returnUs (Nothing, app)
-satExpr env app@(StgApp (StgVarAtom f) as lvs)
- = returnSUs (arity_to_return, StgApp (StgVarAtom f2) as2 lvs)
+satExpr env app@(StgApp (StgVarArg f) as lvs)
+ = returnUs (arity_to_return, StgApp (StgVarArg f2) as2 lvs)
where
as2 = lookupArgs env as
f2 = lookupVar env f
arity_to_return = case arityMaybe (getIdArity f2) of
Nothing -> Nothing
- Just f_arity -> if remaining_arity > 0
+ Just f_arity -> if remaining_arity > 0
then Just remaining_arity
else Nothing
where
remaining_arity = f_arity - length as
-
-satExpr env app@(StgConApp con as lvs)
- = returnSUs (Nothing, StgConApp con (lookupArgs env as) lvs)
-satExpr env app@(StgPrimApp op as lvs)
- = returnSUs (Nothing, StgPrimApp op (lookupArgs env as) lvs)
+satExpr env app@(StgCon con as lvs)
+ = returnUs (Nothing, StgCon con (lookupArgs env as) lvs)
+
+satExpr env app@(StgPrim op as lvs)
+ = returnUs (Nothing, StgPrim op (lookupArgs env as) lvs)
satExpr env (StgSCC ty l e)
- = satExpr env e `thenSUs` \ (_, e2) ->
- returnSUs (Nothing, StgSCC ty l e2)
+ = satExpr env e `thenUs` \ (_, e2) ->
+ returnUs (Nothing, StgSCC ty l e2)
{- OMITTED: Let-no-escapery should come *after* saturation
satExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
- = satBinding binds `thenSUs` \ (binds2, c) ->
- satExpr body `thenSUs` \ (_, body2, c2) ->
- returnSUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2)
+ = satBinding binds `thenUs` \ (binds2, c) ->
+ satExpr body `thenUs` \ (_, body2, c2) ->
+ returnUs (Nothing, StgLetNoEscape lvs_whole lvs_rhss binds2 body2, c + c2)
-}
satExpr env (StgLet binds body)
- = satBinding False{-not top-level-} env binds `thenSUs` \ (env2, binds2) ->
- satExpr env2 body `thenSUs` \ (_, body2) ->
- returnSUs (Nothing, StgLet binds2 body2)
+ = satBinding False{-not top-level-} env binds `thenUs` \ (env2, binds2) ->
+ satExpr env2 body `thenUs` \ (_, body2) ->
+ returnUs (Nothing, StgLet binds2 body2)
satExpr env (StgCase expr lve lva uniq alts)
- = satExpr env expr `thenSUs` \ (_, expr2) ->
- sat_alts alts `thenSUs` \ alts2 ->
- returnSUs (Nothing, StgCase expr2 lve lva uniq alts2)
+ = satExpr env expr `thenUs` \ (_, expr2) ->
+ sat_alts alts `thenUs` \ alts2 ->
+ returnUs (Nothing, StgCase expr2 lve lva uniq alts2)
where
sat_alts (StgAlgAlts ty alts def)
- = mapSUs sat_alg_alt alts `thenSUs` \ alts2 ->
- sat_deflt def `thenSUs` \ def2 ->
- returnSUs (StgAlgAlts ty alts2 def2)
+ = mapUs sat_alg_alt alts `thenUs` \ alts2 ->
+ sat_deflt def `thenUs` \ def2 ->
+ returnUs (StgAlgAlts ty alts2 def2)
where
sat_alg_alt (id, bs, use_mask, e)
- = satExpr env e `thenSUs` \ (_, e2) ->
- returnSUs (id, bs, use_mask, e2)
+ = satExpr env e `thenUs` \ (_, e2) ->
+ returnUs (id, bs, use_mask, e2)
sat_alts (StgPrimAlts ty alts def)
- = mapSUs sat_prim_alt alts `thenSUs` \ alts2 ->
- sat_deflt def `thenSUs` \ def2 ->
- returnSUs (StgPrimAlts ty alts2 def2)
+ = mapUs sat_prim_alt alts `thenUs` \ alts2 ->
+ sat_deflt def `thenUs` \ def2 ->
+ returnUs (StgPrimAlts ty alts2 def2)
where
sat_prim_alt (l, e)
- = satExpr env e `thenSUs` \ (_, e2) ->
- returnSUs (l, e2)
+ = satExpr env e `thenUs` \ (_, e2) ->
+ returnUs (l, e2)
sat_deflt StgNoDefault
- = returnSUs StgNoDefault
+ = returnUs StgNoDefault
sat_deflt (StgBindDefault b u expr)
- = satExpr env expr `thenSUs` \ (_,expr2) ->
- returnSUs (StgBindDefault b u expr2)
+ = satExpr env expr `thenUs` \ (_,expr2) ->
+ returnUs (StgBindDefault b u expr2)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-saturate :: PlainStgExpr -> [PlainStgAtom] -> PlainStgExpr
+saturate :: StgExpr -> [StgArg] -> StgExpr
saturate (StgApp f as lvs) ids = StgApp f (as ++ ids) lvs
saturate other _ = panic "SatStgRhs: saturate"
\end{code}
\begin{code}
-lookupArgs :: SatEnv -> [PlainStgAtom] -> [PlainStgAtom]
+lookupArgs :: SatEnv -> [StgArg] -> [StgArg]
lookupArgs env args = map do args
- where
- do (StgVarAtom v) = StgVarAtom (lookupVar env v)
- do a@(StgLitAtom lit) = a
+ where
+ do (StgVarArg v) = StgVarArg (lookupVar env v)
+ do a@(StgLitArg lit) = a
lookupVar :: SatEnv -> Id -> Id
lookupVar env v = case lookupIdEnv env v of
Nothing -> v
Just v2 -> v2
-newName :: UniType -> SUniqSM Id
+newName :: Type -> UniqSM Id
newName ut
- = getSUnique `thenSUs` \ uniq ->
- returnSUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
+ = getUnique `thenUs` \ uniq ->
+ returnUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
\end{code}
projects / ghc-hetmet.git / blobdiff