X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=ad36bbcb950a28f292b7dfb9fde20f87013d7712;hb=969b7ddd86b69d2fc61b101961affcca0364749c;hp=aa8d0d9946c2eb11263d509544eea1ba2efe9dd5;hpb=29ee33754fc52a1a46fd44aba98a4dce8c81ce58;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index aa8d0d9..ad36bbc 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -1,6 +1,9 @@
 module Translator where
 import qualified Directory
+import qualified System.FilePath as FilePath
 import qualified List
+import Debug.Trace
+import qualified Control.Arrow as Arrow
 import GHC hiding (loadModule, sigName)
 import CoreSyn
 import qualified CoreUtils
@@ -8,10 +11,13 @@ import qualified Var
 import qualified Type
 import qualified TyCon
 import qualified DataCon
+import qualified HscMain
+import qualified SrcLoc
+import qualified FastString
 import qualified Maybe
 import qualified Module
-import qualified Control.Monad.State as State
 import qualified Data.Foldable as Foldable
+import qualified Control.Monad.Trans.State as State
 import Name
 import qualified Data.Map as Map
 import Data.Accessor
@@ -23,6 +29,7 @@ import MonadUtils ( liftIO )
 import Outputable ( showSDoc, ppr )
 import GHC.Paths ( libdir )
 import DynFlags ( defaultDynFlags )
+import qualified UniqSupply
 import List ( find )
 import qualified List
 import qualified Monad
@@ -40,14 +47,12 @@ import Text.PrettyPrint.HughesPJ (render)
 import TranslatorTypes
 import HsValueMap
 import Pretty
+import Normalize
 import Flatten
 import FlattenTypes
 import VHDLTypes
 import qualified VHDL
 
-main = do
-  makeVHDL "Alu.hs" "register_bank" True
-
 makeVHDL :: String -> String -> Bool -> IO ()
 makeVHDL filename name stateful = do
   -- Load the module
@@ -55,7 +60,8 @@ makeVHDL filename name stateful = do
   -- Translate to VHDL
   vhdl <- moduleToVHDL core [(name, stateful)]
   -- Write VHDL to file
-  let dir = "../vhdl/vhdl/" ++ name ++ "/"
+  let dir = "./vhdl/" ++ name ++ "/"
+  prepareDir dir
   mapM (writeVHDL dir) vhdl
   return ()
 
@@ -63,54 +69,58 @@ makeVHDL filename name stateful = do
 listBind :: String -> String -> IO ()
 listBind filename name = do
   core <- loadModule filename
-  let binds = findBinds core [name]
+  let [(b, expr)] = findBinds core [name]
   putStr "\n"
-  putStr $ prettyShow binds
+  putStr $ prettyShow expr
+  putStr "\n\n"
+  putStr $ showSDoc $ ppr expr
   putStr "\n\n"
-  putStr $ showSDoc $ ppr binds
+  putStr $ showSDoc $ ppr $ CoreUtils.exprType expr
   putStr "\n\n"
 
 -- | 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.CoreModule -> [(String, Bool)] -> IO [AST.DesignFile]
+moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
 moduleToVHDL core list = do
   let (names, statefuls) = unzip list
-  --liftIO $ putStr $ prettyShow (cm_binds core)
-  let binds = findBinds core names
-  --putStr $ prettyShow binds
+  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 (vhdl, sess) = State.runState (mkVHDL binds statefuls) (VHDLSession core 0 Map.empty)
-  mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
-  putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+  let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
+  let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls
+  let vhdl = VHDL.createDesignFiles normalized_bindings
+  mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
+  --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
   return vhdl
-
   where
-    -- Turns the given bind into VHDL
-    mkVHDL binds statefuls = do
-      -- Add the builtin functions
-      mapM addBuiltIn builtin_funcs
-      -- Create entities and architectures for them
-      Monad.zipWithM processBind statefuls binds
-      modFuncMap $ Map.map (fdFlatFunc ^: (fmap nameFlatFunction))
-      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdEntity ^= (VHDL.createEntity hsfunc fdata) $ fdata)
-      funcs <- getFuncMap
-      modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdArch ^= (VHDL.createArchitecture funcs hsfunc fdata) $ fdata)
-      funcs <- getFuncs
-      return $ VHDL.getDesignFiles (map snd funcs)
 
--- | Write the given design file to a file inside the given dir
---   The first library unit in the designfile must be an entity, whose name
---   will be used as a filename.
-writeVHDL :: String -> AST.DesignFile -> IO ()
-writeVHDL dir vhdl = do
+-- | Prepares the directory for writing VHDL files. This means creating the
+--   dir if it does not exist and removing all existing .vhdl files from it.
+prepareDir :: String -> IO()
+prepareDir dir = do
   -- Create the dir if needed
   exists <- Directory.doesDirectoryExist dir
   Monad.unless exists $ Directory.createDirectory dir
+  -- Find all .vhdl files in the directory
+  files <- Directory.getDirectoryContents dir
+  let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
+  -- Prepend the dirname to the filenames
+  let abs_to_remove = map (FilePath.combine dir) to_remove
+  -- Remove the files
+  mapM_ Directory.removeFile abs_to_remove
+
+-- | Write the given design file to a file with the given name inside the
+--   given dir
+writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
+writeVHDL dir (name, vhdl) = do
   -- Find the filename
-  let AST.DesignFile _ (u:us) = vhdl
-  let AST.LUEntity (AST.EntityDec id _) = u
-  let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
+  let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
   -- Write the file
   ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
 
@@ -127,60 +137,39 @@ loadModule filename =
       --setTargets [target]
       --load LoadAllTargets
       --core <- GHC.compileToCoreSimplified "Adders.hs"
-      core <- GHC.compileToCoreSimplified filename
+      core <- GHC.compileToCoreModule filename
       return core
 
 -- | Extracts the named binds from the given module.
-findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
-findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
+findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
+findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
 
 -- | Extract a named bind from the given list of binds
-findBind :: [CoreBind] -> String -> Maybe CoreBind
+findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
 findBind binds lookfor =
   -- This ignores Recs and compares the name of the bind with lookfor,
   -- disregarding any namespaces in OccName and extra attributes in Name and
   -- Var.
-  find (\b -> case b of 
-    Rec l -> False
-    NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
-  ) binds
-
--- | Processes the given bind as a top level bind.
-processBind ::
-  Bool                       -- ^ Should this be stateful function?
-  -> CoreBind                -- ^ The bind to process
-  -> TranslatorState ()
-
-processBind _ (Rec _) = error "Recursive binders not supported"
-processBind stateful bind@(NonRec var expr) = do
-  -- Create the function signature
-  let ty = CoreUtils.exprType expr
-  let hsfunc = mkHsFunction var ty stateful
-  flattenBind hsfunc bind
+  find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
 
 -- | Flattens the given bind into the given signature and adds it to the
 --   session. Then (recursively) finds any functions it uses and does the same
 --   with them.
 flattenBind ::
   HsFunction                         -- The signature to flatten into
-  -> CoreBind                        -- The bind to flatten
+  -> (CoreBndr, CoreExpr)            -- The bind to flatten
   -> TranslatorState ()
 
-flattenBind _ (Rec _) = error "Recursive binders not supported"
-
-flattenBind hsfunc bind@(NonRec var expr) = do
-  -- Add the function to the session
-  addFunc hsfunc
+flattenBind hsfunc bind@(var, expr) = do
   -- Flatten the function
   let flatfunc = flattenFunction hsfunc bind
   -- Propagate state variables
   let flatfunc' = propagateState hsfunc flatfunc
   -- Store the flat function in the session
-  setFlatFunc hsfunc flatfunc'
+  modA tsFlatFuncs (Map.insert hsfunc flatfunc')
   -- Flatten any functions used
   let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
-  State.mapM resolvFunc used_hsfuncs
-  return ()
+  mapM_ resolvFunc used_hsfuncs
 
 -- | Decide which incoming state variables will become state in the
 --   given function, and which will be propagate to other applied
@@ -276,23 +265,19 @@ resolvFunc ::
   -> TranslatorState ()
 
 resolvFunc hsfunc = do
-  -- See if the function is already known
-  func <- getFunc hsfunc
-  case func of
-    -- Already known, do nothing
-    Just _ -> do
-      return ()
-    -- New function, resolve it
-    Nothing -> do
-      -- Get the current module
-      core <- getModule
-      -- Find the named function
-      let bind = findBind (cm_binds core) name
-      case bind of
-        Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
-        Just b  -> flattenBind hsfunc b
-  where
-    name = hsFuncName hsfunc
+  flatfuncmap <- getA tsFlatFuncs
+  -- Don't do anything if there is already a flat function for this hsfunc or
+  -- when it is a builtin function.
+  Monad.unless (Map.member hsfunc flatfuncmap) $ do
+  -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+  -- New function, resolve it
+  core <- getA tsCoreModule
+  -- Find the named function
+  let name = (hsFuncName hsfunc)
+  let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name 
+  case bind of
+    Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+    Just b  -> flattenBind hsfunc b
 
 -- | Translate a top level function declaration to a HsFunction. i.e., which
 --   interface will be provided by this function. This function essentially
@@ -366,32 +351,4 @@ splitTupleType ty =
         Nothing
     Nothing -> Nothing
 
--- | A consise representation of a (set of) ports on a builtin function
-type PortMap = HsValueMap (String, AST.TypeMark)
--- | A consise representation of a builtin function
-data BuiltIn = BuiltIn String [PortMap] PortMap
-
--- | Map a port specification of a builtin function to a VHDL Signal to put in
---   a VHDLSignalMap
-toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
-toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
-
--- | Translate a concise representation of a builtin function to something
---   that can be put into FuncMap directly.
-addBuiltIn :: BuiltIn -> TranslatorState ()
-addBuiltIn (BuiltIn name args res) = do
-    addFunc hsfunc
-    setEntity hsfunc entity
-  where
-    hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
-    entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing Nothing
-
-builtin_funcs = 
-  [ 
-    BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
-    BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
-    BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
-    BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
-  ]
-
 -- vim: set ts=8 sw=2 sts=2 expandtab: