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