X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSATMonad.lhs;h=0df2551e3f7d0d7ad5d12f136ebadcab6a30216d;hb=408b30036d764bc2cb72c726a76c706fae41fe7f;hp=dbdff75125efafb4ec049b05145045608aac46ab;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index dbdff75..0df2551 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ %* * @@ -7,33 +7,36 @@ %* * %************************************************************************ +96/03: We aren't using the static-argument transformation right now. + \begin{code} +module SATMonad where + #include "HsVersions.h" +import Panic ( panic ) + +junk_from_SATMonad = panic "SATMonad.junk" + +{- LATER: to end of file: + module SATMonad ( SATInfo(..), updSAEnv, SatM(..), initSAT, emptyEnvSAT, returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName, getArgLists, Arg(..), insSAEnv, saTransform, - SATEnv(..), isStatic, dropStatics, - - Id, UniType, SplitUniqSupply, PlainCoreExpr(..) + SATEnv(..), isStatic, dropStatics ) where -import AbsUniType ( mkTyVarTy, mkSigmaTy, TyVarTemplate, - extractTyVarsFromTy, splitType, splitTyArgs, - glueTyArgs, instantiateTy, TauType(..), - Class, ThetaType(..), SigmaType(..), +import Type ( mkTyVarTy, mkSigmaTy, + splitSigmaTy, splitFunTys, + glueTyArgs, substTy, InstTyEnv(..) ) -import IdEnv -import Id ( mkSysLocal, getIdUniType ) -import Maybes ( Maybe(..) ) -import PlainCore -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) -import SplitUniq -import Unique +import MkId ( mkSysLocal ) +import Id ( idType, idName, mkLocalId ) +import UniqSupply import Util infixr 9 `thenSAT`, `thenSAT_` @@ -48,13 +51,13 @@ infixr 9 `thenSAT`, `thenSAT_` \begin{code} type SATEnv = IdEnv SATInfo -type SATInfo = ([Arg UniType],[Arg Id]) +type SATInfo = ([Arg Type],[Arg Id]) data Arg a = Static a | NotStatic deriving Eq delOneFromSAEnv v us env - = ((), delOneFromIdEnv env v) + = ((), delVarEnv env v) updSAEnv :: Maybe (Id,SATInfo) -> SatM () updSAEnv Nothing @@ -78,7 +81,7 @@ notStatics n = nOfThem n NotStatic insSAEnv :: Id -> SATInfo -> SatM () insSAEnv b info us env - = ((), addOneToIdEnv env b info) + = ((), extendVarEnv env b info) \end{code} %************************************************************************ @@ -91,11 +94,11 @@ Two items of state to thread around: a UniqueSupply and a SATEnv. \begin{code} type SatM result - = SplitUniqSupply -> SATEnv -> (result, SATEnv) + = UniqSupply -> SATEnv -> (result, SATEnv) -initSAT :: SatM a -> SplitUniqSupply -> a +initSAT :: SatM a -> UniqSupply -> a -initSAT f us = fst (f us nullIdEnv) +initSAT f us = fst (f us emptyVarEnv) thenSAT m k us env = case splitUniqSupply us of { (s1, s2) -> @@ -108,7 +111,7 @@ thenSAT_ m k us env k s2 menv }} emptyEnvSAT :: SatM () -emptyEnvSAT us _ = ((), nullIdEnv) +emptyEnvSAT us _ = ((), emptyVarEnv) returnSAT v us env = (v, env) @@ -128,61 +131,61 @@ mapSAT f (x:xs) \begin{code} getSATInfo :: Id -> SatM (Maybe SATInfo) getSATInfo var us env - = (lookupIdEnv env var, env) + = (lookupVarEnv env var, env) -newSATName :: Id -> UniType -> SatM Id +newSATName :: Id -> Type -> SatM Id newSATName id ty us env - = case (getSUnique us) of { unique -> - (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) } - where - new_str = getOccurrenceName id _APPEND_ SLIT("_sat") + = case (getUnique us) of { unique -> + let + new_name = mkCompoundName SLIT("$sat") unique (idName id) + in + (mkLocalId new_name ty, env) } -getArgLists :: PlainCoreExpr -> ([Arg UniType],[Arg Id]) +getArgLists :: CoreExpr -> ([Arg Type],[Arg Id]) getArgLists expr = let - (tvs, lambda_bounds, body) = digForLambdas expr + (tvs, lambda_bounds, body) = collectBinders expr in ([ Static (mkTyVarTy tv) | tv <- tvs ], [ Static v | v <- lambda_bounds ]) -dropArgs :: PlainCoreExpr -> PlainCoreExpr -dropArgs (CoLam v e) = dropArgs e -dropArgs (CoTyLam ty e) = dropArgs e +dropArgs :: CoreExpr -> CoreExpr +dropArgs (Lam _ e) = dropArgs e +dropArgs (CoTyLam _ e) = dropArgs e dropArgs e = e - \end{code} We implement saTransform using shadowing of binders, that is we transform map = \f as -> case as of - [] -> [] - (a':as') -> let x = f a' - y = map f as' - in x:y + [] -> [] + (a':as') -> let x = f a' + y = map f as' + in x:y to map = \f as -> let map = \f as -> map' as - in let rec map' = \as -> case as of - [] -> [] - (a':as') -> let x = f a' - y = map f as' - in x:y - in map' as + in let rec map' = \as -> case as of + [] -> [] + (a':as') -> let x = f a' + y = map f as' + in x:y + in map' as the inner map should get inlined and eliminated. \begin{code} -saTransform :: Id -> PlainCoreExpr -> SatM PlainCoreBinding +saTransform :: Id -> CoreExpr -> SatM CoreBinding saTransform binder rhs = getSATInfo binder `thenSAT` \ r -> case r of -- [Andre] test: do it only if we have more than one static argument. - --Just (tyargs,args) | any isStatic args - Just (tyargs,args) | length (filter isStatic args) > 1 + --Just (tyargs,args) | any isStatic args + Just (tyargs,args) | (filter isStatic args) `lengthExceeds` 1 -> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' -> mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs -> trace ("SAT "++ show (length (filter isStatic args))) ( - returnSAT (CoNonRec binder new_rhs) - ) - _ -> returnSAT (CoRec [(binder, rhs)]) + returnSAT (NonRec binder new_rhs) + ) + _ -> returnSAT (Rec [(binder, rhs)]) where mkNewRhs binder binder' tyargs args rhs = let @@ -196,57 +199,57 @@ saTransform binder rhs get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as get_nsa (_:args) (_:as) = get_nsa args as - local_body = foldl CoApp (CoVar binder') - [CoVarAtom a | a <- non_static_args] + local_body = foldl App (Var binder') + [VarArg a | a <- non_static_args] nonrec_rhs = origLams local_body - -- HACK! The following is a fake SysLocal binder with + -- HACK! The following is a fake SysLocal binder with -- *the same* unique as binder. -- the reason for this is the following: -- this binder *will* get inlined but if it happen to be -- a top level binder it is never removed as dead code, -- therefore we have to remove that information (of it being - -- top-level or exported somehow. + -- top-level or exported somehow.) -- A better fix is to use binder directly but with the TopLevel -- tag (or Exported tag) modified. - fake_binder = mkSysLocal - (getOccurrenceName binder _APPEND_ SLIT("_fsat")) - (getTheUnique binder) - (getIdUniType binder) - mkUnknownSrcLoc - rec_body = mkCoLam non_static_args - ( CoLet (CoNonRec fake_binder nonrec_rhs) - {-in-} (dropArgs rhs)) + fake_binder = mkSysLocal SLIT("sat") + (getUnique binder) + (idType binder) + rec_body = mkValLam non_static_args + ( Let (NonRec fake_binder nonrec_rhs) + {-in-} (dropArgs rhs)) in returnSAT ( - origLams (CoLet (CoRec [(binder',rec_body)]) {-in-} local_body) + origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body) ) where origLams = origLams' rhs - where - origLams' (CoLam v e) e' = mkCoLam v (origLams' e e') - origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e') - origLams' _ e' = e' + where + origLams' (Lam v e) e' = Lam v (origLams' e e') + origLams' (CoTyLam ty e) e' = CoTyLam ty (origLams' e e') + origLams' _ e' = e' new_ty tyargs args - = instantiateTy (mk_inst_tyenv tyargs tv_tmpl) + = substTy (mk_inst_tyenv tyargs tv_tmpl) (mkSigmaTy tv_tmpl' dict_tys' tau_ty') where -- get type info for the local function: - (tv_tmpl, dict_tys, tau_ty) = (splitType . getIdUniType) binder - (reg_arg_tys, res_type) = splitTyArgs tau_ty + (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder + (reg_arg_tys, res_type) = splitFunTys tau_ty -- now, we drop the ones that are -- static, that is, the ones we will not pass to the local function - l = length dict_tys tv_tmpl' = dropStatics tyargs tv_tmpl - dict_tys' = dropStatics (take l args) dict_tys - reg_arg_tys' = dropStatics (drop l args) reg_arg_tys + + (args1, args2) = splitAtList dict_tys args + dict_tys' = dropStatics args1 dict_tys + reg_arg_tys' = dropStatics args2 reg_arg_tys + tau_ty' = glueTyArgs reg_arg_tys' res_type - mk_inst_tyenv [] _ = [] - mk_inst_tyenv (Static s:args) (t:ts) = (t,s) : mk_inst_tyenv args ts + mk_inst_tyenv [] _ = emptyVarEnv + mk_inst_tyenv (Static s:args) (t:ts) = extendVarEnv (mk_inst_tyenv args ts) t s mk_inst_tyenv (_:args) (_:ts) = mk_inst_tyenv args ts dropStatics [] t = t @@ -256,4 +259,5 @@ dropStatics (_:args) (t:ts) = t:dropStatics args ts isStatic :: Arg a -> Bool isStatic NotStatic = False isStatic _ = True +-} \end{code}