diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.5.5 *May 5th 2015* +* New features: + * `TopEntity` wrappers are now specified as `ANN` annotation pragmas [#42](https://github.com/clash-lang/clash-compiler/issues/42) + ## 0.5.4 *May 1st 2015* * New features: * Generate wrappers around `topEntity` that have constant names and types 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.5.4 +Version: 0.5.5 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -70,7 +70,8 @@ unbound-generics >= 0.1, unordered-containers >= 0.2.1.0, - clash-lib >= 0.5.2, + clash-lib >= 0.5.3, + clash-prelude >= 0.7.4, clash-vhdl >= 0.5.3, clash-systemverilog >= 0.5.2, clash-prelude >= 0.7.3, diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -113,7 +113,6 @@ import CLaSH.Backend.VHDL (VHDLState) import CLaSH.Backend.SystemVerilog (SystemVerilogState) import qualified CLaSH.Driver -import CLaSH.Driver.TopWrapper (generateTopEnt) import CLaSH.GHC.Evaluator import CLaSH.GHC.GenerateBindings import CLaSH.GHC.NetlistTypes @@ -1578,8 +1577,7 @@ liftIO $ do primDir <- CLaSH.Backend.primDir backend primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] forM_ srcs $ \src -> do - (bindingsMap,tcm) <- generateBindings primMap src (Just dflags) - topEntM <- generateTopEnt (dropExtensions $ takeFileName src) + (bindingsMap,tcm,topEntM) <- generateBindings primMap src (Just dflags) CLaSH.Driver.generateHDL bindingsMap (Just backend) primMap tcm ghcTypeToHWType reduceConstant topEntM DebugNone diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -152,6 +152,7 @@ , DynFlags.Opt_FlexibleContexts , DynFlags.Opt_ConstraintKinds , DynFlags.Opt_TypeFamilies + , DynFlags.Opt_BinaryLiterals ] dflagsExtra1 = foldl DynFlags.xopt_unset dflagsExtra [ DynFlags.Opt_ImplicitPrelude 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 @@ -15,6 +15,7 @@ import qualified CoreSyn as GHC import qualified DynFlags as GHC +import CLaSH.Annotations.TopEntity (TopEntity) import CLaSH.Core.FreeVars (termFreeIds) import CLaSH.Core.Term (Term (..), TmName) import CLaSH.Core.Type (Type, TypeView (..), coreView, mkFunTy, splitFunForallTy) @@ -36,9 +37,9 @@ PrimMap -> String -> Maybe (GHC.DynFlags) - -> IO (BindingMap,HashMap TyConName TyCon) + -> IO (BindingMap,HashMap TyConName TyCon,Maybe TopEntity) generateBindings primMap modName dflagsM = do - (bindings,clsOps,unlocatable,fiEnvs) <- loadModules modName dflagsM + (bindings,clsOps,unlocatable,fiEnvs,topEntM) <- loadModules modName dflagsM let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState tcCache = makeAllTyCons tcMap fiEnvs allTcCache = tysPrimMap `HashMap.union` tcCache @@ -49,7 +50,7 @@ [topEntity] -> let droppedBindings = lambdaDropPrep allBindings (fst topEntity) in snd $ retype allTcCache ([],droppedBindings) (fst topEntity) _ -> allBindings - return (retypedBindings,allTcCache) + return (retypedBindings,allTcCache,topEntM) -- | 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 @@ -8,13 +8,16 @@ where -- External Modules +import Data.List (nub) +import Data.Maybe (listToMaybe) +import CLaSH.Annotations.TopEntity (TopEntity) import System.Exit (ExitCode (..)) import System.IO (hGetLine) import System.Process (runInteractiveCommand, waitForProcess) -import Data.List (nub) -- GHC API +import qualified Annotations import qualified CoreSyn import DynFlags (GeneralFlag (..)) import qualified DynFlags @@ -23,11 +26,13 @@ import qualified HscTypes import qualified MonadUtils 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 @@ -59,6 +64,7 @@ , [(CoreSyn.CoreBndr,Int)] -- Class operations , [CoreSyn.CoreBndr] -- Unlocatable Expressions , FamInstEnv.FamInstEnvs + , Maybe TopEntity ) loadModules modName dflagsM = GHC.defaultErrorHandler DynFlags.defaultFatalMessager DynFlags.defaultFlushOut $ do @@ -76,6 +82,7 @@ , DynFlags.Opt_FlexibleContexts , DynFlags.Opt_ConstraintKinds , DynFlags.Opt_TypeFamilies + , DynFlags.Opt_BinaryLiterals ] let dfDis = foldl DynFlags.xopt_unset dfEn [ DynFlags.Opt_ImplicitPrelude @@ -129,9 +136,19 @@ 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')) + return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntM) GHC.Failed -> Panic.pgmError $ $(curLoc) ++ "failed to load module: " ++ modName + +findCLaSHAnnotations :: GHC.GhcMonad m + => [CoreSyn.CoreBndr] + -> m [TopEntity] +findCLaSHAnnotations bndrs = do + let deserializer = Serialized.deserializeWithData + targets = map (Annotations.NamedTarget . Var.varName) bndrs + concat <$> mapM (GHC.findGlobalAnns deserializer) targets parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule parseModule modSum = do