diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.99.1 *May 12th 2018* +* Allow `~NAME[N]` tag inside `~GENSYM[X]` +* Support HDL record selector generation [#313](https://github.com/clash-lang/clash-compiler/pull/313) +* `InlinePrimitive` support: specify HDL primitives inline with Haskell code + ## 0.99 *March 31st 2018* * New features: * Support for `clash-prelude-0.99`: 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.99 +Version: 0.99.1 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -116,9 +116,9 @@ clash-lib >= 0.7.1 && < 1.0, clash-prelude >= 0.11.2 && < 1.0, concurrent-supply >= 0.1.7 && < 0.2, - ghc-typelits-extra >= 0.1.3 && < 0.3, - ghc-typelits-knownnat >= 0.1.2 && < 0.5, - ghc-typelits-natnormalise >= 0.4.3 && < 0.6, + ghc-typelits-extra >= 0.2.5 && < 0.3, + ghc-typelits-knownnat >= 0.5 && < 0.6, + ghc-typelits-natnormalise >= 0.6 && < 0.7, deepseq >= 1.3.0.2 && < 1.5, time >= 1.4.0.1 && < 1.9, ghc-boot >= 8.0.2 && < 8.6, diff --git a/src-ghc/Clash/GHC/LoadInterfaceFiles.hs b/src-ghc/Clash/GHC/LoadInterfaceFiles.hs --- a/src-ghc/Clash/GHC/LoadInterfaceFiles.hs +++ b/src-ghc/Clash/GHC/LoadInterfaceFiles.hs @@ -12,14 +12,21 @@ {-# LANGUAGE TupleSections #-} module Clash.GHC.LoadInterfaceFiles - (loadExternalExprs) + ( loadExternalExprs + , primitiveFilePath + ) where -- External Modules -import Data.Either (partitionEithers) -import Data.List (elemIndex, foldl', partition) -import Data.Maybe (isJust, isNothing, mapMaybe) -import Data.Word (Word8) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Char (toLower) +import Data.Either (partitionEithers) +import Data.List (elemIndex, foldl', partition) +import Data.Maybe (fromMaybe, isJust, isNothing, + mapMaybe) +import Data.Word (Word8) +import System.Directory (createDirectoryIfMissing) +import System.FilePath.Posix ((<.>), ()) import Clash.Annotations.Primitive @@ -30,7 +37,7 @@ import qualified CoreFVs import qualified CoreSyn import qualified Demand -import DynFlags (unsafeGlobalDynFlags) +import DynFlags (unsafeGlobalDynFlags) import qualified GHC import qualified Id import qualified IdInfo @@ -43,7 +50,7 @@ #endif import qualified MonadUtils import qualified Name -import Outputable (showPpr, showSDoc, text) +import Outputable (showPpr, showSDoc, text) #if MIN_VERSION_ghc(8,4,1) import qualified GhcPlugins #else @@ -60,7 +67,7 @@ #endif -- Internal Modules -import Clash.Util ((***), curLoc, traceIf) +import Clash.Util (curLoc, traceIf, (***)) runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a runIfl modName action = do @@ -168,7 +175,11 @@ ,[FilePath] ) loadExprFromIface hdl bndr = do - let moduleM = Name.nameModule_maybe $ Var.varName bndr + dflags <- GHC.getSessionDynFlags + + let -- Using the stub directory as the output directory for inline primitives + outDir = fromMaybe "." $ GHC.stubDir dflags + moduleM = Name.nameModule_maybe $ Var.varName bndr case moduleM of Just nameMod -> runIfl nameMod $ do ifaceM <- loadIface nameMod @@ -183,7 +194,7 @@ let declM = filter ((== nameFun) . IfaceSyn.ifName) decls #endif anns <- TcIface.tcIfaceAnnotations (GHC.mi_anns iface) - let primFPs = loadPrimitiveAnnotations hdl anns + primFPs <- loadPrimitiveAnnotations hdl outDir anns case declM of [namedDecl] -> do tyThing <- loadDecl namedDecl @@ -191,24 +202,52 @@ _ -> return (Right bndr,primFPs) Nothing -> return (Right bndr,[]) -loadPrimitiveAnnotations - :: HDL +loadPrimitiveAnnotations :: + MonadIO m + => HDL + -> FilePath -> [Annotations.Annotation] - -> [FilePath] -loadPrimitiveAnnotations hdl anns = mapMaybe toFP (concat prims) + -> m [FilePath] +loadPrimitiveAnnotations hdl outDir anns = + sequence $ mapMaybe (primitiveFilePath hdl outDir) prims where - annEnv = Annotations.mkAnnEnv anns - prims = UniqFM.eltsUFM (Annotations.deserializeAnns deserializer annEnv) + prims = mapMaybe filterPrim anns + filterPrim (Annotations.Annotation target value) = + (target,) <$> deserialize value #if MIN_VERSION_ghc(8,4,1) - deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> Primitive) + deserialize = + GhcPlugins.fromSerialized + (GhcPlugins.deserializeWithData :: [Word8] -> Primitive) #else - deserializer = Serialized.deserializeWithData :: ([Word8] -> Primitive) + deserialize = + Serialized.fromSerialized + (Serialized.deserializeWithData :: [Word8] -> Primitive) #endif - toFP (Primitive hdl' fp) - | hdl == hdl' - = Just fp - toFP _ = Nothing +primitiveFilePath :: + MonadIO m + => HDL + -> FilePath + -> (Annotations.CoreAnnTarget, Primitive) + -> Maybe (m FilePath) +primitiveFilePath hdl outDir targetPrim = + case targetPrim of + (_, Primitive hdl' fp) + | hdl == hdl' -> Just $ pure fp + (target, InlinePrimitive hdl' content) + | hdl == hdl' -> Just . liftIO $ do + let qualifiedName = + case target of + Annotations.NamedTarget name -> Name.nameStableString name + Annotations.ModuleTarget mod' -> Module.moduleStableString mod' + inlinePrimsDir = + outDir "inline_primitives" map toLower (show hdl) + primFile = inlinePrimsDir qualifiedName <.> "json" + createDirectoryIfMissing True inlinePrimsDir + writeFile primFile content + return inlinePrimsDir + _ -> Nothing + loadExprFromTyThing :: CoreSyn.CoreBndr -> GHC.TyThing -> Either @@ -220,7 +259,7 @@ unfolding = IdInfo.unfoldingInfo _idInfo inlineInfo = IdInfo.inlinePragInfo _idInfo in case unfolding of - (CoreSyn.CoreUnfolding {}) -> + CoreSyn.CoreUnfolding {} -> case (BasicTypes.inl_inline inlineInfo,BasicTypes.inl_act inlineInfo) of (BasicTypes.NoInline,BasicTypes.AlwaysActive) -> Right bndr (BasicTypes.NoInline,BasicTypes.NeverActive) -> Right bndr @@ -232,13 +271,16 @@ in Left (bndr,dfExpr) CoreSyn.NoUnfolding | Demand.isBottomingSig $ IdInfo.strictnessInfo _idInfo + -> Left + ( bndr #if MIN_VERSION_ghc(8,2,2) - -> Left (bndr, MkCore.mkAbsentErrorApp + , MkCore.mkAbsentErrorApp #else - -> Left (bndr, MkCore.mkRuntimeErrorApp MkCore.aBSENT_ERROR_ID + , MkCore.mkRuntimeErrorApp + MkCore.aBSENT_ERROR_ID #endif - (Var.varType _id) - ("no_unfolding " ++ showPpr unsafeGlobalDynFlags bndr) - ) + (Var.varType _id) + ("no_unfolding " ++ showPpr unsafeGlobalDynFlags bndr) + ) _ -> Right bndr _ -> Right bndr 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 @@ -24,25 +24,26 @@ #endif -- External Modules -import Control.Arrow (second) +import Clash.Annotations.Primitive (HDL, Primitive (..)) +import Clash.Annotations.TopEntity (TopEntity (..)) +import Control.Arrow (second) import Data.Generics.Uniplate.DataOnly (transform) -import Data.List (foldl', lookup, nub) -import Data.Maybe (listToMaybe) -import Data.Word (Word8) -import Clash.Annotations.Primitive (HDL) -import Clash.Annotations.TopEntity (TopEntity (..)) -import System.Exit (ExitCode (..)) -import System.IO (hGetLine) -import System.IO.Error (tryIOError) -import System.Process (runInteractiveCommand, - waitForProcess) +import Data.List (foldl', lookup, nub) +import Data.Maybe (catMaybes, fromMaybe, + listToMaybe, mapMaybe) +import Data.Word (Word8) +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 CoreFVs +import qualified CoreSyn import qualified Digraph -import DynFlags (GeneralFlag (..)) +import DynFlags (GeneralFlag (..)) import qualified DynFlags import qualified GHC import qualified HscMain @@ -54,29 +55,29 @@ #else import qualified Serialized #endif -import qualified TidyPgm import qualified TcRnMonad import qualified TcRnTypes +import qualified TidyPgm import qualified Unique #if MIN_VERSION_ghc(8,2,0) import qualified UniqDFM #else import qualified UniqFM #endif -import qualified UniqSet -import qualified Var import qualified FamInst import qualified FamInstEnv +import qualified GHC.LanguageExtensions as LangExt import qualified Name -import Outputable (ppr) -import qualified Outputable import qualified OccName -import qualified GHC.LanguageExtensions as LangExt +import Outputable (ppr) +import qualified Outputable +import qualified UniqSet +import qualified Var -- Internal Modules -import Clash.GHC.GHC2Core (modNameM) +import Clash.GHC.GHC2Core (modNameM) import Clash.GHC.LoadInterfaceFiles -import Clash.Util (curLoc) +import Clash.Util (curLoc) ghcLibDir :: IO FilePath ghcLibDir = do @@ -158,16 +159,16 @@ return dfPlug let dflags1 = dflags -#if __GLASGOW_HASKELL__ >= 711 - { DynFlags.reductionDepth = 1000 -#else - { DynFlags.ctxtStkDepth = 1000 -#endif - , DynFlags.optLevel = 2 + { DynFlags.optLevel = 2 , DynFlags.ghcMode = GHC.CompManager , DynFlags.ghcLink = GHC.LinkInMemory , DynFlags.hscTarget = DynFlags.defaultObjectTarget (DynFlags.targetPlatform dflags) +#if __GLASGOW_HASKELL__ >= 711 + , DynFlags.reductionDepth = 1000 +#else + , DynFlags.ctxtStkDepth = 1000 +#endif } let dflags2 = wantedOptimizationFlags dflags1 let ghcDynamic = case lookup "GHC Dynamic" (DynFlags.compilerInfo dflags) of @@ -232,6 +233,9 @@ (externalBndrs,clsOps,unlocatable,pFP) <- loadExternalExprs hdl (UniqSet.mkUniqSet binderIds) bindersC + -- Find local primitive annotations + pFP' <- findPrimitiveAnnotations hdl binderIds + hscEnv <- GHC.getSession famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs @@ -263,7 +267,7 @@ Just _ -> return allSyn' _ -> Panic.pgmError $ $(curLoc) ++ "Multiple 'topEntities' found." - return (bindersC ++ makeRecursiveGroups externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntities',nub pFP) + return (bindersC ++ makeRecursiveGroups externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntities',nub $ pFP ++ pFP') -- | Given a set of bindings, make explicit non-recursive bindings and -- recursive binding groups. @@ -363,6 +367,34 @@ qualNm = maybe occName (\modName -> modName ++ ('.':occName)) (modNameM bndrNm) occName = OccName.occNameString (Name.nameOccName bndrNm) +findPrimitiveAnnotations + :: GHC.GhcMonad m + => HDL + -> [CoreSyn.CoreBndr] + -> m [FilePath] +findPrimitiveAnnotations hdl bndrs = do + dflags <- GHC.getSessionDynFlags + + let -- Using the stub directory as the output directory for inline primitives + outDir = fromMaybe "." $ GHC.stubDir dflags +#if MIN_VERSION_ghc(8,4,1) + deserializer = GhcPlugins.deserializeWithData :: ([Word8] -> Primitive) +#else + deserializer = Serialized.deserializeWithData :: ([Word8] -> Primitive) +#endif + targets = + concatMap + ( (\v -> catMaybes + [ Just $ Annotations.NamedTarget v + , Annotations.ModuleTarget <$> Name.nameModule_maybe v + ]) . Var.varName + ) bndrs + + anns <- mapM (GHC.findGlobalAnns deserializer) targets + sequence $ + mapMaybe (primitiveFilePath hdl outDir) + (concat $ zipWith (\t -> map ((,) t)) targets anns) + parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule parseModule modSum = do (GHC.ParsedModule pmModSum pmParsedSource extraSrc anns) <- @@ -488,7 +520,7 @@ rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name rmHSD (GHC.TyClD tyClDecl) = GHC.TyClD (rmTyClD tyClDecl) - rmHSD hsd = hsd + rmHSD hsd = hsd rmTyClD :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name rmTyClD dc@(GHC.DataDecl {}) = dc {GHC.tcdDataDefn = rmDataDefn (GHC.tcdDataDefn dc)} @@ -515,7 +547,7 @@ rmHsType = transform go where go (GHC.unLoc -> GHC.HsBangTy _ ty) = ty - go ty = ty + go ty = ty rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name rmConDeclF cdf = cdf {GHC.cd_fld_type = rmHsType (GHC.cd_fld_type cdf)}