diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.5.6 *May 18th 2015* +* New features: + * Inlining limit is configurable, run with `-clash-inline-limit=N` to set the inlining limit to `N` + * Specialisation limit is configurable, run with `clash-spec-limit=N` to set the inline limit to `N` + * Debug level is configurable, run with `-clash-debug ` where `` can be: `DebugNone, DebugFinal, DebugName, DebugApplied, DebugAll`. Be default, `clash` runs with `DebugNone`. + +* Fixes bugs: + * Extend evaluator for `GHC.Integer.Type.minusInteger` and `CLaSH.Promoted.Nat.SNat`. + ## 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) 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.5 +Version: 0.5.6 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -70,12 +70,11 @@ unbound-generics >= 0.1, unordered-containers >= 0.2.1.0, - 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, - ghc-typelits-natnormalise >= 0.2 + clash-lib >= 0.5.5, + clash-vhdl >= 0.5.4, + clash-systemverilog >= 0.5.4, + clash-prelude >= 0.7.5, + ghc-typelits-natnormalise >= 0.2.1 if os(windows) Build-Depends: Win32 @@ -88,6 +87,7 @@ GhciMonad GhciTags + CLaSH.GHC.CLaSHFlags CLaSH.GHC.Evaluator CLaSH.GHC.GenerateBindings CLaSH.GHC.GHC2Core diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -113,11 +113,11 @@ import CLaSH.Backend.VHDL (VHDLState) import CLaSH.Backend.SystemVerilog (SystemVerilogState) import qualified CLaSH.Driver +import CLaSH.Driver.Types (CLaSHOpts) import CLaSH.GHC.Evaluator import CLaSH.GHC.GenerateBindings import CLaSH.GHC.NetlistTypes import qualified CLaSH.Primitives.Util -import CLaSH.Rewrite.Types (DebugLevel(..)) import CLaSH.Util (clashLibVersion) import qualified Data.Version as Data.Version import qualified Paths_clash_ghc @@ -132,10 +132,10 @@ defPrompt2 :: String } -defaultGhciSettings :: GhciSettings -defaultGhciSettings = +defaultGhciSettings :: IORef CLaSHOpts -> GhciSettings +defaultGhciSettings opts = GhciSettings { - availableCommands = ghciCommands, + availableCommands = ghciCommands opts, shortHelpText = defShortHelpText, fullHelpText = defFullHelpText, defPrompt = default_prompt, @@ -152,8 +152,8 @@ GLOBAL_VAR(macros_ref, [], [Command]) -ghciCommands :: [Command] -ghciCommands = [ +ghciCommands :: IORef CLaSHOpts -> [Command] +ghciCommands opts = [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap ("?", keepGoing help, noCompletion), ("add", keepGoingPaths addModule, completeFilename), @@ -204,8 +204,8 @@ ("trace", keepGoing traceCmd, completeExpression), ("undef", keepGoing undefineMacro, completeMacro), ("unset", keepGoing unsetOptions, completeSetOptions), - ("vhdl", keepGoingPaths makeVHDL, completeHomeModuleOrFile), - ("systemverilog", keepGoingPaths makeSystemVerilog, completeHomeModuleOrFile) + ("vhdl", keepGoingPaths (makeVHDL opts), completeHomeModuleOrFile), + ("systemverilog", keepGoingPaths (makeSystemVerilog opts), completeHomeModuleOrFile) ] @@ -1556,9 +1556,10 @@ makeHDL' :: CLaSH.Backend.Backend backend => backend + -> IORef CLaSHOpts -> [FilePath] -> InputT GHCi () -makeHDL' backend lst = makeHDL backend =<< case lst of +makeHDL' backend opts lst = makeHDL backend opts =<< case lst of srcs@(_:_) -> return srcs [] -> do modGraph <- GHC.getModuleGraph @@ -1570,21 +1571,23 @@ makeHDL :: GHC.GhcMonad m => CLaSH.Backend.Backend backend => backend + -> IORef CLaSHOpts -> [FilePath] -> m () -makeHDL backend srcs = do +makeHDL backend optsRef srcs = do dflags <- GHC.getSessionDynFlags - liftIO $ do primDir <- CLaSH.Backend.primDir backend + liftIO $ do opts <- readIORef optsRef + primDir <- CLaSH.Backend.primDir backend primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] forM_ srcs $ \src -> do (bindingsMap,tcm,topEntM) <- generateBindings primMap src (Just dflags) CLaSH.Driver.generateHDL bindingsMap (Just backend) primMap tcm - ghcTypeToHWType reduceConstant topEntM DebugNone + ghcTypeToHWType reduceConstant topEntM opts -makeVHDL :: [FilePath] -> InputT GHCi () +makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi () makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState) -makeSystemVerilog :: [FilePath] -> InputT GHCi () +makeSystemVerilog :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi () makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: SystemVerilogState) ----------------------------------------------------------------------------- diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -68,12 +68,16 @@ import Paths_clash_ghc import InteractiveUI (makeHDL) import Exception (gcatch) +import Data.IORef (IORef, newIORef) import qualified Data.Version (showVersion) import Control.Exception (ErrorCall (..)) import qualified CLaSH.Backend import CLaSH.Backend.VHDL (VHDLState) import CLaSH.Backend.SystemVerilog (SystemVerilogState) +import CLaSH.Driver.Types (CLaSHOpts (..)) +import CLaSH.GHC.CLaSHFlags +import CLaSH.Rewrite.Types (DebugLevel (..)) import CLaSH.Util (clashLibVersion) ghcLibDir :: IO FilePath @@ -118,10 +122,16 @@ let argv1 = map (mkGeneralLocated "on the commandline") argv0 (argv2, staticFlagWarnings) <- parseStaticFlags argv1 + r <- newIORef (CLaSHOpts { opt_dbgLevel = DebugNone + , opt_inlineLimit = 20 + , opt_specLimit = 20 + }) + (argv3, clashFlagWarnings) <- parseCLaSHFlags r argv2 + -- 2. Parse the "mode" flags (--make, --interactive etc.) - (mode, argv3, modeFlagWarnings) <- parseModeFlags argv2 + (mode, argv4, modeFlagWarnings) <- parseModeFlags argv3 - let flagWarnings = staticFlagWarnings ++ modeFlagWarnings + let flagWarnings = staticFlagWarnings ++ modeFlagWarnings ++ clashFlagWarnings -- If all we want to do is something like showing the version number -- then do it now, before we start a GHC session etc. This makes @@ -175,11 +185,12 @@ ShowGhciUsage -> showGhciUsage dflagsExtra2 PrintWithDynFlags f -> putStrLn (f dflagsExtra2) Right postLoadMode -> - main' postLoadMode dflagsExtra2 argv3 flagWarnings + main' postLoadMode dflagsExtra2 argv4 flagWarnings r main' :: PostLoadMode -> DynFlags -> [Located String] -> [Located String] + -> IORef CLaSHOpts -> Ghc () -main' postLoadMode dflags0 args flagWarnings = do +main' postLoadMode dflags0 args flagWarnings clashOpts = do -- set the default GhcMode, HscTarget and GhcLink. The HscTarget -- can be further adjusted on a module by module basis, using only -- the -fvia-C and -fasm flags. If the default HscTarget is not @@ -280,14 +291,14 @@ handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do - let clash fun = gcatch (fun srcs) (\(ErrorCall e) -> throwOneError $ mkPlainErrMsg dflags6 noSrcSpan (text ("CLaSH Error:\n" ++ e))) + let clash fun = gcatch (fun clashOpts srcs) (\(ErrorCall e) -> throwOneError $ mkPlainErrMsg dflags6 noSrcSpan (text ("CLaSH Error:\n" ++ e))) case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs DoMkDependHS -> doMkDependHS (map fst srcs) StopBefore p -> liftIO (oneShot hsc_env p srcs) - DoInteractive -> ghciUI srcs Nothing - DoEval exprs -> ghciUI srcs $ Just $ reverse exprs + DoInteractive -> ghciUI clashOpts srcs Nothing + DoEval exprs -> ghciUI clashOpts srcs $ Just $ reverse exprs DoAbiHash -> abiHash (map fst srcs) ShowPackages -> liftIO $ showPackages dflags6 DoVHDL -> clash makeVHDL @@ -295,11 +306,11 @@ liftIO $ dumpFinalStats dflags6 -ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () +ghciUI :: IORef CLaSHOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #ifndef GHCI -ghciUI _ _ = throwGhcException (CmdLineError "not built for interactive use") +ghciUI _ _ _ = throwGhcException (CmdLineError "not built for interactive use") #else -ghciUI = interactiveUI defaultGhciSettings +ghciUI opts = interactiveUI (defaultGhciSettings opts) #endif -- ----------------------------------------------------------------------------- @@ -921,14 +932,14 @@ -- ----------------------------------------------------------------------------- -- VHDL Generation -makeHDL' :: CLaSH.Backend.Backend backend => backend -> [(String,Maybe Phase)] -> Ghc () -makeHDL' _ [] = throwGhcException (CmdLineError "No input files") -makeHDL' backend srcs = makeHDL backend $ fmap fst srcs +makeHDL' :: CLaSH.Backend.Backend backend => backend -> IORef CLaSHOpts -> [(String,Maybe Phase)] -> Ghc () +makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files") +makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs -makeVHDL :: [(String, Maybe Phase)] -> Ghc () +makeVHDL :: IORef CLaSHOpts -> [(String, Maybe Phase)] -> Ghc () makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState) -makeSystemVerilog :: [(String, Maybe Phase)] -> Ghc () +makeSystemVerilog :: IORef CLaSHOpts -> [(String, Maybe Phase)] -> Ghc () makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: SystemVerilogState) -- ----------------------------------------------------------------------------- diff --git a/src-ghc/CLaSH/GHC/CLaSHFlags.hs b/src-ghc/CLaSH/GHC/CLaSHFlags.hs new file mode 100644 --- /dev/null +++ b/src-ghc/CLaSH/GHC/CLaSHFlags.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TupleSections #-} +module CLaSH.GHC.CLaSHFlags + ( parseCLaSHFlags + ) +where + +import CmdLineParser +import Panic +import SrcLoc + +import Data.IORef +import Control.Monad +import CLaSH.Driver.Types +import Text.Read (readMaybe) + +parseCLaSHFlags :: IORef CLaSHOpts -> [Located String] + -> IO ([Located String],[Located String]) +parseCLaSHFlags r = parseCLaSHFlagsFull (flagsClash r) + +parseCLaSHFlagsFull :: [Flag IO] -> [Located String] + -> IO ([Located String],[Located String]) +parseCLaSHFlagsFull flagsAvialable args = do + (leftovers,errs,warns) <- processArgs flagsAvialable args + + unless (null errs) $ throwGhcExceptionIO $ + errorsToGhcException . map (("on the commandline", ) . unLoc) $ errs + + return (leftovers, warns) + +flagsClash :: IORef CLaSHOpts -> [Flag IO] +flagsClash r = [ + defFlag "clash-inline-limit" (IntSuffix (liftEwM . setInlineLimit r)) + , defFlag "clash-spec-limit" (IntSuffix (liftEwM . setSpecLimit r)) + , defFlag "clash-debug" (SepArg (setDebugLevel r)) + ] + +setInlineLimit :: IORef CLaSHOpts + -> Int + -> IO () +setInlineLimit r n = modifyIORef r (\c -> c {opt_inlineLimit = n}) + +setSpecLimit :: IORef CLaSHOpts + -> Int + -> IO () +setSpecLimit r n = modifyIORef r (\c -> c {opt_specLimit = n}) + +setDebugLevel :: IORef CLaSHOpts + -> String + -> EwM IO () +setDebugLevel r s = case readMaybe s of + Just dbgLvl -> liftEwM $ modifyIORef r (\c -> c {opt_dbgLevel = dbgLvl}) + Nothing -> addWarn (s ++ " is an invalid debug level") 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 @@ -9,7 +9,7 @@ import qualified Data.List as List import Unbound.Generics.LocallyNameless (bind, embed, string2Name) -import CLaSH.Core.DataCon (dcTag) +import CLaSH.Core.DataCon (DataCon (..)) import CLaSH.Core.Literal (Literal (..)) import CLaSH.Core.Term (Term (..)) import CLaSH.Core.Type (Type (..), ConstTy (..), mkFunTy) @@ -68,6 +68,11 @@ [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] -> Literal (IntegerLiteral (i * j)) _ -> e + | nm == "GHC.Integer.Type.minusInteger" + = case (map (reduceConstant tcm) . Either.lefts) args of + [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] + -> Literal (IntegerLiteral (i - j)) + _ -> e | nm == "GHC.Integer.Type.divInteger" = case (map (reduceConstant tcm) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] @@ -119,6 +124,10 @@ = case (map (reduceConstant tcm) . Either.lefts) args of [Literal (IntegerLiteral i), _] -> Literal (IntegerLiteral i) _ -> e + | nm == "CLaSH.Promoted.Nat.SNat" + = case (map collectArgs . Either.lefts) args of + [(Literal (IntegerLiteral _),[]), (Data _,_)] -> mkApps snatCon args + _ -> e reduceConstant _ e = e @@ -141,3 +150,18 @@ nName = string2Name "n" nVar = VarTy typeNatKind nName nTV = TyVar nName (embed typeNatKind) + +snatCon :: Term +snatCon = Data (MkData snanNm 1 snatTy [nName] [] argTys) + where + snanNm = string2Name "CLaSH.Promoted.Nat.SNat" + snatTy = ForAllTy (bind nTV funTy) + argTys = [ConstTy (TyCon (string2Name "GHC.Integer.Type.Integer")) + ,AppTy (AppTy (ConstTy (TyCon (string2Name "Data.Proxy.Proxy"))) typeNatKind) + nVar + ] + funTy = foldr mkFunTy (ConstTy (TyCon (string2Name "CLaSH.Promoted.Nat.SNat"))) argTys + nName = string2Name "n" + nVar = VarTy typeNatKind nName + nTV = TyVar nName (embed typeNatKind) +