clash-ghc 0.99 → 0.99.1
raw patch · 4 files changed
+141/−62 lines, 4 filesdep ~Win32dep ~ghc-typelits-extradep ~ghc-typelits-knownnatPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: Win32, ghc-typelits-extra, ghc-typelits-knownnat, ghc-typelits-natnormalise
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- clash-ghc.cabal +4/−4
- src-ghc/Clash/GHC/LoadInterfaceFiles.hs +70/−28
- src-ghc/Clash/GHC/LoadModules.hs +62/−30
CHANGELOG.md view
@@ -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`:
clash-ghc.cabal view
@@ -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,
src-ghc/Clash/GHC/LoadInterfaceFiles.hs view
@@ -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
src-ghc/Clash/GHC/LoadModules.hs view
@@ -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)}