X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=d11d29e4d09559c97528c8a8e8c09f3520da4589;hb=56b4b2edb9bd1d06cafefc12a06feb7ef5622291;hp=8d69ea2626396094202437afc6c7ca570c123c42;hpb=2f1cf3a17e4d206c01031b3117779e99d21a4dce;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Translator.hs b/Translator.hs index 8d69ea2..d11d29e 100644 --- a/Translator.hs +++ b/Translator.hs @@ -1,5 +1,5 @@ module Translator where -import GHC +import GHC hiding (loadModule, sigName) import CoreSyn import qualified CoreUtils import qualified Var @@ -10,8 +10,10 @@ import qualified Maybe import qualified Module import qualified Control.Monad.State as State import Name +import qualified Data.Map as Map import Data.Generics import NameEnv ( lookupNameEnv ) +import qualified HscTypes import HscTypes ( cm_binds, cm_types ) import MonadUtils ( liftIO ) import Outputable ( showSDoc, ppr ) @@ -32,43 +34,92 @@ import qualified ForSyDe.Backend.Ppr import Text.PrettyPrint.HughesPJ (render) import TranslatorTypes +import HsValueMap import Pretty import Flatten +import FlattenTypes +import VHDLTypes import qualified VHDL -main = - do - defaultErrorHandler defaultDynFlags $ do - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - setSessionDynFlags dflags - --target <- guessTarget "adder.hs" Nothing - --liftIO (print (showSDoc (ppr (target)))) - --liftIO $ printTarget target - --setTargets [target] - --load LoadAllTargets - --core <- GHC.compileToCoreSimplified "Adders.hs" - core <- GHC.compileToCoreSimplified "Adders.hs" - --liftIO $ printBinds (cm_binds core) - let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"] - liftIO $ putStr $ prettyShow binds - -- Turn bind into VHDL - let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession 0 []) - liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl - liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl" - liftIO $ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" - return () +main = do + makeVHDL "Alu.hs" "register_bank" + +makeVHDL :: String -> String -> IO () +makeVHDL filename name = do + -- Load the module + core <- loadModule filename + -- Translate to VHDL + vhdl <- moduleToVHDL core [name] + -- Write VHDL to file + mapM (writeVHDL "../vhdl/vhdl/") vhdl + return () + +-- | Show the core structure of the given binds in the given file. +listBind :: String -> String -> IO () +listBind filename name = do + core <- loadModule filename + let binds = findBinds core [name] + putStr "\n" + putStr $ prettyShow binds + putStr $ showSDoc $ ppr binds + putStr "\n\n" + +-- | Translate the binds with the given names from the given core module to +-- VHDL +moduleToVHDL :: HscTypes.CoreModule -> [String] -> IO [AST.DesignFile] +moduleToVHDL core names = do + --liftIO $ putStr $ prettyShow (cm_binds core) + let binds = findBinds core names + --putStr $ prettyShow binds + -- Turn bind into VHDL + let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty) + mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl + putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n" + return vhdl + where -- Turns the given bind into VHDL mkVHDL binds = do -- Add the builtin functions - --mapM (uncurry addFunc) builtin_funcs + mapM addBuiltIn builtin_funcs -- Create entities and architectures for them - mapM flattenBind binds - return $ AST.DesignFile - [] - [] + mapM processBind binds + modFuncs nameFlatFunction + modFuncs VHDL.createEntity + modFuncs VHDL.createArchitecture + VHDL.getDesignFiles + +-- | 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 + let AST.DesignFile _ (u:us) = vhdl + let AST.LUEntity (AST.EntityDec id _) = u + let fname = dir ++ AST.fromVHDLId id ++ ".vhdl" + ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname + +-- | Loads the given file and turns it into a core module. +loadModule :: String -> IO HscTypes.CoreModule +loadModule filename = + defaultErrorHandler defaultDynFlags $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + --target <- guessTarget "adder.hs" Nothing + --liftIO (print (showSDoc (ppr (target)))) + --liftIO $ printTarget target + --setTargets [target] + --load LoadAllTargets + --core <- GHC.compileToCoreSimplified "Adders.hs" + core <- GHC.compileToCoreSimplified 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 + +-- | Extract a named bind from the given list of binds findBind :: [CoreBind] -> String -> Maybe CoreBind findBind binds lookfor = -- This ignores Recs and compares the name of the bind with lookfor, @@ -79,24 +130,34 @@ findBind binds lookfor = NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var) ) binds --- | Flattens the given bind and adds it to the session. Then (recursively) --- finds any functions it uses and does the same with them. -flattenBind :: - CoreBind -- The binder to flatten +-- | Processes the given bind as a top level bind. +processBind :: + CoreBind -- The bind to process -> VHDLState () -flattenBind (Rec _) = error "Recursive binders not supported" - -flattenBind bind@(NonRec var expr) = do +processBind (Rec _) = error "Recursive binders not supported" +processBind bind@(NonRec var expr) = do -- Create the function signature let ty = CoreUtils.exprType expr let hsfunc = mkHsFunction var ty - --hwfunc <- mkHWFunction bind hsfunc - -- Add it to the session - --addFunc hsfunc hwfunc + flattenBind hsfunc bind + +-- | 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 + -> VHDLState () + +flattenBind _ (Rec _) = error "Recursive binders not supported" + +flattenBind hsfunc bind@(NonRec var expr) = do + -- Flatten the function let flatfunc = flattenFunction hsfunc bind - addFunc hsfunc flatfunc - let used_hsfuncs = map appFunc (apps flatfunc) + addFunc hsfunc + setFlatFunc hsfunc flatfunc + let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc) State.mapM resolvFunc used_hsfuncs return () @@ -106,8 +167,24 @@ resolvFunc :: HsFunction -- | The function to look for -> VHDLState () -resolvFunc hsfunc = - return () +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 -- | Translate a top level function declaration to a HsFunction. i.e., which -- interface will be provided by this function. This function essentially @@ -137,6 +214,31 @@ mkHsFunction f ty = error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty) otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports." +-- | Adds signal names to the given FlatFunction +nameFlatFunction :: + HsFunction + -> FuncData + -> VHDLState () + +nameFlatFunction hsfunc fdata = + let func = flatFunc fdata in + case func of + -- Skip (builtin) functions without a FlatFunction + Nothing -> do return () + -- Name the signals in all other functions + Just flatfunc -> + let s = flat_sigs flatfunc in + let s' = map nameSignal s in + let flatfunc' = flatfunc { flat_sigs = s' } in + setFlatFunc hsfunc flatfunc' + where + nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo) + nameSignal (id, info) = + let hints = nameHints info in + let parts = ("sig" : hints) ++ [show id] in + let name = concat $ List.intersperse "_" parts in + (id, info {sigName = Just name}) + -- | Splits a tuple type into a list of element types, or Nothing if the type -- is not a tuple type. splitTupleType :: @@ -152,4 +254,32 @@ 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 -> 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 + +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: