clash-ghc 0.6.6 → 0.6.7
raw patch · 5 files changed
+119/−55 lines, 5 filesdep ~clash-libdep ~unbound-generics
Dependency ranges changed: clash-lib, unbound-generics
Files
- CHANGELOG.md +7/−0
- clash-ghc.cabal +3/−3
- src-bin/InteractiveUI.hs +2/−2
- src-ghc/CLaSH/GHC/GenerateBindings.hs +34/−35
- src-ghc/CLaSH/GHC/LoadModules.hs +73/−15
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.6.7 *December 21st 2015*+* Support for `unbound-generics-0.3`+* New features:+ * Only look for 'topEntity' in the root module. [#22](https://github.com/clash-lang/clash-compiler/issues/22)+* Fixes bugs:+ * Unhelpful error message when GHC is not in PATH [#104](https://github.com/clash-lang/clash-compiler/issues/104)+ ## 0.6.6 *December 11th 2015* * New features: * Remove all existing HDL files before generating new ones. This can be disabled by the `-clash-noclean` flag. [#96](https://github.com/clash-lang/clash-compiler/issues/96)
clash-ghc.cabal view
@@ -1,5 +1,5 @@ Name: clash-ghc-Version: 0.6.6+Version: 0.6.7 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -91,10 +91,10 @@ mtl >= 2.1.1, text >= 0.11.3.1, transformers >= 0.4.2,- unbound-generics >= 0.1 && < 0.3,+ unbound-generics >= 0.1 && < 0.4, unordered-containers >= 0.2.1.0, - clash-lib >= 0.6.5 && < 0.7,+ clash-lib >= 0.6.7 && < 0.7, clash-systemverilog >= 0.6.3, clash-vhdl >= 0.6.4, clash-verilog >= 0.6.3,
src-bin/InteractiveUI.hs view
@@ -1584,9 +1584,9 @@ primDir <- CLaSH.Backend.primDir backend primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] forM_ srcs $ \src -> do- (bindingsMap,tcm,tupTcm,topEntM) <- generateBindings primMap src (Just dflags)+ (bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM) <- generateBindings primMap src (Just dflags) CLaSH.Driver.generateHDL bindingsMap (Just backend) primMap tcm- tupTcm ghcTypeToHWType reduceConstant topEntM opts+ tupTcm ghcTypeToHWType reduceConstant topEnt testInpM expOutM opts makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi () makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState)
src-ghc/CLaSH/GHC/GenerateBindings.hs view
@@ -10,16 +10,16 @@ import qualified Data.HashMap.Strict as HashMap import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM-import Data.List (isSuffixOf) import qualified Data.Set as Set import qualified Data.Set.Lens as Lens-import Unbound.Generics.LocallyNameless (name2String, runFreshM, unembed)+import Unbound.Generics.LocallyNameless (runFreshM, unembed) import qualified BasicTypes as GHC import qualified CoreSyn as GHC import qualified DynFlags as GHC import qualified TyCon as GHC import qualified TysWiredIn as GHC+import qualified Var as GHC import CLaSH.Annotations.TopEntity (TopEntity) import CLaSH.Core.FreeVars (termFreeIds)@@ -43,50 +43,49 @@ PrimMap -> String -> Maybe (GHC.DynFlags)- -> IO (BindingMap,HashMap TyConName TyCon,IntMap TyConName,Maybe TopEntity)+ -> IO (BindingMap,HashMap TyConName TyCon,IntMap TyConName+ ,(TmName, Maybe TopEntity) -- topEntity bndr + (maybe) TopEntity annotation+ ,Maybe TmName -- testInput bndr+ ,Maybe TmName) -- expectedOutput bndr generateBindings primMap modName dflagsM = do- (bindings,clsOps,unlocatable,fiEnvs,topEntM) <- loadModules modName dflagsM+ (bindings,clsOps,unlocatable,fiEnvs,(topEnt,topEntAnn),testInpM,expOutM) <- loadModules modName dflagsM let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState (tcMap',tupTcCache) = mkTupTyCons tcMap tcCache = makeAllTyCons tcMap' fiEnvs allTcCache = tysPrimMap `HashMap.union` tcCache clsMap = HashMap.map (\(ty,i) -> (ty,mkClassSelector allTcCache ty i)) clsVMap allBindings = bindingsMap `HashMap.union` clsMap- droppedAndRetypedBindings = dropAndRetypeBindings allTcCache allBindings- return (droppedAndRetypedBindings,allTcCache,tupTcCache,topEntM)--dropAndRetypeBindings :: HashMap TyConName TyCon -> BindingMap -> BindingMap-dropAndRetypeBindings allTcCache allBindings = oBindings- where- topEntities = HashMap.toList- $ HashMap.filterWithKey- (\var _ -> isSuffixOf ".topEntity" $ name2String var)- allBindings- testInputs = HashMap.toList- $ HashMap.filterWithKey- (\var _ -> isSuffixOf ".testInput" $ name2String var)- allBindings- expectedOutputs = HashMap.toList- $ HashMap.filterWithKey- (\var _ -> isSuffixOf ".expectedOutput" $ name2String var)- allBindings+ (topEnt',testInpM',expOutM') = flip State.evalState tcMap' $ do+ topEnt'' <- coreToName GHC.varName GHC.varUnique qualfiedNameString topEnt+ testInpM'' <- traverse (coreToName GHC.varName GHC.varUnique qualfiedNameString) testInpM+ expOutM'' <- traverse (coreToName GHC.varName GHC.varUnique qualfiedNameString) expOutM+ return (topEnt'',testInpM'',expOutM'')+ droppedAndRetypedBindings = dropAndRetypeBindings allTcCache allBindings topEnt' testInpM' expOutM' - dropAndRetype d (t,_) = snd- $ retype allTcCache- ([],lambdaDropPrep d t)- t+ return (droppedAndRetypedBindings,allTcCache,tupTcCache,(topEnt',topEntAnn),testInpM',expOutM') - tBindings = case topEntities of- (topEntity:_) -> dropAndRetype allBindings topEntity- _ -> allBindings+dropAndRetypeBindings :: HashMap TyConName TyCon+ -> BindingMap+ -> TmName -- ^ topEntity+ -> Maybe TmName -- ^ testInput+ -> Maybe TmName -- ^ expectedOutput+ -> BindingMap - iBindings = case testInputs of- (testInput:_) -> dropAndRetype tBindings testInput- _ -> tBindings+dropAndRetypeBindings allTcCache allBindings topEnt testInpM expOutM = oBindings+ where+ topEntity = do e <- HashMap.lookup topEnt allBindings+ return (topEnt,e)+ testInput = do t <- testInpM+ e <- HashMap.lookup t allBindings+ return (t,e)+ expectedOut = do t <- expOutM+ e <- HashMap.lookup t allBindings+ return (t,e) - oBindings = case expectedOutputs of- (expectedOutput:_) -> dropAndRetype iBindings expectedOutput- _ -> iBindings+ tBindings = maybe allBindings (dropAndRetype allBindings) topEntity+ iBindings = maybe tBindings (dropAndRetype tBindings) testInput+ oBindings = maybe iBindings (dropAndRetype iBindings) expectedOut+ dropAndRetype d (t,_) = snd (retype allTcCache ([],lambdaDropPrep d t) t) -- | clean up cast-removal mess retype :: HashMap TyConName TyCon
src-ghc/CLaSH/GHC/LoadModules.hs view
@@ -10,16 +10,18 @@ -- External Modules import Data.List (nub)-import Data.Maybe (listToMaybe)+import Data.Word (Word8) import CLaSH.Annotations.TopEntity (TopEntity) import System.Exit (ExitCode (..)) import System.IO (hGetLine)+import System.IO.Error (tryIOError) import System.Process (runInteractiveCommand, waitForProcess) -- GHC API import qualified Annotations import qualified CoreSyn+import qualified Digraph import DynFlags (GeneralFlag (..)) import qualified DynFlags import qualified GHC@@ -29,32 +31,44 @@ import qualified Panic import qualified Serialized import qualified TidyPgm- import qualified TcRnMonad import qualified TcRnTypes import qualified UniqFM import qualified Var import qualified FamInst import qualified FamInstEnv+import qualified Name+import qualified Module+import Outputable ((<>),dot,ppr)+import qualified Outputable+import qualified OccName -- Internal Modules import CLaSH.GHC.LoadInterfaceFiles import CLaSH.Util (curLoc,first) ghcLibDir :: IO FilePath-ghcLibDir = do (libDir,exitCode) <- getProcessOutput $ "ghc-" ++ TOOL_VERSION_ghc ++ " --print-libdir"- case exitCode of- ExitSuccess -> return libDir- ExitFailure i -> error $ "Calling GHC failed with: " ++ show i+ghcLibDir = do+ (libDirM,exitCode) <- getProcessOutput $ "ghc-" ++ TOOL_VERSION_ghc ++ " --print-libdir"+ case exitCode of+ ExitSuccess -> case libDirM of+ Just libDir -> return libDir+ Nothing -> Panic.pgmError noGHC+ ExitFailure i -> case i of+ 127 -> Panic.pgmError noGHC+ i' -> Panic.pgmError $ "Calling GHC failed with error code: " ++ show i'+ where+ noGHC = "CLaSH needs the GHC compiler it was build with, ghc-" ++ TOOL_VERSION_ghc +++ ", but it was not found. Make sure its location is in your PATH variable." -getProcessOutput :: String -> IO (String, ExitCode)+getProcessOutput :: String -> IO (Maybe String, ExitCode) getProcessOutput command = -- Create the process do (_, pOut, _, handle) <- runInteractiveCommand command -- Wait for the process to finish and store its exit code exitCode <- waitForProcess handle -- Get the standard output.- output <- hGetLine pOut+ output <- either (const Nothing) Just <$> tryIOError (hGetLine pOut) -- return both the output and the exit code. return (output, exitCode) @@ -65,7 +79,9 @@ , [(CoreSyn.CoreBndr,Int)] -- Class operations , [CoreSyn.CoreBndr] -- Unlocatable Expressions , FamInstEnv.FamInstEnvs- , Maybe TopEntity+ , (CoreSyn.CoreBndr, Maybe TopEntity) -- topEntity bndr + (maybe) TopEntity annotation+ , Maybe CoreSyn.CoreBndr -- testInput bndr+ , Maybe CoreSyn.CoreBndr -- expectedOutput bndr ) loadModules modName dflagsM = GHC.defaultErrorHandler DynFlags.defaultFatalMessager DynFlags.defaultFlushOut $ do@@ -144,19 +160,61 @@ hscEnv <- GHC.getSession famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs- topEntityAnnotations <- findCLaSHAnnotations (map fst binders)- let topEntM = listToMaybe topEntityAnnotations - return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntM)+ let rootModule = GHC.ms_mod_name . last+ . Digraph.flattenSCC+ . last+ $ GHC.topSortModuleGraph True modGraph Nothing++ rootBndrs = filter (maybe False+ ((== rootModule)+ . Module.moduleName)+ . Name.nameModule_maybe+ . Var.varName)+ (map fst binders)++ topEntM <- findCLaSHAnnotations rootBndrs+ let varNameString = OccName.occNameString . Name.nameOccName . Var.varName+ topEntities = filter ((== "topEntity") . varNameString) rootBndrs+ testInputs = filter ((== "testInput") . varNameString) rootBndrs+ expectedOutputs = filter ((== "expectedOutput") . varNameString) rootBndrs+ topEntity <- case topEntities of+ [] -> case topEntM of+ Just (l,r) -> return (l,Just r)+ _ -> Panic.pgmError $ "No 'topEntity', nor function with a 'TopEntity' annotation found in root module: " +++ (Outputable.showSDocUnsafe (ppr rootModule))+ [x] -> case topEntM of+ Just (l,r) | l == x -> return (l,Just r)+ | otherwise -> Panic.pgmError $ "'TopEntity' annotation applied to a function that is not named 'topEntity' while a 'topEntity' function is present: " +++ (Outputable.showSDocUnsafe (ppr rootModule <> dot <> ppr l))+ Nothing -> return (x,Nothing)+ _ -> Panic.pgmError $ $(curLoc) ++ "Multiple 'topEntities' found."+ testInput <- case testInputs of+ [] -> return Nothing+ [x] -> return (Just x)+ _ -> Panic.pgmError $ $(curLoc) ++ "Multiple 'testInput's found."+ expectedOutput <- case expectedOutputs of+ [] -> return Nothing+ [x] -> return (Just x)+ _ -> Panic.pgmError $ $(curLoc) ++ "Multiple 'testInput's found."++ return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntity,testInput,expectedOutput) GHC.Failed -> Panic.pgmError $ $(curLoc) ++ "failed to load module: " ++ modName findCLaSHAnnotations :: GHC.GhcMonad m => [CoreSyn.CoreBndr]- -> m [TopEntity]+ -> m (Maybe (CoreSyn.CoreBndr,TopEntity)) findCLaSHAnnotations bndrs = do- let deserializer = Serialized.deserializeWithData+ let deserializer = Serialized.deserializeWithData :: ([Word8] -> TopEntity) targets = map (Annotations.NamedTarget . Var.varName) bndrs- concat <$> mapM (GHC.findGlobalAnns deserializer) targets++ anns <- mapM (GHC.findGlobalAnns deserializer) targets+ let annBndrs = filter (not . null . snd) (zip bndrs anns)+ case annBndrs of+ [] -> return Nothing+ [(x,[y])] -> return (Just (x,y))+ [(x,_)] -> Panic.pgmError $ "Root module contains a function with multiple 'TopEntity' annotation: " ++ Outputable.showSDocUnsafe (ppr x)+ xs -> Panic.pgmError $ "Root module contains multiple functions with a 'TopEntity' annotation: " ++ Outputable.showSDocUnsafe (ppr (map fst xs)) parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule parseModule modSum = do