diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.5.15 *September 21st 2015* +* New features: + * Report simulation time in (System)Verilog assert messages + +* Fixes bugs: + * Performance bug: top-level definitions of type "Signal" erroneously inlined. + * Fix Index maxBound [#79](https://github.com/clash-lang/clash-compiler/pull/79) + ## 0.5.14 *September 14th 2015* * New features: * Completely unroll "definitions" of some higher-order primitives with non-representable argument or result vectors: 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.14 +Version: 0.5.15 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -94,11 +94,11 @@ unbound-generics >= 0.1 && < 0.3, unordered-containers >= 0.2.1.0, - clash-lib >= 0.5.12 && < 0.6, - clash-systemverilog >= 0.5.9, - clash-vhdl >= 0.5.11, - clash-verilog >= 0.5.9, - clash-prelude >= 0.9.2, + clash-lib >= 0.5.13 && < 0.6, + clash-systemverilog >= 0.5.10, + clash-vhdl >= 0.5.12, + clash-verilog >= 0.5.10, + clash-prelude >= 0.9.3, ghc-typelits-natnormalise >= 0.3 if os(windows) diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -116,8 +116,18 @@ hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do - -- 1. extract the -B flag from the args + +-- Disable CPR analysis in versions older than GHC 7.11 by always inserting the +-- -fcpr-off flag. From GHC 7.11 and up, CPR analysis, specifically the +-- worker/wrapper it creates, can be turned off with a DynFlag. +-- +-- See [NOTE: CPR breaks CLaSH] why the worker/wrapper introduced by the CPR +-- analysis is bad for CLaSH +#if __GLASGOW_HASKELL__ >= 711 argv0 <- getArgs +#else + argv0 <- fmap ("-fcpr-off":) getArgs +#endif libDir <- ghcLibDir let argv1 = map (mkGeneralLocated "on the commandline") argv0 diff --git a/src-ghc/CLaSH/GHC/Evaluator.hs b/src-ghc/CLaSH/GHC/Evaluator.hs --- a/src-ghc/CLaSH/GHC/Evaluator.hs +++ b/src-ghc/CLaSH/GHC/Evaluator.hs @@ -14,14 +14,15 @@ import CLaSH.Core.Literal (Literal (..)) import CLaSH.Core.Term (Term (..)) import CLaSH.Core.Type (Type (..), ConstTy (..), LitTy (..), - TypeView (..), tyView, mkFunTy) + TypeView (..), tyView, mkFunTy, + mkTyConApp, splitFunForallTy) import CLaSH.Core.TyCon (TyCon, TyConName, tyConDataCons) import CLaSH.Core.TysPrim (typeNatKind) import CLaSH.Core.Util (collectArgs,mkApps,mkVec,termType) import CLaSH.Core.Var (Var (..)) reduceConstant :: HashMap.HashMap TyConName TyCon -> Bool -> Term -> Term -reduceConstant tcm isSubj e@(collectArgs -> (Prim nm _, args)) +reduceConstant tcm isSubj e@(collectArgs -> (Prim nm ty, args)) | nm == "GHC.Prim.==#" || nm == "GHC.Integer.Type.eqInteger#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] @@ -90,6 +91,16 @@ [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] -> Literal (IntegerLiteral (i `rem` j)) _ -> e + | nm == "GHC.Prim.quotRemInt#" + = case (map (reduceConstant tcm isSubj) . Either.lefts) args of + [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] + -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty + (Just tupTc) = HashMap.lookup tupTcNm tcm + [tupDc] = tyConDataCons tupTc + (q,r) = quotRem i j + ret = mkApps (Data tupDc) (map Right tyArgs ++ [Left (Literal (IntegerLiteral q)), Left (Literal (IntegerLiteral r))]) + in ret + _ -> e | nm == "GHC.Integer.Type.shiftLInteger" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] @@ -106,32 +117,42 @@ _ -> e | nm == "CLaSH.Sized.Internal.Signed.minBound#" = case args of - [litTy,Left (Literal (IntegerLiteral mb))] + [litTy,kn@(Left (Literal (IntegerLiteral mb)))] -> let minB = negate (2 ^ (mb - 1)) - in mkApps signedConPrim [litTy,Left (Literal (IntegerLiteral minB))] + in mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral minB))] _ -> e | nm == "CLaSH.Sized.Internal.Signed.maxBound#" = case args of - [litTy,Left (Literal (IntegerLiteral mb))] + [litTy,kn@(Left (Literal (IntegerLiteral mb)))] -> let maxB = (2 ^ (mb - 1)) - 1 - in mkApps signedConPrim [litTy,Left (Literal (IntegerLiteral maxB))] + in mkApps signedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))] _ -> e | nm == "CLaSH.Sized.Internal.Unsigned.minBound#" = case args of - [litTy] - -> mkApps unsignedConPrim [litTy,Left (Literal (IntegerLiteral 0))] + [litTy,kn@(Left (Literal (IntegerLiteral _)))] + -> mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral 0))] _ -> e | nm == "CLaSH.Sized.Internal.Unsigned.maxBound#" = case args of - [litTy,Left (Literal (IntegerLiteral mb))] - -> let maxB = 2 ^ mb - in mkApps unsignedConPrim [litTy,Left (Literal (IntegerLiteral maxB))] + [litTy,kn@(Left (Literal (IntegerLiteral mb)))] + -> let maxB = (2 ^ mb) - 1 + in mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))] _ -> e | nm == "CLaSH.Sized.Internal.Signed.toInteger#" || nm == "CLaSH.Sized.Internal.Unsigned.toInteger#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of - [App _ (Literal (IntegerLiteral i))] - -> Literal (IntegerLiteral i) + [collectArgs -> (Prim nm' _,[Right _, Left _, Left (Literal (IntegerLiteral i))])] + | nm' == "CLaSH.Sized.Internal.Signed.fromInteger#" || + nm' == "CLaSH.Sized.Internal.Unsigned.fromInteger#" -> Literal (IntegerLiteral i) _ -> e + | nm == "CLaSH.Sized.Internal.Signed.eq#" || nm == "CLaSH.Sized.Internal.Unsigned.eq#" + = case (map (reduceConstant tcm isSubj) . Either.lefts) args of + [collectArgs -> (Prim _ _,[Right _, Left _, Left (Literal (IntegerLiteral i))]) ,collectArgs -> (Prim _ _,[Right _, Left _, Left (Literal (IntegerLiteral j))])] -> + let (_,tyView -> TyConApp boolTcNm []) = splitFunForallTy ty + (Just boolTc) = HashMap.lookup boolTcNm tcm + [falseDc,trueDc] = tyConDataCons boolTc + retDc = if i == j then trueDc else falseDc + in Data retDc + _ -> e | nm == "GHC.TypeLits.natVal" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), _] -> Literal (IntegerLiteral i) @@ -141,8 +162,8 @@ [(Literal (IntegerLiteral _),[]), (Data _,_)] -> mkApps snatCon args _ -> e | isSubj && nm == "CLaSH.Sized.Vector.replicate" - = let ty = runFreshM (termType tcm e) - in case tyView ty of + = let ty' = runFreshM (termType tcm e) + in case tyView ty' of (TyConApp vecTcNm [LitTy (NumTy len),argTy]) -> let (Just vecTc) = HashMap.lookup vecTcNm tcm [nilCon,consCon] = tyConDataCons vecTc @@ -152,24 +173,24 @@ reduceConstant _ _ e = e signedConPrim :: Term -signedConPrim = Prim "CLaSH.Sized.Internal.Signed.S" (ForAllTy (bind nTV funTy)) - where - funTy = mkFunTy intTy (AppTy signedTy nVar) - intTy = ConstTy (TyCon (string2Name "GHC.Integer.Type.Integer")) - signedTy = ConstTy (TyCon (string2Name "CLaSH.Sized.Internal.Signed.Signed")) - nName = string2Name "n" - nVar = VarTy typeNatKind nName - nTV = TyVar nName (embed typeNatKind) - -unsignedConPrim :: Term -unsignedConPrim = Prim "CLaSH.Sized.Internal.Unsigned.U" (ForAllTy (bind nTV funTy)) +signedConPrim = Prim "CLaSH.Sized.Internal.Signed.fromInteger#" (ForAllTy (bind nTV funTy)) where - funTy = mkFunTy intTy (AppTy unsignedTy nVar) + funTy = foldr1 mkFunTy [intTy,intTy,mkTyConApp signedTcNm [nVar]] intTy = ConstTy (TyCon (string2Name "GHC.Integer.Type.Integer")) - unsignedTy = ConstTy (TyCon (string2Name "CLaSH.Sized.Internal.Unsigned.Unsigned")) + signedTcNm = string2Name "CLaSH.Sized.Internal.Signed.Signed" nName = string2Name "n" nVar = VarTy typeNatKind nName nTV = TyVar nName (embed typeNatKind) + +unsignedConPrim :: Term +unsignedConPrim = Prim "CLaSH.Sized.Internal.Unsigned.fromInteger#" (ForAllTy (bind nTV funTy)) + where + funTy = foldr1 mkFunTy [intTy,intTy,mkTyConApp unsignedTcNm [nVar]] + intTy = ConstTy (TyCon (string2Name "GHC.Integer.Type.Integer")) + unsignedTcNm = string2Name "CLaSH.Sized.Internal.Unsigned.Unsigned" + nName = string2Name "n" + nVar = VarTy typeNatKind nName + nTV = TyVar nName (embed typeNatKind) snatCon :: Term snatCon = Data (MkData snanNm 1 snatTy [nName] [] argTys) 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 @@ -180,7 +180,6 @@ wantedOptimizationFlags df = foldl DynFlags.gopt_unset (foldl DynFlags.gopt_set df wanted) unwanted where wanted = [ Opt_CSE -- CSE - , Opt_FullLaziness -- Floats let-bindings outside enclosing lambdas , Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types , Opt_DoLambdaEtaExpansion -- transform nested series of lambdas into one with multiple arguments, helps us achieve only top-level lambdas , Opt_CaseMerge -- We want fewer case-statements @@ -216,6 +215,9 @@ , Opt_OmitInterfacePragmas -- We need all the unfoldings we can get , Opt_IrrefutableTuples -- Introduce irrefutPatError: avoid , 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] +#endif ] -- [NOTE: CPR breaks CLaSH]