module Translator where
import qualified Directory
import qualified List
+import Debug.Trace
+import qualified Control.Arrow as Arrow
import GHC hiding (loadModule, sigName)
import CoreSyn
import qualified CoreUtils
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 Data.Foldable as Foldable
import Outputable ( showSDoc, ppr )
import GHC.Paths ( libdir )
import DynFlags ( defaultDynFlags )
+import qualified UniqSupply
import List ( find )
import qualified List
import qualified Monad
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
-- Translate to VHDL
vhdl <- moduleToVHDL core [(name, stateful)]
-- Write VHDL to file
- let dir = "../vhdl/vhdl/" ++ name ++ "/"
+ let dir = "./vhdl/" ++ name ++ "/"
mapM (writeVHDL dir) vhdl
return ()
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
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) (TranslatorSession core 0 Map.empty)
+ 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"
+ --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
return vhdl
where
- -- Turns the given bind into VHDL
- mkVHDL :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
- mkVHDL binds statefuls = do
- -- Add the builtin functions
- --mapM addBuiltIn builtin_funcs
- -- Create entities and architectures for them
- Monad.zipWithM processBind statefuls binds
- modA tsFlatFuncs (Map.map nameFlatFunction)
- flatfuncs <- getA tsFlatFuncs
- return $ VHDL.createDesignFiles flatfuncs
-- | Write the given design file to a file with the given name inside the
-- given dir
--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
+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
- modA tsFlatFuncs (Map.insert hsfunc flatfunc)
+ modA tsFlatFuncs (Map.insert hsfunc flatfunc')
-- Flatten any functions used
let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
mapM_ resolvFunc used_hsfuncs
-- 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
- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
- -- TODO: Builtin functions
+ -- 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 (cm_binds core) name
+ 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