update cabal file to upload to hackage
[matthijs/master-project/cλash.git] / cλash / CLasH / Translator.hs
1 module CLasH.Translator 
2   (
3    makeVHDLAnnotations
4   ) where
5
6 -- Standard Modules
7 import qualified System.Directory as Directory
8 import qualified Maybe
9 import qualified Monad
10 import qualified System.FilePath as FilePath
11 import qualified Control.Monad.Trans.State as State
12 import Text.PrettyPrint.HughesPJ (render)
13 import Data.Accessor.Monad.Trans.State
14 import qualified Data.Map as Map
15 import qualified Data.Time.Clock as Clock
16 import Debug.Trace
17
18 -- GHC API
19 import qualified CoreSyn
20 import qualified HscTypes
21 import qualified UniqSupply
22
23 -- VHDL Imports
24 import qualified Language.VHDL.AST as AST
25 import qualified Language.VHDL.FileIO as FileIO
26 import qualified Language.VHDL.Ppr as Ppr
27
28 -- Local Imports
29 import CLasH.Translator.TranslatorTypes
30 import CLasH.Translator.Annotations
31 import CLasH.Utils
32 import CLasH.Utils.GhcTools
33 import CLasH.VHDL
34 import CLasH.VHDL.VHDLTools
35 import CLasH.VHDL.Testbench
36
37 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
38 --   and Test Inputs found in the Files. 
39 makeVHDLAnnotations :: 
40   FilePath      -- ^ The GHC Library Dir
41   -> [FilePath] -- ^ The FileNames
42   -> IO ()
43 makeVHDLAnnotations libdir filenames =
44   makeVHDL libdir filenames finder
45     where
46       finder = findSpec (hasCLasHAnnotation isTopEntity)
47                         (hasCLasHAnnotation isInitState)
48                         (isCLasHAnnotation isInitState)
49                         (hasCLasHAnnotation isTestInput)
50
51 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
52 --   Entity, Initial State and Test Inputs in the Haskell Files.
53 makeVHDL ::
54   FilePath      -- ^ The GHC Library Dir
55   -> [FilePath] -- ^ The Filenames
56   -> Finder
57   -> IO ()
58 makeVHDL libdir filenames finder = do
59   start <- Clock.getCurrentTime
60   -- Load the modules
61   (cores, env, specs) <- loadModules libdir filenames (Just finder)
62   -- Translate to VHDL
63   vhdl <- moduleToVHDL env cores specs
64   -- Write VHDL to file. Just use the first entity for the name
65   let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
66   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
67   prepareDir dir
68   mapM_ (writeVHDL dir) vhdl
69   end <- Clock.getCurrentTime
70   trace ("\nTotal compilation took " ++ show (Clock.diffUTCTime end start)) $
71     return ()
72
73 -- | Translate the specified entities in the given modules to VHDL.
74 moduleToVHDL ::
75   HscTypes.HscEnv             -- ^ The GHC Environment
76   -> [HscTypes.CoreModule]    -- ^ The Core Modules
77   -> [EntitySpec]             -- ^ The entities to generate
78   -> IO [(AST.VHDLId, AST.DesignFile)]
79 moduleToVHDL env cores specs = do
80   (vhdl, count) <- runTranslatorSession env $ do
81     let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores
82     -- Store the bindings we loaded
83     tsBindings %= Map.fromList all_bindings
84     let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs 
85     tsInitStates %= Map.fromList all_initstates
86     test_binds <- catMaybesM $ Monad.mapM mkTest specs
87     let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
88     vhdl <- case topbinds of
89       []  -> error "Could not find top entity requested"
90       tops -> createDesignFiles (tops ++ test_binds)
91     count <- get tsTransformCounter 
92     return (vhdl, count)
93   mapM_ (putStr . render . Ppr.ppr . snd) vhdl
94   putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
95   return vhdl
96   where
97     mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
98     -- Create a testbench for any entry that has test input
99     mkTest (_, _, Nothing) = return Nothing
100     mkTest (Nothing, _, _) = return Nothing
101     mkTest (Just top, _, Just input) = do
102       bndr <- createTestbench Nothing cores input top
103       return $ Just bndr
104
105 -- Run the given translator session. Generates a new UniqSupply for that
106 -- session.
107 runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
108 runTranslatorSession env session = do
109   -- Generate a UniqSupply
110   -- Running 
111   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
112   -- on the compiler dir of ghc suggests that 'z' is not used to generate
113   -- a unique supply anywhere.
114   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
115   let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
116   let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0
117   return $ State.evalState session init_state
118
119 -- | Prepares the directory for writing VHDL files. This means creating the
120 --   dir if it does not exist and removing all existing .vhdl files from it.
121 prepareDir :: String -> IO()
122 prepareDir dir = do
123   -- Create the dir if needed
124   Directory.createDirectoryIfMissing True dir
125   -- Find all .vhdl files in the directory
126   files <- Directory.getDirectoryContents dir
127   let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
128   -- Prepend the dirname to the filenames
129   let abs_to_remove = map (FilePath.combine dir) to_remove
130   -- Remove the files
131   mapM_ Directory.removeFile abs_to_remove
132
133 -- | Write the given design file to a file with the given name inside the
134 --   given dir
135 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
136 writeVHDL dir (name, vhdl) = do
137   -- Find the filename
138   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
139   -- Write the file
140   FileIO.writeDesignFile vhdl fname
141
142 -- vim: set ts=8 sw=2 sts=2 expandtab: