diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/clash-ghc.cabal b/clash-ghc.cabal --- a/clash-ghc.cabal +++ b/clash-ghc.cabal @@ -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, diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -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) diff --git a/src-ghc/CLaSH/GHC/GenerateBindings.hs b/src-ghc/CLaSH/GHC/GenerateBindings.hs --- a/src-ghc/CLaSH/GHC/GenerateBindings.hs +++ b/src-ghc/CLaSH/GHC/GenerateBindings.hs @@ -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 diff --git a/src-ghc/CLaSH/GHC/LoadModules.hs b/src-ghc/CLaSH/GHC/LoadModules.hs --- a/src-ghc/CLaSH/GHC/LoadModules.hs +++ b/src-ghc/CLaSH/GHC/LoadModules.hs @@ -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