X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=0f60277671f99b646ec427deb8fd82ce92d53169;hb=e230d86ae7135a268a72cdffba947a9011001ec2;hp=841f63b892c2f330adfa88bca5c837cf5a7ada23;hpb=6a57a063a1765dea8e72628d59efaaa5ecfa66e1;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Translator.hs b/Translator.hs index 841f63b..0f60277 100644 --- a/Translator.hs +++ b/Translator.hs @@ -1,6 +1,8 @@ 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 @@ -8,12 +10,16 @@ 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 import Data.Generics import NameEnv ( lookupNameEnv ) import qualified HscTypes @@ -22,6 +28,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 @@ -39,13 +46,14 @@ 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 +-- main = do +-- makeVHDL "Alu.hs" "exec" True makeVHDL :: String -> String -> Bool -> IO () makeVHDL filename name stateful = do @@ -54,7 +62,7 @@ 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 () @@ -62,52 +70,56 @@ 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 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 - 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 + --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 @@ -124,32 +136,28 @@ 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 + 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 @@ -160,24 +168,19 @@ processBind stateful bind@(NonRec var expr) = do -- with them. flattenBind :: HsFunction -- The signature to flatten into - -> CoreBind -- The bind to flatten - -> VHDLState () - -flattenBind _ (Rec _) = error "Recursive binders not supported" + -> (CoreBndr, CoreExpr) -- The bind to flatten + -> TranslatorState () -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 @@ -270,26 +273,22 @@ getStateSignals hsfunc flatfunc = -- (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 @@ -331,21 +330,15 @@ mkHsFunction f ty stateful= -- | Adds signal names to the given FlatFunction nameFlatFunction :: - HsFunction - -> FuncData - -> VHDLState () + FlatFunction + -> FlatFunction -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' +nameFlatFunction flatfunc = + -- Name the signals + let + s = flat_sigs flatfunc + s' = map nameSignal s in + flatfunc { flat_sigs = s' } where nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo) nameSignal (id, info) = @@ -369,32 +362,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 -> 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: