compiler/simplCore/SATMonad.lhs

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