X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=0f60277671f99b646ec427deb8fd82ce92d53169;hb=e230d86ae7135a268a72cdffba947a9011001ec2;hp=1ecbdb9223b3c4267649f4705e1ffa000b358de0;hpb=d8c4021114afc1f860763b3a8dceff3f219d4798;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Translator.hs b/Translator.hs index 1ecbdb9..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,6 +10,9 @@ 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 Data.Foldable as Foldable @@ -23,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 @@ -40,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 @@ -55,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 () @@ -63,11 +70,13 @@ 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 @@ -76,25 +85,31 @@ listBind filename name = do 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) (TranslatorSession core 0 Map.empty) + 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 :: [CoreBind] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)] - 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 -- Create entities and architectures for them - Monad.zipWithM processBind statefuls binds - modA tsFlatFuncs (Map.map nameFlatFunction) - flatfuncs <- getA tsFlatFuncs - return $ VHDL.createDesignFiles flatfuncs + --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 @@ -121,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 + -> (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 @@ -157,18 +168,16 @@ processBind stateful bind@(NonRec var expr) = do -- 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 @@ -268,14 +277,15 @@ resolvFunc :: resolvFunc hsfunc = do flatfuncmap <- getA tsFlatFuncs - -- Don't do anything if there is already a flat function for this hsfunc. + -- 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 - -- 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 @@ -352,33 +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 -> 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: