Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project

[matthijs/master-project/cλash.git] / cλash / CLasH / Utils / Core / CoreTools.hs

diff --git a/cλash/CLasH/Utils/Core/CoreTools.hs b/cλash/CLasH/Utils/Core/CoreTools.hs
index b4808026fe37958e0d34d81baf70a229a83a5517..d8f4289d28b25253544126ba0424f90f6fc842de 100644 (file)
--- a/cλash/CLasH/Utils/Core/CoreTools.hs
+++ b/cλash/CLasH/Utils/Core/CoreTools.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternGuards, TypeSynonymInstances #-}

 -- | This module provides a number of functions to find out things about Core
 -- programs. This module does not provide the actual plumbing to work with
 -- Core and Haskell (it uses HsTools for this), but only the functions that
 -- | This module provides a number of functions to find out things about Core
 -- programs. This module does not provide the actual plumbing to work with
 -- Core and Haskell (it uses HsTools for this), but only the functions that


@@ -19,12 +20,17 @@ import qualified HscTypes
 import qualified RdrName
 import qualified Name
 import qualified OccName
 import qualified RdrName
 import qualified Name
 import qualified OccName

+import qualified Type
+import qualified Id
+import qualified TyCon
+import qualified DataCon

 import qualified TysWiredIn
 import qualified Bag
 import qualified DynFlags
 import qualified SrcLoc
 import qualified CoreSyn
 import qualified Var
 import qualified TysWiredIn
 import qualified Bag
 import qualified DynFlags
 import qualified SrcLoc
 import qualified CoreSyn
 import qualified Var

+import qualified IdInfo

 import qualified VarSet
 import qualified Unique
 import qualified CoreUtils
 import qualified VarSet
 import qualified Unique
 import qualified CoreUtils


@@ -32,10 +38,14 @@ import qualified CoreFVs
 import qualified Literal
 
 -- Local imports
 import qualified Literal
 
 -- Local imports

+import CLasH.Translator.TranslatorTypes

 import CLasH.Utils.GhcTools
 import CLasH.Utils.HsTools
 import CLasH.Utils.Pretty
 
 import CLasH.Utils.GhcTools
 import CLasH.Utils.HsTools
 import CLasH.Utils.Pretty
 

+-- | A single binding, used as a shortcut to simplify type signatures.
+type Binding = (CoreSyn.CoreBndr, CoreSyn.CoreExpr)
+

 -- | Evaluate a core Type representing type level int from the tfp
 -- library to a real int.
 eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int
 -- | Evaluate a core Type representing type level int from the tfp
 -- library to a real int.
 eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int


@@ -183,6 +193,10 @@ has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isT
 has_free_vars :: CoreSyn.CoreExpr -> Bool
 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
 
 has_free_vars :: CoreSyn.CoreExpr -> Bool
 has_free_vars = not . VarSet.isEmptyVarSet . CoreFVs.exprFreeVars
 

+-- Does the given expression use any of the given binders?
+expr_uses_binders :: [CoreSyn.CoreBndr] -> CoreSyn.CoreExpr -> Bool
+expr_uses_binders bndrs = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars (`elem` bndrs))
+

 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 -- simple Var CoreExprs, not complexer ones.
 exprToVar :: CoreSyn.CoreExpr -> Var.Id
 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
 -- simple Var CoreExprs, not complexer ones.
 exprToVar :: CoreSyn.CoreExpr -> Var.Id


@@ -212,13 +226,89 @@ getLiterals app@(CoreSyn.App _ _) = literals
     (CoreSyn.Var f, args) = CoreSyn.collectArgs app
     literals = filter (is_lit) args
 
     (CoreSyn.Var f, args) = CoreSyn.collectArgs app
     literals = filter (is_lit) args
 

-reduceCoreListToHsList :: CoreSyn.CoreExpr -> [CoreSyn.CoreExpr]
-reduceCoreListToHsList app@(CoreSyn.App _ _) = out
+getLiterals lit@(CoreSyn.Lit _) = [lit]
+
+reduceCoreListToHsList :: 
+  [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden
+  -> CoreSyn.CoreExpr   -- ^ The refence to atleast one of the nodes
+  -> TranslatorSession [CoreSyn.CoreExpr]
+reduceCoreListToHsList cores app@(CoreSyn.App _ _) = do {
+  ; let { (fun, args) = CoreSyn.collectArgs app
+        ; len         = length args 
+        } ;
+  ; case len of
+      3 -> do {
+        ; let topelem = args!!1
+        ; case (args!!2) of
+            (varz@(CoreSyn.Var id)) -> do {
+              ; binds <- mapM (findExpr (isVarName id)) cores
+              ; otherelems <- reduceCoreListToHsList cores (head (Maybe.catMaybes binds))
+              ; return (topelem:otherelems)
+              }
+            (appz@(CoreSyn.App _ _)) -> do {
+              ; otherelems <- reduceCoreListToHsList cores appz
+              ; return (topelem:otherelems)
+              }
+            otherwise -> return [topelem]
+        }
+      otherwise -> return []
+  }

   where
   where

-    (fun, args) = CoreSyn.collectArgs app
-    len = length args
-    out = case len of
-          3 -> ((args!!1) : (reduceCoreListToHsList (args!!2)))
-          otherwise -> []
+    isVarName :: Monad m => Var.Var -> Var.Var -> m Bool
+    isVarName lookfor bind = return $ (Var.varName lookfor) == (Var.varName bind)
+
+reduceCoreListToHsList _ _ = return []
+
+-- Is the given var the State data constructor?
+isStateCon :: Var.Var -> Bool
+isStateCon var = do
+  -- See if it is a DataConWrapId (not DataConWorkId, since State is a
+  -- newtype).
+  case Id.idDetails var of
+    IdInfo.DataConWrapId dc -> 
+      -- See if the datacon is the State datacon from the State type.
+      let tycon = DataCon.dataConTyCon dc
+          tyname = Name.getOccString tycon
+          dcname = Name.getOccString dc
+      in case (tyname, dcname) of
+        ("State", "State") -> True
+        _ -> False
+    _ -> False
+
+-- | Is the given type a State type?
+isStateType :: Type.Type -> Bool
+-- Resolve any type synonyms remaining
+isStateType ty | Just ty' <- Type.tcView ty = isStateType ty'
+isStateType ty  = Maybe.isJust $ do
+  -- Split the type. Don't use normal splitAppTy, since that looks through
+  -- newtypes, and we want to see the State newtype.
+  (typef, _) <- Type.repSplitAppTy_maybe ty
+  -- See if the applied type is a type constructor
+  (tycon, _) <- Type.splitTyConApp_maybe typef
+  if TyCon.isNewTyCon tycon && Name.getOccString tycon == "State"
+    then
+      Just ()
+    else
+      Nothing
+
+-- | Does the given TypedThing have a State type?
+hasStateType :: (TypedThing t) => t -> Bool
+hasStateType expr = case getType expr of
+  Nothing -> False
+  Just ty -> isStateType ty
+
+
+-- | A class of things that (optionally) have a core Type. The type is
+-- optional, since Type expressions don't have a type themselves.
+class TypedThing t where
+  getType :: t -> Maybe Type.Type
+
+instance TypedThing CoreSyn.CoreExpr where
+  getType (CoreSyn.Type _) = Nothing
+  getType expr = Just $ CoreUtils.exprType expr
+
+instance TypedThing CoreSyn.CoreBndr where
+  getType = return . Id.idType

 
 

-reduceCoreListToHsList _ = []
+instance TypedThing Type.Type where
+  getType = return . id