From 4495e7a13be4643f342c5b05dcb819b60dc1b108 Mon Sep 17 00:00:00 2001 From: Christiaan Baaij Date: Wed, 22 Jul 2009 13:33:44 +0200 Subject: [PATCH] Removed need for GHC.Paths, some functions however require a top libdir --- "c\316\273ash/CLasH/Translator.hs" | 33 ++++++++++---------- "c\316\273ash/CLasH/Utils/Core/CoreTools.hs" | 7 +++-- "c\316\273ash/CLasH/Utils/GhcTools.hs" | 25 +++++++-------- "c\316\273ash/clash.cabal" | 12 ------- 4 files changed, 33 insertions(+), 44 deletions(-) diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index ca660a7..c1e853a 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -31,7 +31,6 @@ import qualified HscTypes import HscTypes ( cm_binds, cm_types ) import MonadUtils ( liftIO ) import Outputable ( showSDoc, ppr, showSDocDebug ) -import GHC.Paths ( libdir ) import DynFlags ( defaultDynFlags ) import qualified UniqSupply import List ( find ) @@ -56,10 +55,10 @@ import CLasH.Normalize import CLasH.VHDL.VHDLTypes import qualified CLasH.VHDL as VHDL -makeVHDL :: String -> String -> Bool -> IO () -makeVHDL filename name stateful = do +makeVHDL :: FilePath -> String -> String -> Bool -> IO () +makeVHDL libdir filename name stateful = do -- Load the module - (core, env) <- loadModule filename + (core, env) <- loadModule libdir filename -- Translate to VHDL vhdl <- moduleToVHDL env core [(name, stateful)] -- Write VHDL to file @@ -68,9 +67,9 @@ makeVHDL filename name stateful = do mapM (writeVHDL dir) vhdl return () -makeVHDLAnn :: String -> Bool -> IO () -makeVHDLAnn filename stateful = do - (core, top, init, env) <- loadModuleAnn filename +makeVHDLAnn :: FilePath -> String -> IO () +makeVHDLAnn libdir filename = do + (core, top, init, env) <- loadModuleAnn libdir filename let top_entity = head top vhdl <- case init of [] -> moduleToVHDLAnn env core [top_entity] @@ -80,9 +79,9 @@ makeVHDLAnn filename stateful = do mapM (writeVHDL dir) vhdl return () -listBindings :: String -> IO [()] -listBindings filename = do - (core, env) <- loadModule filename +listBindings :: FilePath -> String -> IO [()] +listBindings libdir filename = do + (core, env) <- loadModule libdir filename let binds = CoreSyn.flattenBinds $ cm_binds core mapM (listBinding) binds @@ -99,9 +98,9 @@ listBinding (b, e) = do putStr "\n\n" -- | Show the core structure of the given binds in the given file. -listBind :: String -> String -> IO () -listBind filename name = do - (core, env) <- loadModule filename +listBind :: FilePath -> String -> String -> IO () +listBind libdir filename name = do + (core, env) <- loadModule libdir filename let [(b, expr)] = findBinds core [name] putStr "\n" putStr $ prettyShow expr @@ -190,8 +189,8 @@ writeVHDL dir (name, vhdl) = do Language.VHDL.FileIO.writeDesignFile vhdl fname -- | Loads the given file and turns it into a core module. -loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv) -loadModule filename = +loadModule :: FilePath -> String -> IO (HscTypes.CoreModule, HscTypes.HscEnv) +loadModule libdir filename = defaultErrorHandler defaultDynFlags $ do runGhc (Just libdir) $ do dflags <- getSessionDynFlags @@ -207,8 +206,8 @@ loadModule filename = return (core, env) -- | Loads the given file and turns it into a core module. -loadModuleAnn :: String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], HscTypes.HscEnv) -loadModuleAnn filename = +loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], HscTypes.HscEnv) +loadModuleAnn libdir filename = defaultErrorHandler defaultDynFlags $ do runGhc (Just libdir) $ do dflags <- getSessionDynFlags diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index 45721a8..e0a5c11 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -40,7 +40,7 @@ import CLasH.Utils.Pretty -- library to a real int. eval_tfp_int :: HscTypes.HscEnv -> Type.Type -> Int eval_tfp_int env ty = - unsafeRunGhc $ do + unsafeRunGhc libdir $ do GHC.setSession env -- Automatically import modules for any fully qualified identifiers setDynFlag DynFlags.Opt_ImplicitImportQualified @@ -52,7 +52,10 @@ eval_tfp_int env ty = let int_ty = SrcLoc.noLoc $ HsTypes.HsTyVar TysWiredIn.intTyCon_RDR let expr = HsExpr.ExprWithTySig app int_ty core <- toCore expr - execCore core + execCore core + where + libdir = DynFlags.topDir dynflags + dynflags = HscTypes.hsc_dflags env normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type normalise_tfp_int env ty = diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 5f6e671..3f032d9 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -4,7 +4,6 @@ import qualified System.IO.Unsafe -- GHC API import qualified GHC -import qualified GHC.Paths import qualified DynFlags import qualified TcRnMonad import qualified MonadUtils @@ -26,19 +25,19 @@ setDynFlag dflag = do -- don't have side effects themselves (Or rather, that don't use -- unsafePerformIO themselves, since normal side effectful function would -- just return an IO monad when they are evaluated). -unsafeRunGhc :: GHC.Ghc a -> a -unsafeRunGhc m = - System.IO.Unsafe.unsafePerformIO $ - GHC.runGhc (Just GHC.Paths.libdir) $ do +unsafeRunGhc :: FilePath -> GHC.Ghc a -> a +unsafeRunGhc libDir m = + System.IO.Unsafe.unsafePerformIO $ do + GHC.runGhc (Just libDir) $ do dflags <- GHC.getSessionDynFlags GHC.setSessionDynFlags dflags m -runTcM :: TcRnMonad.TcM a -> IO a -runTcM thing_inside = do - GHC.runGhc (Just GHC.Paths.libdir) $ do - dflags <- GHC.getSessionDynFlags - GHC.setSessionDynFlags dflags - env <- GHC.getSession - HscTypes.ioMsgMaybe . MonadUtils.liftIO . TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do - thing_inside +-- runTcM :: TcRnMonad.TcM a -> IO a +-- runTcM thing_inside = do +-- GHC.runGhc (Just GHC.Paths.libdir) $ do +-- dflags <- GHC.getSessionDynFlags +-- GHC.setSessionDynFlags dflags +-- env <- GHC.getSession +-- HscTypes.ioMsgMaybe . MonadUtils.liftIO . TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do +-- thing_inside diff --git "a/c\316\273ash/clash.cabal" "b/c\316\273ash/clash.cabal" index 6daa843..69fd79f 100644 --- "a/c\316\273ash/clash.cabal" +++ "b/c\316\273ash/clash.cabal" @@ -16,23 +16,11 @@ stability: alpha maintainer: christiaan.baaij@gmail.com & matthijs@stdin.nl Cabal-Version: >= 1.2 -flag out-ghc-tree - description: Are we outside a GHC tree? - default: False - manual: True - Library - if flag(out-ghc-tree) - build-depends: ghc-paths - else - cpp-options: -DIN_GHC_TREE - build-depends: ghc >= 6.11, pretty, vhdl, haskell98, syb, data-accessor, containers, base >= 4, transformers, filepath, template-haskell, data-accessor-template, prettyclass - extensions: CPP - exposed-modules: CLasH.Translator, CLasH.Translator.Annotations -- 2.30.2