clash-ghc 0.6.19 → 0.6.20
raw patch · 8 files changed
+189/−56 lines, 8 filesdep ~clash-libdep ~clash-preludedep ~clash-systemverilog
Dependency ranges changed: clash-lib, clash-prelude, clash-systemverilog, clash-verilog, clash-vhdl, ghc-typelits-extra, ghc-typelits-natnormalise
Files
- CHANGELOG.md +10/−0
- clash-ghc.cabal +11/−11
- src-bin/Main.hs +28/−4
- src-ghc/CLaSH/GHC/CLaSHFlags.hs +4/−0
- src-ghc/CLaSH/GHC/Evaluator.hs +6/−4
- src-ghc/CLaSH/GHC/GHC2Core.hs +116/−26
- src-ghc/CLaSH/GHC/GenerateBindings.hs +10/−7
- src-ghc/CLaSH/GHC/NetlistTypes.hs +4/−4
CHANGELOG.md view
@@ -1,5 +1,15 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.6.20 *July 15th 2016*+* New features:+ * Better error location reporting+* Fixes bugs:+ * `CLaSH.Sized.Internal.Unsigned.maxBound#` not evaluated at compile-time [#155](https://github.com/clash-lang/clash-compiler/issues/155)+ * `CLaSH.Sized.Internal.Unsigned.minBound#` not evaluated at compile-time [#157](https://github.com/clash-lang/clash-compiler/issues/157)+ * Values of type Index 'n', where 'n' > 2^MACHINE_WIDTH, incorrectly considered non-synthesisable due to overflow+ * VHDL: Types in generated types.vhdl incorrectly sorted+ * Casts of CLaSH numeric types result in incorrect VHDL/Verilog (Such casts are now reported as an error)+ ## 0.6.19 *June 9th 2016* * Fixes bugs: * `Eq` instance of `Vec` sometimes not synthesisable
clash-ghc.cabal view
@@ -1,5 +1,5 @@ Name: clash-ghc-Version: 0.6.19+Version: 0.6.20 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -84,25 +84,25 @@ directory >= 1.2 && < 1.3, filepath >= 1.3 && < 1.5, ghc >= 7.10.1 && < 7.12,- process >= 1.2 && < 1.3,+ 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, mtl >= 2.1.1 && < 2.3, text >= 0.11.3.1 && < 1.3,- transformers >= 0.4.2 && < 0.5,+ transformers >= 0.4.2 && < 0.6, unbound-generics >= 0.1 && < 0.4, unordered-containers >= 0.2.1.0 && < 0.3, - clash-lib >= 0.6.17 && < 0.7,- clash-systemverilog >= 0.6.6 && < 0.7,- clash-vhdl >= 0.6.13 && < 0.7,- clash-verilog >= 0.6.6 && < 0.7,- clash-prelude >= 0.10.9 && < 0.11,- ghc-typelits-extra >= 0.1 && < 0.2,- ghc-typelits-natnormalise >= 0.3 && < 0.5,+ clash-lib >= 0.6.18 && < 0.7,+ clash-systemverilog >= 0.6.7 && < 0.7,+ clash-vhdl >= 0.6.14 && < 0.7,+ clash-verilog >= 0.6.7 && < 0.7,+ clash-prelude >= 0.10.10 && < 0.11,+ ghc-typelits-extra >= 0.1.2 && < 0.2,+ ghc-typelits-natnormalise >= 0.4.2 && < 0.5, deepseq >= 1.3.0.2 && < 1.5,- time >= 1.4.0.1 && <1.6+ time >= 1.4.0.1 && < 1.7 if os(windows) Build-Depends: Win32 >= 2.3.1 && < 2.4
src-bin/Main.hs view
@@ -69,15 +69,15 @@ import Paths_clash_ghc import InteractiveUI (makeHDL) import Exception (gcatch)-import Data.IORef (IORef, newIORef)+import Data.IORef (IORef, newIORef, readIORef) import qualified Data.Version (showVersion)-import Control.Exception (ErrorCall (..))+import Control.Exception (Exception(..),ErrorCall (..),throw) import qualified CLaSH.Backend import CLaSH.Backend.SystemVerilog (SystemVerilogState) import CLaSH.Backend.VHDL (VHDLState) import CLaSH.Backend.Verilog (VerilogState)-import CLaSH.Driver.Types (CLaSHOpts (..))+import CLaSH.Driver.Types (CLaSHOpts (..), CLaSHException (..)) import CLaSH.GHC.CLaSHFlags import CLaSH.Netlist.BlackBox.Types (HdlSyn (..)) import CLaSH.Rewrite.Types (DebugLevel (..))@@ -127,6 +127,7 @@ , opt_intWidth = WORD_SIZE_IN_BITS , opt_hdlDir = Nothing , opt_hdlSyn = Other+ , opt_errorExtra = False }) (argv3, clashFlagWarnings) <- parseCLaSHFlags r argv2 @@ -298,7 +299,8 @@ handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do- let clash fun = gcatch (fun clashOpts srcs) (\(ErrorCall e) -> throwOneError $ mkPlainErrMsg dflags6 noSrcSpan (text ("CLaSH Error:\n" ++ e)))+ clashOpts' <- liftIO (readIORef clashOpts)+ let clash fun = gcatch (fun clashOpts srcs) (handleCLaSHException dflags6 clashOpts') case postLoadMode of ShowInterface f -> liftIO $ doShowIface dflags6 f DoMake -> doMake srcs@@ -313,6 +315,28 @@ DoSystemVerilog -> clash makeSystemVerilog liftIO $ dumpFinalStats dflags6++handleCLaSHException df opts e = case fromException e of+ Just (CLaSHException sp s eM) ->+ throwOneError (mkPlainErrMsg df sp (text s $$ blankLine $$ srcInfo $$ showExtra (opt_errorExtra opts) eM))+ _ -> case fromException e of+ Just (ErrorCall msg) ->+ throwOneError (mkPlainErrMsg df noSrcSpan (text "CLaSH error call:" $$ text msg))+ _ -> throwOneError (mkPlainErrMsg df noSrcSpan (text "Other error:" $$ text (displayException e)))+ where+ srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$+ text "The actual location of the error can be in a function that is inlined." $$+ text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."++ showExtra False (Just _) =+ blankLine $$+ text "This error contains additional information, rerun with '-clash-error-extra' to show this information."+ showExtra True (Just msg) =+ blankLine $$+ text "Additional information:" $$ blankLine $$+ text msg+ showExtra _ _ = empty+ ghciUI :: IORef CLaSHOpts -> [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #ifndef GHCI
src-ghc/CLaSH/GHC/CLaSHFlags.hs view
@@ -45,6 +45,7 @@ , defFlag "clash-intwidth" (IntSuffix (setIntWidth r)) , defFlag "clash-hdldir" (SepArg (setHdlDir r)) , defFlag "clash-hdlsyn" (SepArg (setHdlSyn r))+ , defFlag "clash-error-extra" (NoArg (liftEwM (setErrorExtra r))) ] setInlineLimit :: IORef CLaSHOpts@@ -93,3 +94,6 @@ Nothing -> if s == "Xilinx" then liftEwM $ modifyIORef r (\c -> c {opt_hdlSyn = Vivado}) else addWarn (s ++ " is an unknown hdl synthesis tool")++setErrorExtra :: IORef CLaSHOpts -> IO ()+setErrorExtra r = modifyIORef r (\c -> c {opt_errorExtra = True})
src-ghc/CLaSH/GHC/Evaluator.hs view
@@ -225,10 +225,12 @@ -> boolToBoolLiteral tcm ty (i /= j) "CLaSH.Sized.Internal.Unsigned.minBound#"- | [litTy,kn@(Left (Literal (IntegerLiteral _)))] <- args- -> mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral 0))]+ | [Right nTy] <- args+ , Right len <- runExcept (tyNatSize tcm nTy)+ -> let kn = Left (Literal (IntegerLiteral (toInteger len)))+ in mkApps unsignedConPrim [Right nTy,kn,Left (Literal (IntegerLiteral 0))] - "CLaSH.Sized.Internal.Unsigned.minBound#"+ "CLaSH.Sized.Internal.Unsigned.maxBound#" | [litTy,kn@(Left (Literal (IntegerLiteral mb)))] <- args -> let maxB = (2 ^ mb) - 1 in mkApps unsignedConPrim [litTy,kn,Left (Literal (IntegerLiteral maxB))]@@ -249,7 +251,7 @@ , Right len <- runExcept (tyNatSize tcm lenTy) -> let (Just vecTc) = HashMap.lookup vecTcNm tcm [nilCon,consCon] = tyConDataCons vecTc- in mkVec nilCon consCon argTy len (replicate len (last $ Either.lefts args))+ in mkVec nilCon consCon argTy len (replicate (fromInteger len) (last $ Either.lefts args)) "CLaSH.Sized.Vector.maxIndex" | isSubj
src-ghc/CLaSH/GHC/GHC2Core.hs view
@@ -25,7 +25,11 @@ where -- External Modules+import Control.Exception (throw) import Control.Lens ((^.), (%~), (&), (%=))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT)+import qualified Control.Monad.Trans.Reader as Reader import Control.Monad.State (State) import qualified Control.Monad.State.Lazy as State import qualified Data.ByteString.Char8 as Char8@@ -33,7 +37,7 @@ import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Strict as HSM-import Data.Maybe (fromMaybe)+import Data.Maybe (catMaybes,fromMaybe,listToMaybe) import Data.Text (isInfixOf,pack) import qualified Data.Traversable as T import Unbound.Generics.LocallyNameless (bind, embed, rebind, rec,@@ -42,7 +46,7 @@ import qualified Unbound.Generics.LocallyNameless as Unbound -- GHC API-import Coercion (coercionType)+import Coercion (Coercion (..),Role(..),coercionType,coercionKind,mkCoercionType) import CoreFVs (exprSomeFreeVars) import CoreSyn (AltCon (..), Bind (..), CoreExpr, Expr (..), rhssOfAlts)@@ -61,9 +65,12 @@ import Literal (Literal (..)) import Module (moduleName, moduleNameString) import Name (Name, nameModule_maybe,- nameOccName, nameUnique)+ nameOccName, nameUnique, getSrcSpan) import OccName (occNameString)-import Outputable (showPpr)+import Outputable (showPpr, showSDocUnsafe)+import Pair (Pair (..))+import PprCore (pprCoreExpr)+import SrcLoc (isGoodSrcSpan) import TyCon (AlgTyConRhs (..), TyCon, algTyConRhs, isAlgTyCon, isFamilyTyCon, isFunTyCon, isNewTyCon,@@ -91,6 +98,7 @@ import qualified CLaSH.Core.TyCon as C import qualified CLaSH.Core.Type as C import qualified CLaSH.Core.Var as C+import CLaSH.Driver.Types import CLaSH.Primitives.Types import CLaSH.Util @@ -216,48 +224,71 @@ coreToTerm :: PrimMap a -> [Var]+ -> SrcSpan -> CoreExpr -> State GHC2CoreState C.Term-coreToTerm primMap unlocs coreExpr = term coreExpr+coreToTerm primMap unlocs srcsp coreExpr = Reader.runReaderT (term coreExpr) srcsp where- term (Var x) = var x+ term :: CoreExpr -> ReaderT SrcSpan (State GHC2CoreState) C.Term+ term (Var x) = lift (var x) term (Lit l) = return $ C.Literal (coreToLiteral l)- term (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> coreToType tyArg+ term (App eFun (Type tyArg)) = C.TyApp <$> term eFun <*> lift (coreToType tyArg) term (App eFun eArg) = C.App <$> term eFun <*> term eArg- term (Lam x e) | isTyVar x = C.TyLam <$> (bind <$> coreToTyVar x <*> term e)- | otherwise = C.Lam <$> (bind <$> coreToId x <*> term e)+ term (Lam x e) | isTyVar x = C.TyLam <$> (bind <$> lift (coreToTyVar x) <*> addUsefull (getSrcSpan x) (term e))+ | otherwise = C.Lam <$> (bind <$> lift (coreToId x) <*> addUsefull (getSrcSpan x) (term e)) term (Let (NonRec x e1) e2) = do- x' <- coreToId x- e1' <- term e1+ x' <- lift (coreToId x)+ e1' <- addUsefull (getSrcSpan x) (term e1) e2' <- term e2 return $ C.Letrec $ bind (rec [(x', embed e1')]) e2' term (Let (Rec xes) e) = do- xes' <- mapM- ( firstM coreToId <=<- secondM ((return . embed) <=< term)- ) xes+ xes' <- mapM (\(x,b) -> (,) <$> lift (coreToId x)+ <*> addUsefull (getSrcSpan x)+ (embed <$> term b))+ xes e' <- term e return $ C.Letrec $ bind (rec xes') e' - term (Case _ _ ty []) = C.Prim (pack "EmptyCase") <$> coreToType ty+ term (Case _ _ ty []) = C.Prim (pack "EmptyCase") <$> lift (coreToType ty) term (Case e b ty alts) = do let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (`elem` [b])) $ rhssOfAlts alts- b' <- coreToId b- e' <- term e- ty' <- coreToType ty- let caseTerm v = C.Case v ty' <$> mapM alt alts+ b' <- lift (coreToId b)+ e' <- addUsefull (getSrcSpan b) (term e)+ ty' <- lift (coreToType ty)+ let caseTerm v = C.Case v ty' <$> mapM (addUsefull (getSrcSpan b) . alt) alts if usesBndr then do ct <- caseTerm (C.Var (unembed $ C.varType b') (C.varName b')) return $ C.Letrec $ bind (rec [(b',embed e')]) ct else caseTerm e' - term (Cast e _) = term e+ term (Cast e co) = do+ let (Pair ty1 ty2) = coercionKind co+ hasPrimCoM <- lift (hasPrimCo co)+ ty1_I <- lift (isIntegerTy ty1)+ ty2_I <- lift (isIntegerTy ty2)+ case hasPrimCoM of+ Just ty | ty1_I || ty2_I -> do+ sp <- Reader.ask+ throw (CLaSHException sp+ (unlines [ "CLaSH cannot translate the following cast:\n"+ , showSDocUnsafe (pprCoreExpr (Cast e co))+ , "\nbecause it contains the following coercion:\n"+ , showPpr unsafeGlobalDynFlags (if ty1_I then mkCoercionType Representational ty1 ty+ else mkCoercionType Representational ty ty2)+ , "\nthat exposes the internal structure of the CLaSH primitive type: " ++ showPpr unsafeGlobalDynFlags ty+ , "This is most likely due to the use of 'seq' or BangPatterns on values of (newtype wrappers of) types: {BitVector,Index,Signed,Unsigned}"+ ])+ (Just (unlines ["The cast occurs in the following core expression:\n"+ , showSDocUnsafe (pprCoreExpr coreExpr)]))+ )++ _ -> term e term (Tick _ e) = term e- term (Type t) = C.Prim (pack "_TY_") <$> coreToType t- term (Coercion co) = C.Prim (pack "_CO_") <$> coreToType (coercionType co)+ term (Type t) = C.Prim (pack "_TY_") <$> lift (coreToType t)+ term (Coercion co) = C.Prim (pack "_CO_") <$> lift (coreToType (coercionType co)) var x = do xVar <- coreToVar x@@ -289,10 +320,10 @@ alt (LitAlt l , _ , e) = bind (C.LitPat . embed $ coreToLiteral l) <$> term e alt (DataAlt dc, xs, e) = case span isTyVar xs of (tyvs,tmvs) -> bind <$> (C.DataPat . embed <$>- coreToDataCon False dc <*>+ lift (coreToDataCon False dc) <*> (rebind <$>- mapM coreToTyVar tyvs <*>- mapM coreToId tmvs)) <*>+ lift (mapM coreToTyVar tyvs) <*>+ lift (mapM coreToId tmvs))) <*> term e coreToLiteral :: Literal@@ -309,6 +340,65 @@ MachDouble r -> C.RationalLiteral r MachNullAddr -> C.StringLiteral [] MachLabel fs _ _ -> C.StringLiteral (unpackFS fs)++addUsefull :: SrcSpan -> ReaderT SrcSpan (State GHC2CoreState) a+ -> ReaderT SrcSpan (State GHC2CoreState) a+addUsefull x = Reader.local (\r -> if isGoodSrcSpan x then x else r)++isIntegerTy :: Type -> State GHC2CoreState Bool+isIntegerTy (TyConApp tc []) = do+ tcNm <- qualfiedNameString (tyConName tc)+ return (tcNm == "GHC.Integer.Type.Integer")+isIntegerTy _ = return False++hasPrimCo :: Coercion -> State GHC2CoreState (Maybe Type)+hasPrimCo (TyConAppCo _ _ coers) = do+ tcs <- catMaybes <$> mapM hasPrimCo coers+ return (listToMaybe tcs)++hasPrimCo (AppCo co1 co2) = do+ tc1M <- hasPrimCo co1+ case tc1M of+ Just _ -> return tc1M+ _ -> hasPrimCo co2+hasPrimCo (ForAllCo _ co) = hasPrimCo co++hasPrimCo co@(AxiomInstCo _ _ coers) = do+ let (Pair ty1 _) = coercionKind co+ ty1PM <- isPrimTc ty1+ if ty1PM+ then return (Just ty1)+ else do+ tcs <- catMaybes <$> mapM hasPrimCo coers+ return (listToMaybe tcs)+ where+ isPrimTc (TyConApp tc _) = do+ tcNm <- qualfiedNameString (tyConName tc)+ return (tcNm `elem` ["CLaSH.Sized.Internal.BitVector.BitVector"+ ,"CLaSH.Sized.Internal.Index.Index"+ ,"CLaSH.Sized.Internal.Signed.Signed"+ ,"CLaSH.Sized.Internal.Unsigned.Unsigned"+ ])+ isPrimTc _ = return False++hasPrimCo (SymCo co) = hasPrimCo co++hasPrimCo (TransCo co1 co2) = do+ tc1M <- hasPrimCo co1+ case tc1M of+ Just _ -> return tc1M+ _ -> hasPrimCo co2++hasPrimCo (AxiomRuleCo _ _ coers) = do+ tcs <- catMaybes <$> mapM hasPrimCo coers+ return (listToMaybe tcs)++hasPrimCo (NthCo _ co) = hasPrimCo co+hasPrimCo (LRCo _ co) = hasPrimCo co+hasPrimCo (InstCo co _) = hasPrimCo co+hasPrimCo (SubCo co) = hasPrimCo co++hasPrimCo _ = return Nothing coreToDataCon :: Bool -> DataCon
src-ghc/CLaSH/GHC/GenerateBindings.hs view
@@ -8,7 +8,7 @@ (generateBindings) where -import Control.Lens ((%~),(&))+import Control.Lens ((%~),(&),(^.),_1) import Control.Monad.State (State) import qualified Control.Monad.State as State import Data.Either (lefts, rights)@@ -23,9 +23,11 @@ import qualified BasicTypes as GHC import qualified CoreSyn as GHC import qualified DynFlags as GHC+import qualified Name as GHC hiding (varName) import qualified TyCon as GHC import qualified TysWiredIn as GHC import qualified Var as GHC+import qualified SrcLoc as GHC import CLaSH.Annotations.TopEntity (TopEntity) import CLaSH.Core.FreeVars (termFreeIds)@@ -59,7 +61,7 @@ (tcMap',tupTcCache) = mkTupTyCons tcMap tcCache = makeAllTyCons tcMap' fiEnvs allTcCache = tysPrimMap `HashMap.union` tcCache- clsMap = HashMap.map (\(ty,i) -> (ty,mkClassSelector allTcCache ty i)) clsVMap+ clsMap = HashMap.map (\(ty,i) -> (ty,GHC.noSrcSpan,mkClassSelector allTcCache ty i)) clsVMap allBindings = bindingsMap `HashMap.union` clsMap (topEnt',testInpM',expOutM') = flip State.evalState tcMap' $ do topEnt'' <- coreToName GHC.varName GHC.varUnique qualfiedNameString topEnt@@ -98,12 +100,12 @@ -> ([TmName], BindingMap) -- (visited, bindings) -> TmName -- top -> ([TmName], BindingMap)-retype tcm (visited,bindings) current = (visited', HashMap.insert current (ty',tm') bindings')+retype tcm (visited,bindings) current = (visited', HashMap.insert current (ty',sp,tm') bindings') where- (_,tm) = bindings HashMap.! current+ (_,sp,tm) = bindings HashMap.! current used = Set.toList $ Lens.setOf termFreeIds tm (visited',bindings') = foldl (retype tcm) (current:visited,bindings) (filter (`notElem` visited) used)- usedTys = map (fst . (bindings' HashMap.!)) used+ usedTys = map ((^. _1) . (bindings' HashMap.!)) used usedVars = zipWith Var usedTys used tm' = substTms (zip used usedVars) tm ty' = runFreshM (termType tcm tm')@@ -118,9 +120,10 @@ ) mkBindings primMap bindings clsOps unlocatable = do bindingsList <- mapM (\(v,e) -> do- tm <- coreToTerm primMap unlocatable e+ let sp = GHC.getSrcSpan v+ tm <- coreToTerm primMap unlocatable sp e v' <- coreToId v- return (varName v', (unembed (varType v'), tm))+ return (varName v', (unembed (varType v'), sp, tm)) ) bindings clsOpList <- mapM (\(v,i) -> do v' <- coreToId v
src-ghc/CLaSH/GHC/NetlistTypes.hs view
@@ -88,22 +88,22 @@ ExceptT $ return $ coreTypeToHWType go m (args !! 1) "CLaSH.Sized.Internal.BitVector.BitVector" ->- BitVector <$> mapExceptT (Just . coerce) (tyNatSize m (head args))+ (BitVector . fromInteger) <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) "CLaSH.Sized.Internal.Index.Index" -> Index <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) "CLaSH.Sized.Internal.Signed.Signed" ->- Signed <$> mapExceptT (Just . coerce) (tyNatSize m (head args))+ (Signed . fromInteger) <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) "CLaSH.Sized.Internal.Unsigned.Unsigned" ->- Unsigned <$> mapExceptT (Just . coerce) (tyNatSize m (head args))+ (Unsigned . fromInteger) <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) "CLaSH.Sized.Vector.Vec" -> do let [szTy,elTy] = args sz <- mapExceptT (Just . coerce) (tyNatSize m szTy) elHWTy <- ExceptT $ return $ coreTypeToHWType go m elTy- return $ Vector sz elHWTy+ return $ Vector (fromInteger sz) elHWTy "String" -> return String "GHC.Types.[]" -> case tyView (head args) of