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.24 *October 17th 20168 +* Call generatePrimMap after loadModules [#175](https://github.com/clash-lang/clash-compiler/pull/175) +* Fixes bugs: + * (System)Verilog: CLaSH.Sized.Vector.imap primitive gets indices in reverse order + * Template Haskell splices are run twice + * CLaSH errors out when observing the constructor for `Signal` [#174](https://github.com/clash-lang/clash-compiler/issues/174) + ## 0.6.23 *August 18th 2015* * Fixes bugs: * Type families are not being reduced correctly [#167](https://github.com/clash-lang/clash-compiler/issues/167) 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.23 +Version: 0.6.24 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -87,7 +87,7 @@ process >= 1.2 && < 1.5, hashable >= 1.1.2.3 && < 1.3, haskeline >= 0.7.0.3 && < 0.8, - lens >= 4.0.5 && < 4.15, + lens >= 4.0.5 && < 4.16, mtl >= 2.1.1 && < 2.3, text >= 0.11.3.1 && < 1.3, transformers >= 0.4.2 && < 0.6, @@ -95,9 +95,9 @@ unordered-containers >= 0.2.1.0 && < 0.3, clash-lib >= 0.6.21 && < 0.7, - clash-systemverilog >= 0.6.9 && < 0.7, + clash-systemverilog >= 0.6.10 && < 0.7, clash-vhdl >= 0.6.16 && < 0.7, - clash-verilog >= 0.6.9 && < 0.7, + clash-verilog >= 0.6.10 && < 0.7, clash-prelude >= 0.10.13 && < 0.11, ghc-typelits-extra >= 0.1.3 && < 0.2, ghc-typelits-natnormalise >= 0.4.3 && < 0.6, diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -115,7 +115,6 @@ import CLaSH.GHC.GenerateBindings import CLaSH.GHC.NetlistTypes import CLaSH.Netlist.BlackBox.Types (HdlSyn) -import qualified CLaSH.Primitives.Util import CLaSH.Util (clashLibVersion) import Control.DeepSeq import qualified Data.Time.Clock as Clock @@ -1593,9 +1592,8 @@ else Nothing opts' = opts {opt_hdlDir = maybe outputDir Just (opt_hdlDir opts)} primDir <- CLaSH.Backend.primDir (backend iw syn) - primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] forM_ srcs $ \src -> do - (bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM) <- generateBindings primMap src (Just dflags) + (bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM,primMap) <- generateBindings primDir src (Just dflags) prepTime <- startTime `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime let prepStartDiff = Clock.diffUTCTime prepTime startTime putStrLn $ "Loading dependencies took " ++ show prepStartDiff diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -149,7 +149,7 @@ do case preStartupMode of ShowSupportedExtensions -> showSupportedExtensions ShowVersion -> showVersion - ShowNumVersion -> putStrLn (Data.Version.showVersion Paths_clash_ghc.version) + ShowNumVersion -> putStrLn cProjectVersion ShowOptions isInteractive -> showOptions isInteractive Right postStartupMode -> -- start our GHC session 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 @@ -16,6 +16,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM +import Data.Text.Lazy (Text) import qualified Data.Set as Set import qualified Data.Set.Lens as Lens import Unbound.Generics.LocallyNameless (runFreshM, unembed) @@ -44,19 +45,22 @@ import CLaSH.GHC.LoadModules (loadModules) import CLaSH.Normalize.Util import CLaSH.Primitives.Types (PrimMap) +import CLaSH.Primitives.Util (generatePrimMap) import CLaSH.Rewrite.Util (mkInternalVar, mkSelectorCase) import CLaSH.Util ((***),first) generateBindings :: - PrimMap a + FilePath -> String -> Maybe (GHC.DynFlags) -> 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 + ,Maybe TmName -- expectedOutput bndr + ,PrimMap Text) -- The primitives found in '.' and 'primDir' +generateBindings primDir modName dflagsM = do (bindings,clsOps,unlocatable,fiEnvs,(topEnt,topEntAnn),testInpM,expOutM) <- loadModules modName dflagsM + primMap <- generatePrimMap [primDir,"."] let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState (tcMap',tupTcCache) = mkTupTyCons tcMap tcCache = makeAllTyCons tcMap' fiEnvs @@ -70,7 +74,7 @@ return (topEnt'',testInpM'',expOutM'') droppedAndRetypedBindings = dropAndRetypeBindings allTcCache allBindings topEnt' testInpM' expOutM' - return (droppedAndRetypedBindings,allTcCache,tupTcCache,(topEnt',topEntAnn),testInpM',expOutM') + return (droppedAndRetypedBindings,allTcCache,tupTcCache,(topEnt',topEntAnn),testInpM',expOutM',primMap) dropAndRetypeBindings :: HashMap TyConName TyCon -> BindingMap 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 @@ -146,72 +146,82 @@ _ <- GHC.setSessionDynFlags dflags3 target <- GHC.guessTarget modName Nothing GHC.setTargets [target] - ldRes <- GHC.load GHC.LoadAllTargets - case ldRes of - GHC.Succeeded -> do - modGraph <- GHC.getModuleGraph - let modGraph' = map disableOptimizationsFlags modGraph - tidiedMods <- mapM (\m -> do { pMod <- parseModule m - ; tcMod <- GHC.typecheckModule pMod - ; dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod - ; hsc_env <- GHC.getSession - ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod - ; (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env simpl_guts - ; let pgm = HscTypes.cg_binds tidy_guts - ; let modFamInstEnv = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcMod - ; return (CoreSyn.flattenBinds pgm,modFamInstEnv) - } - ) modGraph' - - let (binders,modFamInstEnvs) = first concat $ unzip tidiedMods - modFamInstEnvs' = foldr UniqFM.plusUFM UniqFM.emptyUFM modFamInstEnvs + modGraph <- GHC.depanal [] False + let modGraph' = map disableOptimizationsFlags modGraph + modGraph2 = Digraph.flattenSCCs (GHC.topSortModuleGraph True modGraph' Nothing) + tidiedMods <- mapM (\m -> do { pMod <- parseModule m + ; tcMod <- GHC.typecheckModule pMod + -- The purpose of the home package table (HPT) is to track + -- the already compiled modules, so subsequent modules can + -- rely/use those compilation results + -- + -- We need to update the home package table (HPT) ourselves + -- as we can no longer depend on 'GHC.load' to create a + -- proper HPT. + -- + -- The reason we have to cannot rely on 'GHC.load' is that + -- it runs the rename/type-checker, which we also run in + -- the code above. This would mean that the renamer/type-checker + -- is run twice, which in turn means that template haskell + -- splices are run twice. + -- + -- Given that TH splices can do non-trivial computation and I/O, + -- running TH twice must be avoid. + ; tcMod' <- GHC.loadModule tcMod + ; dsMod <- fmap GHC.coreModule $ GHC.desugarModule tcMod' + ; hsc_env <- GHC.getSession + ; simpl_guts <- MonadUtils.liftIO $ HscMain.hscSimplify hsc_env dsMod + ; (tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env simpl_guts + ; let pgm = HscTypes.cg_binds tidy_guts + ; let modFamInstEnv = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcMod + ; return (CoreSyn.flattenBinds pgm,modFamInstEnv) + } + ) modGraph2 - (externalBndrs,clsOps,unlocatable) <- loadExternalExprs - (map snd binders) - (map fst binders) + let (binders,modFamInstEnvs) = first concat $ unzip tidiedMods + modFamInstEnvs' = foldr UniqFM.plusUFM UniqFM.emptyUFM modFamInstEnvs - hscEnv <- GHC.getSession - famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs + (externalBndrs,clsOps,unlocatable) <- loadExternalExprs + (map snd binders) + (map fst binders) - let rootModule = GHC.ms_mod_name . last - . Digraph.flattenSCC - . last - $ GHC.topSortModuleGraph True modGraph Nothing + hscEnv <- GHC.getSession + famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs - rootBndrs = filter (maybe False - ((== rootModule) - . Module.moduleName) - . Name.nameModule_maybe - . Var.varName) - (map fst binders) + let rootModule = GHC.ms_mod_name . last $ modGraph2 + 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." + 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 + return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs'),topEntity,testInput,expectedOutput) findCLaSHAnnotations :: GHC.GhcMonad m => [CoreSyn.CoreBndr] @@ -266,7 +276,9 @@ , Opt_FloatIn -- Moves let-bindings inwards, although it defeats the normal-form with a single top-level let-binding, it helps with other transformations , Opt_DictsStrict -- Hopefully helps remove class method selectors , Opt_DmdTxDictSel -- I think demand and strictness are related, strictness helps with dead-code, enable +#if __GLASGOW_HASKELL__ >= 711 , Opt_Strictness -- Strictness analysis helps with dead-code analysis. However, see [NOTE: CPR breaks CLaSH] +#endif ] unwanted = [ Opt_LiberateCase -- Perform unrolling of recursive RHS: avoid @@ -290,6 +302,12 @@ , Opt_Loopification -- STG pass, don't care #if __GLASGOW_HASKELL__ >= 711 , Opt_CprAnal -- The worker/wrapper introduced by CPR breaks CLaSH, see [NOTE: CPR breaks CLaSH] +#else + , Opt_Strictness -- Strictness analysis helps with dead-code analysis. However, see [NOTE: CPR breaks CLaSH] + -- So, strictness analysis must be disabled completely on GHC versions below 8.0, + -- because strictness analysis implies demand analysis, which implies CPR analysis, + -- which cannot be completely disabled due to https://ghc.haskell.org/trac/ghc/ticket/10696. + -- This bug shows itself as: https://github.com/clash-lang/clash-compiler/issues/174 #endif ]