diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 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.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 diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -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 diff --git a/src-ghc/CLaSH/GHC/CLaSHFlags.hs b/src-ghc/CLaSH/GHC/CLaSHFlags.hs --- a/src-ghc/CLaSH/GHC/CLaSHFlags.hs +++ b/src-ghc/CLaSH/GHC/CLaSHFlags.hs @@ -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}) 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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