From: Matthijs Kooijman <m.kooijman@student.utwente.nl>
Date: Fri, 31 Jul 2009 09:26:59 +0000 (+0200)
Subject: Merge branch 'master' of git://github.com/christiaanb/clash into cλash
X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=4b87be0b9d499155084a6240b016afd57b4b30cd;hp=-c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

Merge branch 'master' of git://github.com/christiaanb/clash into cλash

* 'master' of git://github.com/christiaanb/clash:
  Quick hack implementation of FSVec literals, needs to be fixed
  We need the latest vhdl package
  We now make a show function for all default datatypes.
  Add automated testbench generation according to supplied test input

Conflicts:
	cλash/CLasH/Translator.hs
---

4b87be0b9d499155084a6240b016afd57b4b30cd
diff --combined "c\316\273ash/CLasH/Translator.hs"
index caa0207,c35e338..a347143
--- "a/c\316\273ash/CLasH/Translator.hs"
+++ "b/c\316\273ash/CLasH/Translator.hs"
@@@ -53,27 -53,29 +53,29 @@@ import CLasH.Translator.Annotation
  import CLasH.Utils.Pretty
  import CLasH.Normalize
  import CLasH.VHDL.VHDLTypes
+ import CLasH.Utils.Core.CoreTools
  import qualified CLasH.VHDL as VHDL
  
- makeVHDL :: FilePath -> String -> String -> Bool -> IO ()
- makeVHDL libdir filename name stateful = do
-   -- Load the module
-   (core, env) <- loadModule libdir filename
-   -- Translate to VHDL
-   vhdl <- moduleToVHDL env core [(name, stateful)]
-   -- Write VHDL to file
-   let dir = "./vhdl/" ++ name ++ "/"
-   prepareDir dir
-   mapM (writeVHDL dir) vhdl
-   return ()
+ -- makeVHDL :: FilePath -> String -> String -> Bool -> IO ()
+ -- makeVHDL libdir filename name stateful = do
+ --   -- Load the module
+ --   (core, env) <- loadModule libdir filename
+ --   -- Translate to VHDL
+ --   vhdl <- moduleToVHDL env core [(name, stateful)]
+ --   -- Write VHDL to file
+ --   let dir = "./vhdl/" ++ name ++ "/"
+ --   prepareDir dir
+ --   mapM (writeVHDL dir) vhdl
+ --   return ()
    
  makeVHDLAnn :: FilePath -> String -> IO ()
  makeVHDLAnn libdir filename = do
-   (core, top, init, env) <- loadModuleAnn libdir filename
+   (core, top, init, test, env) <- loadModuleAnn libdir filename
    let top_entity = head top
+   let test_expr = head test
    vhdl <- case init of 
-     [] -> moduleToVHDLAnn env core [top_entity]
-     xs -> moduleToVHDLAnnState env core [(top_entity, (head xs))]
+     [] -> moduleToVHDLAnn env core (top_entity, test_expr)
+     xs -> moduleToVHDLAnnState env core (top_entity, test_expr, (head xs))
    let dir = "./vhdl/" ++ (show top_entity) ++ "/"
    prepareDir dir
    mapM (writeVHDL dir) vhdl
@@@ -89,13 -91,11 +91,13 @@@ listBinding :: (CoreBndr, CoreExpr) -> 
  listBinding (b, e) = do
    putStr "\nBinder: "
    putStr $ show b
 -  putStr "\nExpression: \n"
 +  putStr "\nType of Binder: \n"
 +  putStr $ showSDoc $ ppr $ Var.varType b
 +  putStr "\n\nExpression: \n"
    putStr $ prettyShow e
    putStr "\n\n"
    putStr $ showSDoc $ ppr e
 -  putStr "\n\n"
 +  putStr "\n\nType of Expression: \n"
    putStr $ showSDoc $ ppr $ CoreUtils.exprType e
    putStr "\n\n"
    
@@@ -104,31 -104,37 +106,31 @@@ listBind :: FilePath -> String -> Strin
  listBind libdir filename name = do
    (core, env) <- loadModule libdir filename
    let [(b, expr)] = findBinds core [name]
 -  putStr "\n"
 -  putStr $ prettyShow expr
 -  putStr "\n\n"
 -  putStr $ showSDoc $ ppr expr
 -  putStr "\n\n"
 -  putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
 -  putStr "\n\n"  
 +  listBinding (b, expr)
  
  -- | Translate the binds with the given names from the given core module to
  --   VHDL. The Bool in the tuple makes the function stateful (True) or
  --   stateless (False).
- moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
- moduleToVHDL env core list = do
-   let (names, statefuls) = unzip list
-   let binds = map fst $ findBinds core names
-   -- Generate a UniqSupply
-   -- Running 
-   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
-   -- on the compiler dir of ghc suggests that 'z' is not used to generate a
-   -- unique supply anywhere.
-   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
-   -- Turn bind into VHDL
-   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
-   let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
-   let vhdl = VHDL.createDesignFiles typestate normalized_bindings
-   mapM (putStr . render . Ppr.ppr . snd) vhdl
-   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
-   return vhdl
+ -- moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
+ -- moduleToVHDL env core list = do
+ --   let (names, statefuls) = unzip list
+ --   let binds = map fst $ findBinds core names
+ --   -- Generate a UniqSupply
+ --   -- Running 
+ --   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+ --   -- on the compiler dir of ghc suggests that 'z' is not used to generate a
+ --   -- unique supply anywhere.
+ --   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ --   -- Turn bind into VHDL
+ --   let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+ --   let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
+ --   let vhdl = VHDL.createDesignFiles typestate normalized_bindings binds
+ --   mapM (putStr . render . Ppr.ppr . snd) vhdl
+ --   --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+ --   return vhdl
    
- moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> [CoreSyn.CoreBndr] -> IO [(AST.VHDLId, AST.DesignFile)]
- moduleToVHDLAnn env core binds = do
+ moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO [(AST.VHDLId, AST.DesignFile)]
+ moduleToVHDLAnn env core (topbind, test) = do
    -- Generate a UniqSupply
    -- Running 
    --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
@@@ -137,15 -143,15 +139,15 @@@
    uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
    -- Turn bind into VHDL
    let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
-   let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [False]
-   let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+   let testexprs = reduceCoreListToHsList test
+   let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [False]
+   let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
    mapM (putStr . render . Ppr.ppr . snd) vhdl
    --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
    return vhdl
    
- moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)] -> IO [(AST.VHDLId, AST.DesignFile)]
- moduleToVHDLAnnState env core list = do
-   let (binds, init_states) = unzip list
+ moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr, CoreSyn.CoreBndr) -> IO [(AST.VHDLId, AST.DesignFile)]
+ moduleToVHDLAnnState env core (topbind, test, init_state) = do
    -- Generate a UniqSupply
    -- Running 
    --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
@@@ -154,8 -160,9 +156,9 @@@
    uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
    -- Turn bind into VHDL
    let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
-   let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds [True]
-   let vhdl = VHDL.createDesignFiles typestate normalized_bindings
+   let testexprs = reduceCoreListToHsList test
+   let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [True]
+   let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
    mapM (putStr . render . Ppr.ppr . snd) vhdl
    --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
    return vhdl
@@@ -202,7 -209,7 +205,7 @@@ loadModule libdir filename 
        return (core, env)
        
  -- | Loads the given file and turns it into a core module.
- loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], HscTypes.HscEnv)
+ loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], [CoreSyn.CoreExpr], HscTypes.HscEnv)
  loadModuleAnn libdir filename =
    defaultErrorHandler defaultDynFlags $ do
      runGhc (Just libdir) $ do
@@@ -218,7 -225,8 +221,8 @@@
        env <- GHC.getSession
        top_entity <- findTopEntity core
        init_state <- findInitState core
-       return (core, top_entity, init_state, env)
+       test_input <- findTestInput core
+       return (core, top_entity, init_state, test_input, env)
  
  findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
  findTopEntity core = do
@@@ -234,6 -242,13 +238,13 @@@ findInitState core = d
    let bndrs = case statebinds of [] -> [] ; xs -> fst (unzip statebinds)
    return bndrs
    
+ findTestInput :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreExpr]
+ findTestInput core = do
+   let binds = CoreSyn.flattenBinds $ cm_binds core
+   testbinds <- Monad.filterM (hasTestInputAnnotation . fst) binds
+   let exprs = case testbinds of [] -> [] ; xs -> snd (unzip testbinds)
+   return exprs
+   
  hasTopEntityAnnotation :: GhcMonad m => Var.Var -> m Bool
  hasTopEntityAnnotation var = do
    let deserializer = Serialized.deserializeWithData
@@@ -253,6 -268,16 +264,16 @@@ hasInitStateAnnotation var = d
    case top_ents of
      [] -> return False
      xs -> return True
+     
+ hasTestInputAnnotation :: GhcMonad m => Var.Var -> m Bool
+ hasTestInputAnnotation var = do
+   let deserializer = Serialized.deserializeWithData
+   let target = Annotations.NamedTarget (Var.varName var)
+   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
+   let top_ents = filter isTestInput anns
+   case top_ents of
+     [] -> return False
+     xs -> return True
  
  -- | Extracts the named binds from the given module.
  findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]