diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,15 @@ +# Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package + +## 0.3.1 *May 15th 2014* + +* New features: + * Hardcode `fromInteger` for `Signed` and `Unsigned` [#9](https://github.com/christiaanb/clash2/issues/9) + * Better blackbox operation for vindex [#12](https://github.com/christiaanb/clash2/issues/12) + * Replace VHDL default hole by error hole [#13](https://github.com/christiaanb/clash2/issues/13) + +* Fixes bugs: + * Update GHC2Core.hs [#1](https://github.com/christiaanb/clash2/issues/1) + * primitives (clash.sized.vector) [#2](https://github.com/christiaanb/clash2/issues/2) + * Type families are not expanded [#3](https://github.com/christiaanb/clash2/issues/3) + * Incorrect vhdl generation for default value in blackbox [#6](https://github.com/christiaanb/clash2/issues/6) + * Missing begin keyword in Signed/Unsigned JSON files [#16](https://github.com/christiaanb/clash2/issues/16) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,6 @@ +# Support +For updates and questions join the mailing list clash-language@googlegroups.com or read the [forum](https://groups.google.com/d/forum/clash-language) + # `clash-lib` * See the LICENSE file for license and copyright details 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.3.0.3 +Version: 0.3.1 Synopsis: CAES Language for Synchronous Hardware Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -26,6 +26,7 @@ Build-type: Simple Extra-source-files: README.md, + CHANGELOG.md, LICENSE_GHC, src-bin/HsVersions.h, src-bin/PosixSource.h @@ -41,6 +42,7 @@ primitives/clash.sized.signed.json, primitives/clash.sized.unsigned.json, primitives/clash.sized.vector.json, + primitives/control.exception.base.json, primitives/ghc.base.json, primitives/ghc.classes.json, primitives/ghc.cstring.json, @@ -81,7 +83,7 @@ base >= 4.3.1.0 && < 5, bifunctors >= 4.1.1, bytestring >= 0.9, - clash-lib >= 0.3.0.1, + clash-lib >= 0.3.1, clash-prelude >= 0.5, containers >= 0.5.4.0, directory >= 1.2, diff --git a/primitives/clash.ghc.ghc2core.json b/primitives/clash.ghc.ghc2core.json --- a/primitives/clash.ghc.ghc2core.json +++ b/primitives/clash.ghc.ghc2core.json @@ -1,6 +1,16 @@ [ { "BlackBox" : { "name" : "EmptyCase" - , "templateE" : "~DEFAULTO" + , "templateE" : "~ERRORO" + } + } +, { "Primitive" : + { "name" : "_CO_" + , "primType" : "Constructor" + } + } +, { "Primitive" : + { "name" : "_TY_" + , "primType" : "Constructor" } } ] diff --git a/primitives/clash.signal.explicit.json b/primitives/clash.signal.explicit.json --- a/primitives/clash.signal.explicit.json +++ b/primitives/clash.signal.explicit.json @@ -3,11 +3,14 @@ , "templateD" : "~SYM[0]_block : block signal ~SYM[1] : ~TYP[2]; + signal ~SYM[2] : ~TYP[1]; begin - process(~CLKO,~RSTO) + ~SYM[2] <= ~ARG[1]; + + process(~CLKO,~RSTO,~SYM[2]) begin if ~RSTO = '0' then - ~SYM[1] <= ~ARG[1]; + ~SYM[1] <= ~SYM[2]; elsif rising_edge(~CLKO) then ~SYM[1] <= ~ARG[2]; end if; diff --git a/primitives/clash.signal.implicit.json b/primitives/clash.signal.implicit.json --- a/primitives/clash.signal.implicit.json +++ b/primitives/clash.signal.implicit.json @@ -3,11 +3,14 @@ , "templateD" : "~SYM[0]_block : block signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[0]; begin - process(~CLKO,~RSTO) + ~SYM[2] <= ~ARG[0]; + + process(~CLKO,~RSTO,~SYM[2]) begin if ~RSTO = '0' then - ~SYM[1] <= ~ARG[0]; + ~SYM[1] <= ~SYM[2]; elsif rising_edge(~CLKO) then ~SYM[1] <= ~ARG[1]; end if; diff --git a/primitives/clash.sized.signed.json b/primitives/clash.sized.signed.json --- a/primitives/clash.sized.signed.json +++ b/primitives/clash.sized.signed.json @@ -58,9 +58,9 @@ , "templateE" : "abs ~ARG[1]" } } -, { "BlackBox" : - { "name" : "CLaSH.Sized.Signed.fromIntegerS" - , "templateE" : "to_signed(~ARG[1], ~LIT[0])" +, { "Primitive" : + { "name" : "CLaSH.Sized.Signed.fromIntegerS" + , "primType" : "Function" } } , { "BlackBox" : @@ -123,14 +123,23 @@ { "name" : "CLaSH.Sized.Signed.bitS" , "templateD" : "~SYM[0]_bitS : block - signal ~SYM[1] : ~TYP[1] := ~DEFAULT[1]; + signal ~SYM[1] : ~TYP[1]; begin ~SYM[1] <= ~ARG[1]; process(~SYM[1]) variable ~SYM[2] : ~TYPO; begin ~SYM[2] := (others => '0'); - ~SYM[2](~SYM[1]) := '1'; + -- pragma translate_off + if ~SYM[1] < ~SYM[2]'low or ~SYM[1] > ~SYM[2]'high then + assert false report (\"Index: \" & integer'image(~SYM[1]) & \", is out of bounds: \" & integer'image(~SYM[2]'low) & \" downto \" & integer'image(~SYM[2]'high)) severity warning; + ~SYM[2] := ~ERRORO; + else + -- pragma translate_on + ~SYM[2](~SYM[1]) := '1'; + -- pragma translate_off + end if; + -- pragma translate_on; ~RESULT <= ~SYM[2]; end process; end block;" @@ -141,9 +150,22 @@ , "templateD" : "~SYM[0]_testBitS : block signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[2]; begin ~SYM[1] <= ~ARG[1]; - ~RESULT <= ~SYM[1](~ARG[2]) = '1'; + ~SYM[2] <= ~ARG[2]; + -- pragma translate_off + process(~SYM[1],~SYM[2]) begin + if ~SYM[2] < ~SYM[1]'low or ~SYM[2] > ~SYM[1]'high then + assert false report (\"Index: \" & integer'image(~SYM[2]) & \", is out of bounds: \" & integer'image(~SYM[1]'low) & \" downto \" & integer'image(~SYM[1]'high)) severity warning; + ~RESULT <= ~ERRORO; + else + -- pragma translate_on + ~RESULT <= ~SYM[1](~SYM[2]) = '1'; + -- pragma translate_off + end if; + end process; + -- pragma translate_on end block;" } } diff --git a/primitives/clash.sized.unsigned.json b/primitives/clash.sized.unsigned.json --- a/primitives/clash.sized.unsigned.json +++ b/primitives/clash.sized.unsigned.json @@ -43,9 +43,9 @@ , "templateE" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" } } -, { "BlackBox" : - { "name" : "CLaSH.Sized.Unsigned.fromIntegerU" - , "templateE" : "to_unsigned(~ARG[1], ~LIT[0])" +, { "Primitive" : + { "name" : "CLaSH.Sized.Unsigned.fromIntegerU" + , "primType" : "Function" } } , { "BlackBox" : @@ -92,14 +92,23 @@ { "name" : "CLaSH.Sized.Unsigned.bitU" , "templateD" : "~SYM[0]_bitU : block - signal ~SYM[1] : ~TYP[1] := ~DEFAULT[1]; + signal ~SYM[1] : ~TYP[1]; begin ~SYM[1] <= ~ARG[1]; process(~SYM[1]) variable ~SYM[2] : ~TYPO; begin ~SYM[2] := (others => '0'); - ~SYM[2](~SYM[1]) := '1'; + -- pragma translate_off + if ~SYM[1] < ~SYM[2]'low or ~SYM[1] > ~SYM[2]'high then + assert false report (\"Index: \" & integer'image(~SYM[1]) & \", is out of bounds: \" & integer'image(~SYM[2]'low) & \" downto \" & integer'image(~SYM[2]'high)) severity warning; + ~SYM[2] := ~ERRORO; + else + -- pragma translate_on + ~SYM[2](~SYM[1]) := '1'; + -- pragma translate_off + end if; + -- pragma translate_on; ~RESULT <= ~SYM[2]; end process; end block;" @@ -110,9 +119,22 @@ , "templateD" : "~SYM[0]_testBitU : block signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[2]; begin ~SYM[1] <= ~ARG[1]; - ~RESULT <= ~SYM[1](~ARG[2]) = '1'; + ~SYM[2] <= ~ARG[2]; + -- pragma translate_off + process(~SYM[1],~SYM[2]) begin + if ~SYM[2] < ~SYM[1]'low or ~SYM[2] > ~SYM[1]'high then + assert false report (\"Index: \" & integer'image(~SYM[2]) & \", is out of bounds: \" & integer'image(~SYM[1]'low) & \" downto \" & integer'image(~SYM[1]'high)) severity warning; + ~RESULT <= ~ERRORO; + else + -- pragma translate_on + ~RESULT <= ~SYM[1](~SYM[2]) = '1'; + -- pragma translate_off + end if; + end process; + -- pragma translate_on end block;" } } diff --git a/primitives/clash.sized.vector.json b/primitives/clash.sized.vector.json --- a/primitives/clash.sized.vector.json +++ b/primitives/clash.sized.vector.json @@ -81,7 +81,7 @@ signal ~SYM[1] : ~TYP[1]; begin ~SYM[1] <= ~ARG[1]; - ~RESULT <= (~SYM[1](~SYM[1]'high downto ~LIT[0]),~SYM[1](~LIT[0]-1 downto 0)); + ~RESULT <= (~SYM[1](~SYM[1]'high downto (~SYM[1]'high - ~LIT[0] + 1)),~SYM[1]((~SYM[1]'high - ~LIT[0]) downto 0)); end block;" } } @@ -275,46 +275,27 @@ } } , { "BlackBox" : - { "name" : "CLaSH.Sized.Vector.vzip" - , "templateD" : -"~SYM[0]_vzip : block - signal ~SYM[1] : ~TYP[0]; - signal ~SYM[2] : ~TYP[1]; -begin - ~SYM[1] <= ~ARG[0]; - ~SYM[2] <= ~ARG[1]; - - ~SYM[3]_vzip : for ~SYM[4] in ~RESULT'high downto 0 generate - begin - ~RESULT(~SYM[4]) <= (~SYM[1](~SYM[4]),~SYM[2](~SYM[4])); - end generate; -end block;" - } - } -, { "BlackBox" : - { "name" : "CLaSH.Sized.Vector.vunzip" - , "templateD" : -"~SYM[0]_vunzip : block - signal ~SYM[1] : ~TYP[0]; -begin - ~SYM[1] <= ~ARG[0]; - - ~SYM[2]_vunzip : for ~SYM[3] in ~RESULT'high downto 0 generate - begin - ~RESULT.~TYPO_sel0(~SYM[3]) <= ~SYM[1](~SYM[3]).~TYP[0]_sel0; - ~RESULT.~TYPO_sel1(~SYM[3]) <= ~SYM[1](~SYM[3]).~TYP[0]_sel1; - end generate; -end block;" - } - } -, { "BlackBox" : { "name" : "CLaSH.Sized.Vector.vindex_integer" , "templateD" : "~SYM[0]_vindex_integer : block signal ~SYM[1] : ~TYP[1]; + signal ~SYM[2] : ~TYP[2]; begin ~SYM[1] <= ~ARG[1]; - ~RESULT <= ~SYM[1](~ARG[2]); + ~SYM[2] <= ~ARG[2]; + -- pragma translate_off + process (~SYM[1],~SYM[2]) + begin + if ~SYM[2] < ~SYM[1]'low or ~SYM[2] > ~SYM[1]'high then + assert false report (\"Index: \" & integer'image(~SYM[2]) & \", is out of bounds: \" & integer'image(~SYM[1]'low) & \" downto \" & integer'image(~SYM[1]'high)) severity warning; + ~RESULT <= ~ERRORO; + else + -- pragma translate_on + ~RESULT <= ~SYM[1](~SYM[2]); + -- pragma translate_off + end if; + end process; + -- pragma translate_on end block;" } } @@ -333,7 +314,7 @@ , "templateD" : "~SYM[0]_vreplace_integer : block signal ~SYM[1] : ~TYP[1]; - signal ~SYM[2] : ~TYP[2] := ~DEFAULT[2]; + signal ~SYM[2] : ~TYP[2]; signal ~SYM[3] : ~TYP[3]; begin ~SYM[1] <= ~ARG[1]; @@ -343,7 +324,16 @@ variable ~SYM[4] : ~TYP[1]; begin ~SYM[4] := ~SYM[1]; - ~SYM[4](~SYM[2]) := ~SYM[3]; + -- pragma translate_off + if ~SYM[2] < ~SYM[4]'low or ~SYM[2] > ~SYM[4]'high then + assert false report (\"Index: \" & integer'image(~SYM[2]) & \", is out of bounds: \" & integer'image(~SYM[1]'low) & \" downto \" & integer'image(~SYM[1]'high)) severity warning; + ~SYM[4] := ~ERROR[1]; + else + -- pragma translate_on + ~SYM[4](~SYM[2]) := ~SYM[3]; + -- pragma translate_off + end if; + -- pragma translate_on ~RESULT <= ~SYM[4]; end process; end block;" @@ -384,14 +374,21 @@ } , { "BlackBox" : { "name" : "CLaSH.Sized.Vector.vselect" + , "comment" : + "vselect :: ((f + (s * n) + 1) <= i) -- ARG[0] + => SNat f -- ARG[1] + -> SNat s -- ARG[2] + -> SNat (n + 1) -- ARG[3] + -> Vec i a -- ARG[4] + -> Vec (n + 1) a" , "templateD" : "~SYM[0]_vselect : block - signal ~SYM[1] : ~TYP[3]; + signal ~SYM[1] : ~TYP[4]; begin - ~SYM[1] <= ~ARG[3]; + ~SYM[1] <= ~ARG[4]; ~SYM[2]_vselect : for ~SYM[3] in 0 to ~RESULT'high generate begin - ~RESULT(~RESULT'high - ~SYM[3]) <= ~SYM[1](~SYM[1]'high - (~LIT[0]+(~LIT[1]*~SYM[3]))); + ~RESULT(~RESULT'high - ~SYM[3]) <= ~SYM[1](~SYM[1]'high - (~LIT[1]+(~LIT[2]*~SYM[3]))); end generate; end block;" } @@ -430,9 +427,9 @@ { "name" : "CLaSH.Sized.Vector.vhead'" , "templateD" : "~SYM[0]_vhead : block - signal ~SYM[1] : ~TYP[0]; + signal ~SYM[1] : ~TYP[1]; begin - ~SYM[1] <= ~ARG[0]; + ~SYM[1] <= ~ARG[1]; ~RESULT <= ~SYM[1](~SYM[1]'high); end block;" } diff --git a/primitives/control.exception.base.json b/primitives/control.exception.base.json new file mode 100644 --- /dev/null +++ b/primitives/control.exception.base.json @@ -0,0 +1,11 @@ +[ { "BlackBox" : + { "name" : "Control.Exception.Base.patError" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "Control.Exception.Base.irrefutPatError" + , "templateE" : "~ERRORO" + } + } +] diff --git a/primitives/ghc.err.json b/primitives/ghc.err.json --- a/primitives/ghc.err.json +++ b/primitives/ghc.err.json @@ -1,6 +1,11 @@ [ { "BlackBox" : { "name" : "GHC.Err.error" - , "templateE" : "~DEFAULTO" + , "templateE" : "~ERRORO" + } + } +, { "BlackBox" : + { "name" : "GHC.Err.undefined" + , "templateE" : "~ERRORO" } } ] diff --git a/primitives/ghc.real.json b/primitives/ghc.real.json --- a/primitives/ghc.real.json +++ b/primitives/ghc.real.json @@ -1,16 +1,16 @@ [ { "BlackBox" : { "name" : "GHC.Real.divZeroError" - , "templateE" : "~DEFAULTO" + , "templateE" : "~ERRORO" } } , { "BlackBox" : { "name" : "GHC.Real.ratioZeroDenominatorError" - , "templateE" : "~DEFAULTO" + , "templateE" : "~ERRORO" } } , { "BlackBox" : { "name" : "GHC.Real.overflowError" - , "templateE" : "~DEFAULTO" + , "templateE" : "~ERRORO" } } ] diff --git a/src-ghc/CLaSH/GHC/Compat/Outputable.hs b/src-ghc/CLaSH/GHC/Compat/Outputable.hs --- a/src-ghc/CLaSH/GHC/Compat/Outputable.hs +++ b/src-ghc/CLaSH/GHC/Compat/Outputable.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} module CLaSH.GHC.Compat.Outputable - ( showPpr, showSDoc ) + ( showPpr, showSDoc, showPprDebug ) where #if __GLASGOW_HASKELL__ >= 707 @@ -8,12 +8,15 @@ #elif __GLASGOW_HASKELL__ >= 706 import qualified DynFlags (tracingDynFlags) #endif -import qualified Outputable (Outputable, SDoc, showPpr, showSDoc) +import qualified Outputable (Outputable (..), SDoc, showPpr, showSDoc, showSDocDebug) showSDoc :: Outputable.SDoc -> String #if __GLASGOW_HASKELL__ >= 707 showSDoc = Outputable.showSDoc DynFlags.unsafeGlobalDynFlags #endif + +showPprDebug :: Outputable.Outputable a => a -> String +showPprDebug = Outputable.showSDocDebug DynFlags.unsafeGlobalDynFlags . Outputable.ppr showPpr :: (Outputable.Outputable a) => a -> String #if __GLASGOW_HASKELL__ >= 707 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -34,8 +35,11 @@ import CLaSH.GHC.Compat.FastString (unpackFB, unpackFS) import CLaSH.GHC.Compat.Outputable (showPpr) import CLaSH.GHC.Compat.TyCon (isSuperKindTyCon) --- import Coercion (coercionKind, coercionType) +#if __GLASGOW_HASKELL__ < 710 +import Coercion (Coercion(..), coercionType) +#else import Coercion (coercionType) +#endif import CoreFVs (exprSomeFreeVars) import CoreSyn (AltCon (..), Bind (..), CoreExpr, Expr (..), rhssOfAlts) @@ -44,6 +48,8 @@ dataConTag, dataConTyCon, dataConUnivTyVars, dataConWorkId, dataConWrapId_maybe) +import FamInstEnv (FamInst (..), FamInstEnvs, + familyInstances) import Id (isDataConId_maybe) import IdInfo (IdDetails (..)) import Literal (Literal (..)) @@ -51,8 +57,7 @@ import Name (Name, nameModule_maybe, nameOccName, nameUnique) import OccName (occNameString) --- import Pair (Pair (..)) -import TyCon (AlgTyConRhs (..), PrimRep (..), +import TyCon (AlgTyConRhs (..), SynTyConRhs (..), TyCon, algTyConRhs, isAlgTyCon, isFunTyCon, isNewTyCon, @@ -60,8 +65,7 @@ isSynTyCon, isTupleTyCon, synTyConRhs_maybe, tyConArity, tyConDataCons, tyConKind, - tyConName, tyConPrimRep, - tyConUnique) + tyConName, tyConUnique) import Type (tcView) import TypeRep (TyLit (..), Type (..)) import Unique (Uniquable (..), Unique, getKey) @@ -76,6 +80,9 @@ import qualified CLaSH.Core.Term as C import qualified CLaSH.Core.TyCon as C import qualified CLaSH.Core.Type as C +#if __GLASGOW_HASKELL__ < 710 +import qualified CLaSH.Core.Util as C +#endif import qualified CLaSH.Core.Var as C import CLaSH.Primitives.Types import CLaSH.Util @@ -95,24 +102,26 @@ emptyGHC2CoreState = GHC2CoreState HSM.empty HSM.empty makeAllTyCons :: GHC2CoreState + -> FamInstEnvs -> HashMap C.TyConName C.TyCon -makeAllTyCons hm = go hm hm +makeAllTyCons hm fiEnvs = go hm hm where go old new | HSM.null (new ^. tyConMap) = HSM.empty | otherwise = tcm `HSM.union` tcm' where - (tcm,old') = State.runState (T.mapM makeTyCon (new ^. tyConMap)) old + (tcm,old') = State.runState (T.mapM (makeTyCon fiEnvs) (new ^. tyConMap)) old tcm' = go old' (old' & tyConMap %~ (`HSM.difference` (old ^. tyConMap))) -makeTyCon :: TyCon +makeTyCon :: FamInstEnvs + -> TyCon -> State GHC2CoreState C.TyCon -makeTyCon tc = tycon +makeTyCon fiEnvs tc = tycon where tycon | isTupleTyCon tc = mkTupleTyCon | isAlgTyCon tc = mkAlgTyCon - | isSynTyCon tc = mkVoidTyCon + | isSynTyCon tc = mkFunTyCon | isPrimTyCon tc = mkPrimTyCon | isSuperKindTyCon tc = mkSuperKindTyCon | otherwise = mkVoidTyCon @@ -132,8 +141,21 @@ , C.tyConArity = tcArity , C.algTcRhs = tcRhs } - Nothing -> return (C.PrimTyCon tcName tcKind tcArity C.VoidRep) + Nothing -> return (C.PrimTyCon tcName tcKind tcArity) + mkFunTyCon = do + tcName <- coreToName tyConName tyConUnique qualfiedNameString tc + tcKind <- coreToType (tyConKind tc) + let instances = familyInstances fiEnvs tc + substs <- mapM famInstToSubst instances + return + C.FunTyCon + { C.tyConName = tcName + , C.tyConKind = tcKind + , C.tyConArity = tcArity + , C.tyConSubst = substs + } + mkTupleTyCon = do tcName <- coreToName tyConName tyConUnique qualfiedNameString tc tcKind <- coreToType (tyConKind tc) @@ -154,7 +176,6 @@ { C.tyConName = tcName , C.tyConKind = tcKind , C.tyConArity = tcArity - , C.primTyConRep = coreToPrimRep (tyConPrimRep tc) } mkSuperKindTyCon = do @@ -166,18 +187,13 @@ mkVoidTyCon = do tcName <- coreToName tyConName tyConUnique qualfiedNameString tc tcKind <- coreToType (tyConKind tc) - return (C.PrimTyCon tcName tcKind tcArity C.VoidRep) + return (C.PrimTyCon tcName tcKind tcArity) - coreToPrimRep :: PrimRep - -> C.PrimRep - coreToPrimRep p = case p of - VoidRep -> C.VoidRep - IntRep -> C.IntRep - AddrRep -> C.VoidRep - PtrRep -> C.VoidRep - WordRep -> C.VoidRep - DoubleRep -> C.VoidRep - _ -> error $ $(curLoc) ++ "Can't convert PrimRep: " ++ showPpr p ++ " in tycon: " ++ showPpr tc + famInstToSubst :: FamInst -> State GHC2CoreState ([C.Type],C.Type) + famInstToSubst fi = do + tys <- mapM coreToType (fi_tys fi) + ty <- coreToType (fi_rhs fi) + return (tys,ty) makeAlgTyConRhs :: AlgTyConRhs -> State GHC2CoreState (Maybe C.AlgTyConRhs) @@ -218,27 +234,33 @@ return $ C.Letrec $ bind (rec xes') e' term (Case _ _ ty []) = C.Prim (pack "EmptyCase") <$> coreToType ty - term (Case e b _ alts) = do + term (Case e b ty alts) = do let usesBndr = any ( not . isEmptyVarSet . exprSomeFreeVars (`elem` [b])) $ rhssOfAlts alts b' <- coreToId b e' <- term e - let caseTerm v = C.Case v <$> mapM alt alts + ty' <- coreToType ty + let caseTerm v = C.Case v ty' <$> mapM 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 j@(Cast e co) = traceIf True ("CAST: " ++ showPpr j) $ case coercionKind co of - -- Pair ty1 ty2 -> do - -- ty1C <- coreToType ty1 - -- ty2C <- coreToType ty2 - -- eC <- term e - -- let caTy = C.mkFunTy ty1C ty2C - -- ca = C.Prim (string2Name "_CAST_") caTy - -- return (C.App ca eC) +#if __GLASGOW_HASKELL__ < 710 + term (Cast e co) = do + e' <- term e + case C.collectArgs e' of + (C.Prim nm pTy, [Right _, Left errMsg]) + | nm == (pack "Control.Exception.Base.irrefutPatError") -> case co of + (UnivCo _ _ resTy) -> do resTy' <- coreToType resTy + return (C.mkApps (C.Prim nm pTy) [Right resTy', Left errMsg]) + _ -> error $ $(curLoc) ++ "irrefutPatError casted with an unknown coercion: " ++ showPpr co + _ -> return e' +#else term (Cast e _) = term e +#endif + term (Tick _ e) = term e term (Type t) = C.Prim (pack "_TY_") <$> coreToType t term (Coercion co) = C.Prim (pack "_CO_") <$> coreToType (coercionType co) 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 @@ -35,9 +35,9 @@ -> String -> IO (BindingMap,HashMap TyConName TyCon) generateBindings primMap modName = do - (bindings,clsOps,unlocatable) <- loadModules modName + (bindings,clsOps,unlocatable,fiEnvs) <- loadModules modName let ((bindingsMap,clsVMap),tcMap) = State.runState (mkBindings primMap bindings clsOps unlocatable) emptyGHC2CoreState - tcCache = makeAllTyCons 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 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 @@ -32,9 +32,15 @@ import qualified TidyPgm -- import qualified TyCons +import qualified TcRnMonad +import qualified TcRnTypes +import qualified UniqFM +import qualified FamInst +import qualified FamInstEnv + -- Internal Modules import CLaSH.GHC.LoadInterfaceFiles -import CLaSH.Util (curLoc) +import CLaSH.Util (curLoc,first) #ifdef STANDALONE ghcLibDir :: IO FilePath @@ -63,6 +69,7 @@ -> IO ( [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -- Binders , [(CoreSyn.CoreBndr,Int)] -- Class operations , [CoreSyn.CoreBndr] -- Unlocatable Expressions + , FamInstEnv.FamInstEnvs ) loadModules modName = defaultErrorHandler $ do libDir <- MonadUtils.liftIO ghcLibDir @@ -110,17 +117,22 @@ -- ; let dataTyCons = filter TyCon.isDataTyCon tycons -- ; dflags'' <- GHC.getSessionDynFlags -- ; prepBinders <- MonadUtils.liftIO $ CorePrep.corePrepPgm dflags'' hsc_env pgm dataTyCons - ; return (CoreSyn.flattenBinds pgm) + ; let modFamInstEnv = TcRnTypes.tcg_fam_inst_env $ fst $ GHC.tm_internals_ tcMod + ; return (CoreSyn.flattenBinds pgm,modFamInstEnv) } ) modGraph' - let binders = concat tidiedMods + let (binders,modFamInstEnvs) = first concat $ unzip tidiedMods + modFamInstEnvs' = foldr UniqFM.plusUFM UniqFM.emptyUFM modFamInstEnvs (externalBndrs,clsOps,unlocatable) <- loadExternalExprs (map snd binders) (map fst binders) - return (binders ++ externalBndrs,clsOps,unlocatable) + hscEnv <- GHC.getSession + famInstEnvs <- TcRnMonad.liftIO $ TcRnMonad.initTcForLookup hscEnv FamInst.tcGetFamInstEnvs + + return (binders ++ externalBndrs,clsOps,unlocatable,(fst famInstEnvs,modFamInstEnvs')) GHC.Failed -> Panic.pgmError $ $(curLoc) ++ "failed to load module: " ++ modName parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule 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 @@ -4,13 +4,16 @@ (ghcTypeToHWType) where -import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict (HashMap,(!)) +import Control.Monad (zipWithM) import Control.Monad.Trans.Error (ErrorT(..)) import Unbound.LocallyNameless (name2String) +import CLaSH.Core.Subst (substTys) import CLaSH.Core.Pretty (showDoc) -import CLaSH.Core.TyCon (TyCon, TyConName) -import CLaSH.Core.Type (LitTy (..), Type (..), TypeView (..), tyView) +import CLaSH.Core.TyCon (TyCon (..), TyConName) +import CLaSH.Core.Type (LitTy (..), Type (..), TyName, TypeView (..), + tyView) import CLaSH.Netlist.Util (coreTypeToHWType) import CLaSH.Netlist.Types (HWType(..)) import CLaSH.Util @@ -34,32 +37,68 @@ "CLaSH.Signal.Types.CSignal" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (args !! 1) "CLaSH.Signal.Implicit.SignalP" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (head args) "CLaSH.Signal.Explicit.CSignalP" -> ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m (args !! 1) - "CLaSH.Sized.Signed.Signed" -> Signed <$> tyNatSize (head args) - "CLaSH.Sized.Unsigned.Unsigned" -> Unsigned <$> tyNatSize (head args) + "CLaSH.Sized.Signed.Signed" -> Signed <$> tyNatSize m (head args) + "CLaSH.Sized.Unsigned.Unsigned" -> Unsigned <$> tyNatSize m (head args) "CLaSH.Sized.Vector.Vec" -> do let [szTy,elTy] = args - sz <- tyNatSize szTy + sz <- tyNatSize m szTy elHWTy <- ErrorT $ return $ coreTypeToHWType ghcTypeToHWType m elTy return $ Vector sz elHWTy _ -> ErrorT Nothing ghcTypeToHWType _ _ = Nothing -tyNatSize :: - Type - -> ErrorT String Maybe Int -tyNatSize (LitTy (NumTy i)) = return i -tyNatSize (tyView -> TyConApp tc [ty1,ty2]) = case name2String tc of - "GHC.TypeLits.+" -> (+) <$> tyNatSize ty1 <*> tyNatSize ty2 - "GHC.TypeLits.*" -> (*) <$> tyNatSize ty1 <*> tyNatSize ty2 - "GHC.TypeLits.^" -> (^) <$> tyNatSize ty1 <*> tyNatSize ty2 - "GHC.TypeLits.-" -> (-) <$> tyNatSize ty1 <*> tyNatSize ty2 - "CLaSH.Promoted.Ord.Max" -> max <$> tyNatSize ty1 <*> tyNatSize ty2 - "CLaSH.Promoted.Ord.Min" -> min <$> tyNatSize ty1 <*> tyNatSize ty2 +tyNatSize :: HashMap TyConName TyCon + -> Type + -> ErrorT String Maybe Int +tyNatSize _ (LitTy (NumTy i)) = return i +tyNatSize m (tyView -> TyConApp tc [ty1,ty2]) = case name2String tc of + "GHC.TypeLits.+" -> (+) <$> tyNatSize m ty1 <*> tyNatSize m ty2 + "GHC.TypeLits.*" -> (*) <$> tyNatSize m ty1 <*> tyNatSize m ty2 + "GHC.TypeLits.^" -> (^) <$> tyNatSize m ty1 <*> tyNatSize m ty2 + "GHC.TypeLits.-" -> (-) <$> tyNatSize m ty1 <*> tyNatSize m ty2 + "CLaSH.Promoted.Ord.Max" -> max <$> tyNatSize m ty1 <*> tyNatSize m ty2 + "CLaSH.Promoted.Ord.Min" -> min <$> tyNatSize m ty1 <*> tyNatSize m ty2 _ -> fail $ $(curLoc) ++ "Can't convert tyNatOp: " ++ show tc -- TODO: Remove this conversion -- The current problem is that type-functions are not reduced by the GHC -> Core -- transformation process, and so end up here. Once a fix has been found for -- this problem remove this dirty hack. -tyNatSize (tyView -> TyConApp _ [ty1]) = tyNatSize ty1 -tyNatSize t = fail $ $(curLoc) ++ "Can't convert tyNat: " ++ show t +tyNatSize tcm ty@(tyView -> TyConApp tc tys) = do + case tcm ! tc of + FunTyCon {tyConSubst = tcSubst} -> case findFunSubst tcSubst tys of + Just ty' -> tyNatSize tcm ty' + _ -> fail $ $(curLoc) ++ "Can't convert tyNat: " ++ show ty + _ -> fail $ $(curLoc) ++ "Can't convert tyNat: " ++ show ty + +tyNatSize _ t = fail $ $(curLoc) ++ "Can't convert tyNat: " ++ show t + +-- Given a set of type functions, and list of argument types, get the first +-- type function that matches, and return its substituted RHS type. +findFunSubst :: [([Type],Type)] -> [Type] -> Maybe Type +findFunSubst [] _ = Nothing +findFunSubst (tcSubst:rest) args = case funSubsts tcSubst args of + Just ty -> Just ty + Nothing -> findFunSubst rest args + +-- Given a ([LHS match type], RHS type) representing a type function, and +-- a set of applied types. Match LHS with args, and when successful, return +-- a substituted RHS +funSubsts :: ([Type],Type) -> [Type] -> Maybe Type +funSubsts (tcSubstLhs,tcSubstRhs) args = do + tySubts <- concat <$> zipWithM funSubst tcSubstLhs args + let tyRhs = substTys tySubts tcSubstRhs + return tyRhs + +-- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS +-- are a match. If they do match, and the LHS is a variable, return a +-- substitution +funSubst :: Type -> Type -> Maybe [(TyName,Type)] +funSubst (VarTy _ nmF) ty = Just [(nmF,ty)] +funSubst tyL@(LitTy _) tyR = if tyL == tyR then Just [] else Nothing +funSubst (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys') + | tc == tc' + = do + tySubts <- zipWithM funSubst argTys argTys' + return (concat tySubts) +funSubst _ _ = Nothing