clash-ghc 0.3.0.3 → 0.3.1
raw patch · 17 files changed
+294/−125 lines, 17 filesdep ~clash-lib
Dependency ranges changed: clash-lib
Files
- CHANGELOG.md +15/−0
- README.md +3/−0
- clash-ghc.cabal +4/−2
- primitives/clash.ghc.ghc2core.json +11/−1
- primitives/clash.signal.explicit.json +5/−2
- primitives/clash.signal.implicit.json +5/−2
- primitives/clash.sized.signed.json +28/−6
- primitives/clash.sized.unsigned.json +28/−6
- primitives/clash.sized.vector.json +39/−42
- primitives/control.exception.base.json +11/−0
- primitives/ghc.err.json +6/−1
- primitives/ghc.real.json +3/−3
- src-ghc/CLaSH/GHC/Compat/Outputable.hs +5/−2
- src-ghc/CLaSH/GHC/GHC2Core.hs +55/−33
- src-ghc/CLaSH/GHC/GenerateBindings.hs +2/−2
- src-ghc/CLaSH/GHC/LoadModules.hs +16/−4
- src-ghc/CLaSH/GHC/NetlistTypes.hs +58/−19
+ CHANGELOG.md view
@@ -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)
README.md view
@@ -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
clash-ghc.cabal view
@@ -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,
primitives/clash.ghc.ghc2core.json view
@@ -1,6 +1,16 @@ [ { "BlackBox" : { "name" : "EmptyCase"- , "templateE" : "~DEFAULTO"+ , "templateE" : "~ERRORO"+ }+ }+, { "Primitive" :+ { "name" : "_CO_"+ , "primType" : "Constructor"+ }+ }+, { "Primitive" :+ { "name" : "_TY_"+ , "primType" : "Constructor" } } ]
primitives/clash.signal.explicit.json view
@@ -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;
primitives/clash.signal.implicit.json view
@@ -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;
primitives/clash.sized.signed.json view
@@ -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;" } }
primitives/clash.sized.unsigned.json view
@@ -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;" } }
primitives/clash.sized.vector.json view
@@ -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;" }
+ primitives/control.exception.base.json view
@@ -0,0 +1,11 @@+[ { "BlackBox" :+ { "name" : "Control.Exception.Base.patError"+ , "templateE" : "~ERRORO"+ }+ }+, { "BlackBox" :+ { "name" : "Control.Exception.Base.irrefutPatError"+ , "templateE" : "~ERRORO"+ }+ }+]
primitives/ghc.err.json view
@@ -1,6 +1,11 @@ [ { "BlackBox" : { "name" : "GHC.Err.error"- , "templateE" : "~DEFAULTO"+ , "templateE" : "~ERRORO"+ }+ }+, { "BlackBox" :+ { "name" : "GHC.Err.undefined"+ , "templateE" : "~ERRORO" } } ]
primitives/ghc.real.json view
@@ -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" } } ]
src-ghc/CLaSH/GHC/Compat/Outputable.hs view
@@ -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
src-ghc/CLaSH/GHC/GHC2Core.hs view
@@ -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)
src-ghc/CLaSH/GHC/GenerateBindings.hs view
@@ -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
src-ghc/CLaSH/GHC/LoadModules.hs view
@@ -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
src-ghc/CLaSH/GHC/NetlistTypes.hs view
@@ -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