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 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
import Data.Generics
import NameEnv ( lookupNameEnv )
import qualified HscTypes
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 "Adders.hs" "highordtest2" True
makeVHDL :: String -> String -> Bool -> IO ()
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 ++ "/"
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 binds
+ putStr $ showSDoc $ ppr expr
+ putStr "\n\n"
+ 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
+ -- 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
+ let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty)
+ 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
+ mkVHDL :: UniqSupply.UniqSupply -> [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
+ mkVHDL uniqSupply binds statefuls = do
+ let binds'' = map (Arrow.second $ normalize uniqSupply) binds
+ let binds' = trace ("Before:\n\n" ++ showSDoc ( ppr binds ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr binds'')) binds''
-- Add the builtin functions
- mapM addBuiltIn builtin_funcs
+ --mapM addBuiltIn builtin_funcs
-- Create entities and architectures for them
- Monad.zipWithM processBind statefuls binds
- modFuncMap $ Map.map (\fdata -> fdata {flatFunc = fmap nameFlatFunction (flatFunc fdata)})
- modFuncMap $ Map.mapWithKey (\hsfunc fdata -> fdata {funcEntity = VHDL.createEntity hsfunc fdata})
- modFuncs VHDL.createArchitecture
- 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
+ --Monad.zipWithM processBind statefuls binds
+ --modA tsFlatFuncs (Map.map nameFlatFunction)
+ --flatfuncs <- getA tsFlatFuncs
+ return $ VHDL.createDesignFiles binds'
+
+-- | 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
-- Create the dir if needed
exists <- Directory.doesDirectoryExist dir
Monad.unless exists $ Directory.createDirectory dir
-- 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
--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
+ find (\(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
- -> VHDLState ()
+ -> (CoreBndr, CoreExpr) -- ^ The bind to process
+ -> TranslatorState ()
-processBind _ (Rec _) = error "Recursive binders not supported"
-processBind stateful bind@(NonRec var expr) = do
+processBind stateful bind@(var, expr) = do
-- Create the function signature
let ty = CoreUtils.exprType expr
let hsfunc = mkHsFunction var ty stateful
-- with them.
flattenBind ::
HsFunction -- The signature to flatten into
- -> CoreBind -- The bind to flatten
- -> VHDLState ()
+ -> (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
-- (recursively) do the same for any functions used.
resolvFunc ::
HsFunction -- | The function to look for
- -> VHDLState ()
+ -> 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
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 -> VHDLState ()
-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:
projects / matthijs / master-project / cλash.git / blobdiff