)
import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
- setIdVisibility,
GenId{-instance Eq/Outputable -}, SYN_IE(Id)
)
import Maybes ( maybeToBool )
-- correct, which is done by satStgRhs.
--
-{-
- Done in Core now. Nuke soon. SLPJ Nov 96
-
- No, STG passes may introduce toplevel bindings which
- have to be globalised here (later than Core anyway) -- SOF 2/97
-
- Yes, lambda lifting now does the Right Thing.
-
- let
- -- ToDo: provide proper flag control!
- binds_to_mangle
- = if not do_unlocalising
- then processed_binds
- else snd (unlocaliseStgBinds unlocal_tag nullIdEnv processed_binds)
- in
--}
-
return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
}
where
foldl_mn f z (x:xs) = f z x >>= \ zz ->
foldl_mn f zz xs
\end{code}
-
-%************************************************************************
-%* *
-\subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
-%* *
-%************************************************************************
-
-The idea of all this ``unlocalise'' stuff is that in certain (prelude
-only) modules we split up the .hc file into lots of separate little
-files, which are separately compiled by the C compiler. That gives
-lots of little .o files. The idea is that if you happen to mention
-one of them you don't necessarily pull them all in. (Pulling in a
-piece you don't need can be v bad, because it may mention other pieces
-you don't need either, and so on.)
-
-Sadly, splitting up .hc files means that local names (like s234) are
-now globally visible, which can lead to clashes between two .hc
-files. So unlocaliseWhatnot goes through making all the local things
-into global things, essentially by giving them full names so when they
-are printed they'll have their module name too. Pretty revolting
-really.
-
-\begin{code}
-type UnlocalEnv = IdEnv Id
-
-lookup_uenv :: UnlocalEnv -> Id -> Id
-lookup_uenv env id = case lookupIdEnv env id of
- Nothing -> id
- Just new_id -> new_id
-unlocaliseStgBinds :: FAST_STRING
- -> UnlocalEnv
- -> [StgBinding]
- -> (UnlocalEnv, [StgBinding])
-unlocaliseStgBinds mod uenv [] = (uenv, [])
-unlocaliseStgBinds mod uenv (b : bs) =
- case unlocal_top_bind mod uenv b of { (new_uenv, new_b) ->
- case unlocaliseStgBinds mod new_uenv bs of { (uenv3, new_bs) ->
- (uenv3, new_b : new_bs)
- }}
-
-------------------
-unlocal_top_bind :: FAST_STRING
- -> UnlocalEnv
- -> StgBinding
- -> (UnlocalEnv, StgBinding)
-unlocal_top_bind mod uenv bind@(StgNonRec binder _) =
- let
- new_uenv =
- case lookupIdEnv uenv binder of
- Just global -> uenv
- Nothing -> new_env
- where
- new_env = addOneToIdEnv uenv binder new_global
- new_global = setIdVisibility mod binder
- in
- (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
-
-unlocal_top_bind mod uenv bind@(StgRec pairs) =
- let
- new_env binder uenv =
- case lookupIdEnv uenv binder of
- Just global -> uenv
- Nothing -> env'
- where
- env' = addOneToIdEnv uenv binder new_global
- new_global = setIdVisibility mod binder
-
- uenv' = foldr (new_env) uenv (map (fst) pairs)
- in
- (uenv', renameTopStgBind (lookup_uenv uenv') bind)
-
-\end{code}
-
-@renameTopStgBind@ renames top level binders and all occurrences thereof.
-
-\begin{code}
-renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
-renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
-renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
-\end{code}
-
-This utility function simply applies the given function to every
-bindee in the program.
-
-\begin{code}
-mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding
-mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
-mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
-
-------------------
-mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs
-mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr)
- = StgRhsClosure
- cc bi
- (map fn fvs)
- u
- (map fn args)
- (mapStgBindeesExpr fn expr)
-
-mapStgBindeesRhs fn (StgRhsCon cc con atoms)
- = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms)
-
-------------------
-mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr
-
-mapStgBindeesExpr fn (StgApp f args lvs)
- = StgApp (mapStgBindeesArg fn f)
- (map (mapStgBindeesArg fn) args)
- (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgCon con atoms lvs)
- = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgPrim op atoms lvs)
- = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs)
-
-mapStgBindeesExpr fn (StgLet bind expr)
- = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr)
-
-mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body)
- = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs)
- (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body)
-
-mapStgBindeesExpr fn (StgSCC ty label expr)
- = StgSCC ty label (mapStgBindeesExpr fn expr)
-
-mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts)
- = StgCase (mapStgBindeesExpr fn expr)
- (mapUniqSet fn lvs1)
- (mapUniqSet fn lvs2)
- uniq
- (mapStgBindeesAlts alts)
- where
- mapStgBindeesAlts (StgAlgAlts ty alts deflt)
- = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt)
- where
- mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr)
-
- mapStgBindeesAlts (StgPrimAlts ty alts deflt)
- = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt)
- where
- mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr)
-
- mapStgBindeesDeflt StgNoDefault = StgNoDefault
- mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr)
-
-------------------
-mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg
-mapStgBindeesArg fn a@(StgLitArg _) = a
-mapStgBindeesArg fn a@(StgConArg _) = a
-mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id)
-\end{code}
opt_SpecialiseAll, opt_PprUserLength
)
import Bag ( isEmptyBag, bagToList, Bag )
-import Class ( GenClass{-instance NamedThing-}, SYN_IE(Class),
- GenClassOp {- instance NamedThing -} )
+import Class ( GenClass{-instance NamedThing-}, SYN_IE(Class) )
import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
lookupWithDefaultFM
)
-import Id ( idType, isDictFunId, isConstMethodId_maybe,
- isDefaultMethodId_maybe,
+import Id ( idType, isDictFunId,
+ isDefaultMethodId_maybe, mkSameSpecCon,
GenId {-instance NamedThing -}, SYN_IE(Id)
)
import Maybes ( maybeToBool, catMaybes, firstJust )
import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) )
import Outputable ( PprStyle(..), Outputable(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
- TyCon{-ditto-}, GenType{-ditto-}, GenTyVar, GenClassOp
+ TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
)
import Pretty -- plenty of it
import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} )
assertPanic, panic{-ToDo:rm-}
)
+
cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)"
-mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)"
getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)"
-specialiseTy :: Type -> [Maybe Type] -> Int -> Type
-specialiseTy = panic "SpecUtils.specialiseTy (ToDo)"
\end{code}
@specialiseCallTys@ works out which type args don't need to be specialised on,
choose_ty (tv, Just ty) = (ty, Nothing)
pp_idspec :: PprStyle -> Doc -> (OccName, Id, [Maybe Type], Bool) -> Doc
+pp_idspec = error "pp_idspec"
+
+{- LATER
pp_idspec sty pp_mod (_, id, tys, is_err)
| isDictFunId id
default_method_maybe = isDefaultMethodId_maybe id
is_default_method_id = maybeToBool default_method_maybe
+
+-}
\end{code}
projects / ghc-hetmet.git / commitdiff