ghc/compiler/simplCore/SATMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[SATMonad]{The Static Argument Transformation pass Monad}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 96/03: We aren't using the static-argument transformation right now.
  11
  12 \begin{code}
  13 module SATMonad where
  14
  15 #include "HsVersions.h"
  16
  17 import Util             ( panic )
  18
  19 junk_from_SATMonad = panic "SATMonad.junk"
  20
  21 {- LATER: to end of file:
  22
  23 module SATMonad (
  24         SATInfo(..), updSAEnv,
  25         SatM(..), initSAT, emptyEnvSAT,
  26         returnSAT, thenSAT, thenSAT_, mapSAT, getSATInfo, newSATName,
  27         getArgLists, Arg(..), insSAEnv, saTransform,
  28
  29         SATEnv(..), isStatic, dropStatics
  30     ) where
  31
  32 import Type             ( mkTyVarTy, mkSigmaTy, TyVarTemplate,
  33                           splitSigmaTy, splitFunTys,
  34                           glueTyArgs, instantiateTy, TauType,
  35                           Class, ThetaType, SigmaType,
  36                           InstTyEnv(..)
  37                         )
  38 import Id               ( mkSysLocal, idType )
  39 import SrcLoc           ( SrcLoc, noSrcLoc )
  40 import UniqSupply
  41 import Util
  42
  43 infixr 9 `thenSAT`, `thenSAT_`
  44 \end{code}
  45
  46 %************************************************************************
  47 %*                                                                      *
  48 \subsection{Static Argument Transformation Environment}
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 \begin{code}
  53 type SATEnv = IdEnv SATInfo
  54
  55 type SATInfo = ([Arg Type],[Arg Id])
  56
  57 data Arg a = Static a | NotStatic
  58     deriving Eq
  59
  60 delOneFromSAEnv v us env
  61   = ((), delOneFromIdEnv env v)
  62
  63 updSAEnv :: Maybe (Id,SATInfo) -> SatM ()
  64 updSAEnv Nothing
  65   = returnSAT ()
  66 updSAEnv (Just (b,(tyargs,args)))
  67   = getSATInfo b      `thenSAT` (\ r ->
  68     case r of
  69       Nothing              -> returnSAT ()
  70       Just (tyargs',args') -> delOneFromSAEnv b `thenSAT_`
  71                               insSAEnv b (checkArgs tyargs tyargs',
  72                                           checkArgs args args')
  73     )
  74
  75 checkArgs as [] = notStatics (length as)
  76 checkArgs [] as = notStatics (length as)
  77 checkArgs (a:as) (a':as') | a == a' = a:checkArgs as as'
  78 checkArgs (_:as) (_:as') = NotStatic:checkArgs as as'
  79
  80 notStatics :: Int -> [Arg a]
  81 notStatics n = nOfThem n NotStatic
  82
  83 insSAEnv :: Id -> SATInfo -> SatM ()
  84 insSAEnv b info us env
  85   = ((), addOneToIdEnv env b info)
  86 \end{code}
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection{Static Argument Transformation Monad}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 Two items of state to thread around: a UniqueSupply and a SATEnv.
  95
  96 \begin{code}
  97 type SatM result
  98   =  UniqSupply -> SATEnv -> (result, SATEnv)
  99
 100 initSAT :: SatM a -> UniqSupply -> a
 101
 102 initSAT f us = fst (f us nullIdEnv)
 103
 104 thenSAT m k us env
 105   = case splitUniqSupply us     of { (s1, s2) ->
 106     case m s1 env               of { (m_result, menv) ->
 107     k m_result s2 menv }}
 108
 109 thenSAT_ m k us env
 110   = case splitUniqSupply us     of { (s1, s2) ->
 111     case m s1 env               of { (_, menv) ->
 112     k s2 menv }}
 113
 114 emptyEnvSAT :: SatM ()
 115 emptyEnvSAT us _ = ((), nullIdEnv)
 116
 117 returnSAT v us env = (v, env)
 118
 119 mapSAT f []     = returnSAT []
 120 mapSAT f (x:xs)
 121   = f x         `thenSAT` \ x'  ->
 122     mapSAT f xs `thenSAT` \ xs' ->
 123     returnSAT (x':xs')
 124 \end{code}
 125
 126 %************************************************************************
 127 %*                                                                      *
 128 \subsection{Utility Functions}
 129 %*                                                                      *
 130 %************************************************************************
 131
 132 \begin{code}
 133 getSATInfo :: Id -> SatM (Maybe SATInfo)
 134 getSATInfo var us env
 135   = (lookupIdEnv env var, env)
 136
 137 newSATName :: Id -> Type -> SatM Id
 138 newSATName id ty us env
 139   = case (getUnique us) of { unique ->
 140     (mkSysLocal new_str unique ty noSrcLoc, env) }
 141   where
 142     new_str = getOccName id _APPEND_ SLIT("_sat")
 143
 144 getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
 145 getArgLists expr
 146   = let
 147         (tvs, lambda_bounds, body) = collectBinders expr
 148     in
 149     ([ Static (mkTyVarTy tv) | tv <- tvs ],
 150      [ Static v              | v <- lambda_bounds ])
 151
 152 dropArgs :: CoreExpr -> CoreExpr
 153 dropArgs (Lam   _ e)    = dropArgs e
 154 dropArgs (CoTyLam _ e)  = dropArgs e
 155 dropArgs e              = e
 156 \end{code}
 157
 158 We implement saTransform using shadowing of binders, that is
 159 we transform
 160 map = \f as -> case as of
 161                  [] -> []
 162                  (a':as') -> let x = f a'
 163                                  y = map f as'
 164                              in x:y
 165 to
 166 map = \f as -> let map = \f as -> map' as
 167                in let rec map' = \as -> case as of
 168                                           [] -> []
 169                                           (a':as') -> let x = f a'
 170                                                           y = map f as'
 171                                                       in x:y
 172                   in map' as
 173
 174 the inner map should get inlined and eliminated.
 175 \begin{code}
 176 saTransform :: Id -> CoreExpr -> SatM CoreBinding
 177 saTransform binder rhs
 178   = getSATInfo binder `thenSAT` \ r ->
 179     case r of
 180       -- [Andre] test: do it only if we have more than one static argument.
 181       --Just (tyargs,args) | any isStatic args
 182       Just (tyargs,args) | length (filter isStatic args) > 1
 183         -> newSATName binder (new_ty tyargs args)  `thenSAT` \ binder' ->
 184            mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
 185            trace ("SAT "++ show (length (filter isStatic args))) (
 186            returnSAT (NonRec binder new_rhs)
 187            )
 188       _ -> returnSAT (Rec [(binder, rhs)])
 189   where
 190     mkNewRhs binder binder' tyargs args rhs
 191       = let
 192             non_static_args :: [Id]
 193             non_static_args
 194                = get_nsa args (snd (getArgLists rhs))
 195                where
 196                  get_nsa :: [Arg a] -> [Arg a] -> [a]
 197                  get_nsa [] _ = []
 198                  get_nsa _ [] = []
 199                  get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
 200                  get_nsa (_:args)         (_:as)        =   get_nsa args as
 201
 202             local_body = foldl App (Var binder')
 203                                 [VarArg a | a <- non_static_args]
 204
 205             nonrec_rhs = origLams local_body
 206
 207             -- HACK! The following is a fake SysLocal binder with
 208             -- *the same* unique as binder.
 209             -- the reason for this is the following:
 210             -- this binder *will* get inlined but if it happen to be
 211             -- a top level binder it is never removed as dead code,
 212             -- therefore we have to remove that information (of it being
 213             -- top-level or exported somehow.)
 214             -- A better fix is to use binder directly but with the TopLevel
 215             -- tag (or Exported tag) modified.
 216             fake_binder = mkSysLocal
 217                             (getOccName binder _APPEND_ SLIT("_fsat"))
 218                             (uniqueOf binder)
 219                             (idType binder)
 220                             noSrcLoc
 221             rec_body = mkValLam non_static_args
 222                                ( Let (NonRec fake_binder nonrec_rhs)
 223                                  {-in-} (dropArgs rhs))
 224         in
 225         returnSAT (
 226             origLams (Let (Rec [(binder',rec_body)]) {-in-} local_body)
 227         )
 228       where
 229         origLams = origLams' rhs
 230                  where
 231                    origLams' (Lam v e)     e' = Lam   v  (origLams' e e')
 232                    origLams' (CoTyLam ty e)  e' = CoTyLam ty (origLams' e e')
 233                    origLams' _               e' = e'
 234
 235     new_ty tyargs args
 236       = instantiateTy (mk_inst_tyenv tyargs tv_tmpl)
 237                       (mkSigmaTy tv_tmpl' dict_tys' tau_ty')
 238       where
 239         -- get type info for the local function:
 240         (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
 241         (reg_arg_tys, res_type)     = splitFunTys tau_ty
 242
 243         -- now, we drop the ones that are
 244         -- static, that is, the ones we will not pass to the local function
 245         l            = length dict_tys
 246         tv_tmpl'     = dropStatics tyargs tv_tmpl
 247         dict_tys'    = dropStatics (take l args) dict_tys
 248         reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
 249         tau_ty'      = glueTyArgs reg_arg_tys' res_type
 250
 251         mk_inst_tyenv []                    _ = emptyTyVarEnv
 252         mk_inst_tyenv (Static s:args) (t:ts)  = addToTyVarEnv (mk_inst_tyenv args ts) t s
 253         mk_inst_tyenv (_:args)      (_:ts)    = mk_inst_tyenv args ts
 254
 255 dropStatics [] t = t
 256 dropStatics (Static _:args) (t:ts) = dropStatics args ts
 257 dropStatics (_:args)        (t:ts) = t:dropStatics args ts
 258
 259 isStatic :: Arg a -> Bool
 260 isStatic NotStatic = False
 261 isStatic _         = True
 262 -}
 263 \end{code}