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