diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,34 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.6.1 *October 16th 2015* +* New features: + * Support for `clash-prelude` 0.10.1 + * Transformation that lifts applications of the same function out of alternatives of case-statements. e.g. + + ```haskell + case x of + A -> f 3 y + B -> f x x + C -> h x + ``` + + is transformed into: + + ```haskell + let f_arg0 = case x of {A -> 3; B -> x} + f_arg1 = case x of {A -> y; B -> x} + f_out = f f_arg0 f_arg1 + in case x of + A -> f_out + B -> f_out + C -> h x + ``` + +* Fixes bugs: + * clash won't run when not compiled with usual ghc [#82](https://github.com/clash-lang/clash-compiler/issues/82) + * Fail to generate VHDL with blockRamFile' in clash-ghc 0.6 [#85](https://github.com/clash-lang/clash-compiler/issues/85) + * Case-statements acting like normal decoder circuits are erroneously synthesised to priority decoder circuits. + ## 0.6 *October 3rd 2015* * New features: * Support `clash-prelude-0.10` 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 +Version: 0.6.1 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.6 && < 0.7, - clash-systemverilog >= 0.6, - clash-vhdl >= 0.6, - clash-verilog >= 0.6, - clash-prelude >= 0.10, + clash-lib >= 0.6.1 && < 0.7, + clash-systemverilog >= 0.6.1, + clash-vhdl >= 0.6.1, + clash-verilog >= 0.6.1, + clash-prelude >= 0.10.1, ghc-typelits-natnormalise >= 0.3 if os(windows) diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -1584,9 +1584,9 @@ primDir <- CLaSH.Backend.primDir backend primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] forM_ srcs $ \src -> do - (bindingsMap,tcm,topEntM) <- generateBindings primMap src (Just dflags) + (bindingsMap,tcm,tupTcm,topEntM) <- generateBindings primMap src (Just dflags) CLaSH.Driver.generateHDL bindingsMap (Just backend) primMap tcm - ghcTypeToHWType reduceConstant topEntM opts + tupTcm ghcTypeToHWType reduceConstant topEntM opts makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi () makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState) diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -64,7 +64,6 @@ import Data.Maybe -- clash additions -import System.Process (runInteractiveCommand, waitForProcess) import Paths_clash_ghc import InteractiveUI (makeHDL) import Exception (gcatch) @@ -80,23 +79,7 @@ import CLaSH.GHC.CLaSHFlags import CLaSH.Rewrite.Types (DebugLevel (..)) import CLaSH.Util (clashLibVersion) - -ghcLibDir :: IO FilePath -ghcLibDir = do (libDir,exitCode) <- getProcessOutput "ghc --print-libdir" - case exitCode of - ExitSuccess -> return libDir - ExitFailure i -> error $ "Calling GHC failed with: " ++ show i - -getProcessOutput :: String -> IO (String, ExitCode) -getProcessOutput command = - -- Create the process - do (_, pOut, _, handle) <- runInteractiveCommand command - -- Wait for the process to finish and store its exit code - exitCode <- waitForProcess handle - -- Get the standard output. - output <- hGetLine pOut - -- return both the output and the exit code. - return (output, exitCode) +import CLaSH.GHC.LoadModules (ghcLibDir) ----------------------------------------------------------------------------- -- ToDo: 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 @@ -71,6 +71,15 @@ [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] -> Literal (IntegerLiteral (i * j)) _ -> e + | nm == "GHC.Integer.Type.eqInteger" + = case (map (reduceConstant tcm isSubj) . Either.lefts) args of + [Literal (IntegerLiteral i), 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.Integer.Type.minusInteger" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)] diff --git a/src-ghc/CLaSH/GHC/GHC2Core.hs b/src-ghc/CLaSH/GHC/GHC2Core.hs --- a/src-ghc/CLaSH/GHC/GHC2Core.hs +++ b/src-ghc/CLaSH/GHC/GHC2Core.hs @@ -8,8 +8,11 @@ module CLaSH.GHC.GHC2Core ( GHC2CoreState + , tyConMap , coreToTerm , coreToId + , coreToName + , qualfiedNameString , makeAllTyCons , emptyGHC2CoreState ) 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 @@ -2,18 +2,24 @@ (generateBindings) where +import Control.Lens ((%~),(&)) import Control.Monad.State (State) import qualified Control.Monad.State as State import Data.Either (lefts, rights) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IM import Data.List (isSuffixOf) import qualified Data.Set as Set import qualified Data.Set.Lens as Lens import Unbound.Generics.LocallyNameless (name2String, runFreshM, unembed) +import qualified BasicTypes as GHC import qualified CoreSyn as GHC import qualified DynFlags as GHC +import qualified TyCon as GHC +import qualified TysWiredIn as GHC import CLaSH.Annotations.TopEntity (TopEntity) import CLaSH.Core.FreeVars (termFreeIds) @@ -25,8 +31,8 @@ import CLaSH.Core.Util (mkLams, mkTyLams, termType) import CLaSH.Core.Var (Var (..)) import CLaSH.Driver.Types (BindingMap) -import CLaSH.GHC.GHC2Core (GHC2CoreState, coreToId, coreToTerm, - makeAllTyCons, emptyGHC2CoreState) +import CLaSH.GHC.GHC2Core (GHC2CoreState, tyConMap, coreToId, coreToName, coreToTerm, + makeAllTyCons, qualfiedNameString, emptyGHC2CoreState) import CLaSH.GHC.LoadModules (loadModules) import CLaSH.Normalize.Util import CLaSH.Primitives.Types (PrimMap) @@ -37,16 +43,17 @@ PrimMap -> String -> Maybe (GHC.DynFlags) - -> IO (BindingMap,HashMap TyConName TyCon,Maybe TopEntity) + -> IO (BindingMap,HashMap TyConName TyCon,IntMap TyConName,Maybe TopEntity) generateBindings primMap modName dflagsM = do (bindings,clsOps,unlocatable,fiEnvs,topEntM) <- loadModules modName dflagsM let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState - tcCache = makeAllTyCons tcMap fiEnvs + (tcMap',tupTcCache) = mkTupTyCons tcMap + tcCache = makeAllTyCons tcMap' fiEnvs allTcCache = tysPrimMap `HashMap.union` tcCache clsMap = HashMap.map (\(ty,i) -> (ty,mkClassSelector allTcCache ty i)) clsVMap allBindings = bindingsMap `HashMap.union` clsMap droppedAndRetypedBindings = dropAndRetypeBindings allTcCache allBindings - return (droppedAndRetypedBindings,allTcCache,topEntM) + return (droppedAndRetypedBindings,allTcCache,tupTcCache,topEntM) dropAndRetypeBindings :: HashMap TyConName TyCon -> BindingMap -> BindingMap dropAndRetypeBindings allTcCache allBindings = oBindings @@ -131,7 +138,7 @@ newExpr = case coreView tcm dictTy of (TyConApp _ _) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do (dcId,dcVar) <- mkInternalVar "dict" dictTy - selE <- mkSelectorCase "mkClassSelector" tcm [] dcVar 1 sel + selE <- mkSelectorCase "mkClassSelector" tcm dcVar 1 sel return (mkTyLams (mkLams selE [dcId]) tvs) (FunTy arg res) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do (dcId,dcVar) <- mkInternalVar "dict" (mkFunTy arg res) @@ -139,3 +146,12 @@ (OtherType oTy) -> runFreshM $ flip State.evalStateT (0 :: Int) $ do (dcId,dcVar) <- mkInternalVar "dict" oTy return (mkTyLams (mkLams dcVar [dcId]) tvs) + +mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName) +mkTupTyCons tcMap = (tcMap'',tupTcCache) + where + tupTyCons = map (GHC.tupleTyCon GHC.BoxedTuple) [2..62] + (tcNames,tcMap') = State.runState (mapM (\tc -> coreToName GHC.tyConName GHC.tyConUnique qualfiedNameString tc) tupTyCons) tcMap + tupTcCache = IM.fromList (zip [2..62] tcNames) + tupHM = HashMap.fromList (zip tcNames tupTyCons) + tcMap'' = tcMap' & tyConMap %~ (`HashMap.union` tupHM) 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 @@ -4,6 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} module CLaSH.GHC.LoadModules ( loadModules + , ghcLibDir ) where @@ -41,7 +42,7 @@ import CLaSH.Util (curLoc,first) ghcLibDir :: IO FilePath -ghcLibDir = do (libDir,exitCode) <- getProcessOutput "ghc --print-libdir" +ghcLibDir = do (libDir,exitCode) <- getProcessOutput $ "ghc-" ++ TOOL_VERSION_ghc ++ " --print-libdir" case exitCode of ExitSuccess -> return libDir ExitFailure i -> error $ "Calling GHC failed with: " ++ show i diff --git a/src-ghc/CLaSH/GHC/NetlistTypes.hs b/src-ghc/CLaSH/GHC/NetlistTypes.hs --- a/src-ghc/CLaSH/GHC/NetlistTypes.hs +++ b/src-ghc/CLaSH/GHC/NetlistTypes.hs @@ -53,9 +53,9 @@ elHWTy <- ExceptT $ return $ coreTypeToHWType ghcTypeToHWType m elTy return $ Vector sz elHWTy - "String" -> return Void + "String" -> return String "GHC.Types.[]" -> case tyView (head args) of - (TyConApp (name2String -> "GHC.Types.Char") []) -> return Void + (TyConApp (name2String -> "GHC.Types.Char") []) -> return String _ -> fail $ "Can't translate type: " ++ showDoc ty _ -> case m ! tc of