cλash/CLasH/Normalize/NormalizeTools.hs

   1 {-# LANGUAGE PackageImports #-}
   2 --
   3 -- This module provides functions for program transformations.
   4 --
   5 module CLasH.Normalize.NormalizeTools where
   6
   7 -- Standard modules
   8 import Debug.Trace
   9 import qualified List
  10 import qualified Data.Monoid as Monoid
  11 import qualified Data.Either as Either
  12 import qualified Control.Arrow as Arrow
  13 import qualified Control.Monad as Monad
  14 import qualified Control.Monad.Trans.State as State
  15 import qualified Control.Monad.Trans.Writer as Writer
  16 import qualified "transformers" Control.Monad.Trans as Trans
  17 import qualified Data.Map as Map
  18 import Data.Accessor
  19 import Data.Accessor.MonadState as MonadState
  20
  21 -- GHC API
  22 import CoreSyn
  23 import qualified Name
  24 import qualified Id
  25 import qualified CoreSubst
  26 import qualified CoreUtils
  27 import Outputable ( showSDoc, ppr, nest )
  28
  29 -- Local imports
  30 import CLasH.Normalize.NormalizeTypes
  31 import CLasH.Translator.TranslatorTypes
  32 import CLasH.Utils.Pretty
  33 import qualified CLasH.Utils.Core.CoreTools as CoreTools
  34 import CLasH.VHDL.VHDLTypes
  35 import qualified CLasH.VHDL.VHDLTools as VHDLTools
  36
  37 -- Apply the given transformation to all expressions in the given expression,
  38 -- including the expression itself.
  39 everywhere :: (String, Transform) -> Transform
  40 everywhere trans = applyboth (subeverywhere (everywhere trans)) trans
  41
  42 -- Apply the first transformation, followed by the second transformation, and
  43 -- keep applying both for as long as expression still changes.
  44 applyboth :: Transform -> (String, Transform) -> Transform
  45 applyboth first (name, second) expr  = do
  46   -- Apply the first
  47   expr' <- first expr
  48   -- Apply the second
  49   (expr'', changed) <- Writer.listen $ second expr'
  50   if Monoid.getAny $
  51 --        trace ("Trying to apply transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
  52         changed
  53     then
  54 --      trace ("Applying transform " ++ name ++ " to:\n" ++ showSDoc (nest 4 $ ppr expr') ++ "\nType: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr') ++ "\n") $
  55 --      trace ("Result of applying " ++ name ++ ":\n" ++ showSDoc (nest 4 $ ppr expr'') ++ "\n" ++ "Type: \n" ++ (showSDoc $ nest 4 $ ppr $ CoreUtils.exprType expr'') ++ "\n" ) $
  56       applyboth first (name, second) $
  57         expr''
  58     else
  59 --      trace ("No changes") $
  60       return expr''
  61
  62 -- Apply the given transformation to all direct subexpressions (only), not the
  63 -- expression itself.
  64 subeverywhere :: Transform -> Transform
  65 subeverywhere trans (App a b) = do
  66   a' <- trans a
  67   b' <- trans b
  68   return $ App a' b'
  69
  70 subeverywhere trans (Let (NonRec b bexpr) expr) = do
  71   bexpr' <- trans bexpr
  72   expr' <- trans expr
  73   return $ Let (NonRec b bexpr') expr'
  74
  75 subeverywhere trans (Let (Rec binds) expr) = do
  76   expr' <- trans expr
  77   binds' <- mapM transbind binds
  78   return $ Let (Rec binds') expr'
  79   where
  80     transbind :: (CoreBndr, CoreExpr) -> TransformMonad (CoreBndr, CoreExpr)
  81     transbind (b, e) = do
  82       e' <- trans e
  83       return (b, e')
  84
  85 subeverywhere trans (Lam x expr) = do
  86   expr' <- trans expr
  87   return $ Lam x expr'
  88
  89 subeverywhere trans (Case scrut b t alts) = do
  90   scrut' <- trans scrut
  91   alts' <- mapM transalt alts
  92   return $ Case scrut' b t alts'
  93   where
  94     transalt :: CoreAlt -> TransformMonad CoreAlt
  95     transalt (con, binders, expr) = do
  96       expr' <- trans expr
  97       return (con, binders, expr')
  98
  99 subeverywhere trans (Var x) = return $ Var x
 100 subeverywhere trans (Lit x) = return $ Lit x
 101 subeverywhere trans (Type x) = return $ Type x
 102
 103 subeverywhere trans (Cast expr ty) = do
 104   expr' <- trans expr
 105   return $ Cast expr' ty
 106
 107 subeverywhere trans expr = error $ "\nNormalizeTools.subeverywhere: Unsupported expression: " ++ show expr
 108
 109 -- Apply the given transformation to all expressions, except for direct
 110 -- arguments of an application
 111 notappargs :: (String, Transform) -> Transform
 112 notappargs trans = applyboth (subnotappargs trans) trans
 113
 114 -- Apply the given transformation to all (direct and indirect) subexpressions
 115 -- (but not the expression itself), except for direct arguments of an
 116 -- application
 117 subnotappargs :: (String, Transform) -> Transform
 118 subnotappargs trans (App a b) = do
 119   a' <- subnotappargs trans a
 120   b' <- subnotappargs trans b
 121   return $ App a' b'
 122
 123 -- Let subeverywhere handle all other expressions
 124 subnotappargs trans expr = subeverywhere (notappargs trans) expr
 125
 126 -- Runs each of the transforms repeatedly inside the State monad.
 127 dotransforms :: [Transform] -> CoreExpr -> TranslatorSession CoreExpr
 128 dotransforms transs expr = do
 129   (expr', changed) <- Writer.runWriterT $ Monad.foldM (flip ($)) expr transs
 130   if Monoid.getAny changed then dotransforms transs expr' else return expr'
 131
 132 -- Inline all let bindings that satisfy the given condition
 133 inlinebind :: ((CoreBndr, CoreExpr) -> TransformMonad Bool) -> Transform
 134 inlinebind condition expr@(Let (NonRec bndr expr') res) = do
 135     applies <- condition (bndr, expr')
 136     if applies
 137       then
 138         -- Substitute the binding in res and return that
 139         change $ substitute [(bndr, expr')] res
 140       else
 141         -- Don't change this let
 142         return expr
 143 -- Leave all other expressions unchanged
 144 inlinebind _ expr = return expr
 145
 146 -- Sets the changed flag in the TransformMonad, to signify that some
 147 -- transform has changed the result
 148 setChanged :: TransformMonad ()
 149 setChanged = Writer.tell (Monoid.Any True)
 150
 151 -- Sets the changed flag and returns the given value.
 152 change :: a -> TransformMonad a
 153 change val = do
 154   setChanged
 155   return val
 156
 157 -- Returns the given value and sets the changed flag if the bool given is
 158 -- True. Note that this will not unset the changed flag if the bool is False.
 159 changeif :: Bool -> a -> TransformMonad a
 160 changeif True val = change val
 161 changeif False val = return val
 162
 163 -- Replace each of the binders given with the coresponding expressions in the
 164 -- given expression.
 165 substitute :: [(CoreBndr, CoreExpr)] -> CoreExpr -> CoreExpr
 166 substitute [] expr = expr
 167 -- Apply one substitution on the expression, but also on any remaining
 168 -- substitutions. This seems to be the only way to handle substitutions like
 169 -- [(b, c), (a, b)]. This means we reuse a substitution, which is not allowed
 170 -- according to CoreSubst documentation (but it doesn't seem to be a problem).
 171 -- TODO: Find out how this works, exactly.
 172 substitute ((b, e):subss) expr = substitute subss' expr'
 173   where
 174     -- Create the Subst
 175     subs = (CoreSubst.extendSubst CoreSubst.emptySubst b e)
 176     -- Apply this substitution to the main expression
 177     expr' = CoreSubst.substExpr subs expr
 178     -- Apply this substitution on all the expressions in the remaining
 179     -- substitutions
 180     subss' = map (Arrow.second (CoreSubst.substExpr subs)) subss
 181
 182 -- Is the given expression representable at runtime, based on the type?
 183 isRepr :: (CoreTools.TypedThing t) => t -> TransformMonad Bool
 184 isRepr tything = case CoreTools.getType tything of
 185   Nothing -> return False
 186   Just ty -> Trans.lift $ MonadState.lift tsType $ VHDLTools.isReprType ty
 187
 188 is_local_var :: CoreSyn.CoreExpr -> TranslatorSession Bool
 189 is_local_var (CoreSyn.Var v) = do
 190   bndrs <- getGlobalBinders
 191   return $ not $ v `elem` bndrs
 192 is_local_var _ = return False
 193
 194 -- Is the given binder defined by the user?
 195 isUserDefined :: CoreSyn.CoreBndr -> Bool
 196 -- System names are certain to not be user defined
 197 isUserDefined bndr | Name.isSystemName (Id.idName bndr) = False
 198 -- Check a list of typical compiler-defined names
 199 isUserDefined bndr = str `elem` compiler_names
 200   where
 201     str = Name.getOccString bndr
 202     -- These are names of bindings usually generated by the compiler. For some
 203     -- reason these are not marked as system, probably because the name itself
 204     -- is not made up by the compiler, just this particular binding is.
 205     compiler_names = ["fromInteger"]