clash-ghc 0.6.7 → 0.6.8
raw patch · 9 files changed
+193/−132 lines, 9 filesdep ~clash-libdep ~clash-preludedep ~clash-systemverilog
Dependency ranges changed: clash-lib, clash-prelude, clash-systemverilog, clash-verilog, clash-vhdl
Files
- CHANGELOG.md +7/−0
- clash-ghc.cabal +6/−6
- src-bin/InteractiveUI.hs +10/−9
- src-bin/Main.hs +7/−4
- src-ghc/CLaSH/GHC/CLaSHFlags.hs +9/−0
- src-ghc/CLaSH/GHC/Evaluator.hs +54/−24
- src-ghc/CLaSH/GHC/GHC2Core.hs +7/−10
- src-ghc/CLaSH/GHC/LoadModules.hs +4/−0
- src-ghc/CLaSH/GHC/NetlistTypes.hs +89/−79
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Changelog for the [`clash-ghc`](http://hackage.haskell.org/package/clash-ghc) package +## 0.6.8 *January 13th 2015*+* New features:+ * Support for Haskell's: `Char`, `Int8`, `Int16`, `Int32`, `Int64`, `Word`, `Word8`, `Word16`, `Word32`, `Word64`.+ * Int/Word/Integer bitwidth for generated HDL is configurable using the `-clash-intwidth=N` flag, where `N` can be either 32 or 64.+* Fixes bugs:+ * Cannot reduce `case error ... of ...` to `error ...` [#109](https://github.com/clash-lang/clash-compiler/issues/109)+ ## 0.6.7 *December 21st 2015* * Support for `unbound-generics-0.3` * New features:
clash-ghc.cabal view
@@ -1,5 +1,5 @@ Name: clash-ghc-Version: 0.6.7+Version: 0.6.8 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.4, unordered-containers >= 0.2.1.0, - clash-lib >= 0.6.7 && < 0.7,- clash-systemverilog >= 0.6.3,- clash-vhdl >= 0.6.4,- clash-verilog >= 0.6.3,- clash-prelude >= 0.10.4 && < 0.11,+ clash-lib >= 0.6.8 && < 0.7,+ clash-systemverilog >= 0.6.4,+ clash-vhdl >= 0.6.5,+ clash-verilog >= 0.6.4,+ clash-prelude >= 0.10.5 && < 0.11, ghc-typelits-extra >= 0.1, ghc-typelits-natnormalise >= 0.3
src-bin/InteractiveUI.hs view
@@ -114,7 +114,7 @@ import CLaSH.Backend.VHDL (VHDLState) import CLaSH.Backend.Verilog (VerilogState) import qualified CLaSH.Driver-import CLaSH.Driver.Types (CLaSHOpts)+import CLaSH.Driver.Types (CLaSHOpts(..)) import CLaSH.GHC.Evaluator import CLaSH.GHC.GenerateBindings import CLaSH.GHC.NetlistTypes@@ -1559,7 +1559,7 @@ liftIO $ putStrLn $ showSDocForUser dflags unqual msg makeHDL' :: CLaSH.Backend.Backend backend- => backend+ => (Int -> backend) -> IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()@@ -1574,28 +1574,29 @@ makeHDL :: GHC.GhcMonad m => CLaSH.Backend.Backend backend- => backend+ => (Int -> backend) -> IORef CLaSHOpts -> [FilePath] -> m () makeHDL backend optsRef srcs = do dflags <- GHC.getSessionDynFlags liftIO $ do opts <- readIORef optsRef- primDir <- CLaSH.Backend.primDir backend+ let iw = opt_intWidth opts+ primDir <- CLaSH.Backend.primDir (backend iw) primMap <- CLaSH.Primitives.Util.generatePrimMap [primDir,"."] forM_ srcs $ \src -> do (bindingsMap,tcm,tupTcm,topEnt,testInpM,expOutM) <- generateBindings primMap src (Just dflags)- CLaSH.Driver.generateHDL bindingsMap (Just backend) primMap tcm- tupTcm ghcTypeToHWType reduceConstant topEnt testInpM expOutM opts+ CLaSH.Driver.generateHDL bindingsMap (Just (backend iw)) primMap tcm+ tupTcm (ghcTypeToHWType iw) reduceConstant topEnt testInpM expOutM opts makeVHDL :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()-makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState)+makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: Int -> VHDLState) makeVerilog :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()-makeVerilog = makeHDL' (CLaSH.Backend.initBackend :: VerilogState)+makeVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> VerilogState) makeSystemVerilog :: IORef CLaSHOpts -> [FilePath] -> InputT GHCi ()-makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: SystemVerilogState)+makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> SystemVerilogState) ----------------------------------------------------------------------------- -- :type
src-bin/Main.hs view
@@ -11,6 +11,8 @@ module Main (main) where +#include "MachDeps.h"+ -- The official GHC API import qualified GHC import GHC ( -- DynFlags(..), HscTarget(..),@@ -121,6 +123,7 @@ , opt_specLimit = 20 , opt_inlineBelow = 15 , opt_cleanhdl = True+ , opt_intWidth = WORD_SIZE_IN_BITS }) (argv3, clashFlagWarnings) <- parseCLaSHFlags r argv2 @@ -941,18 +944,18 @@ -- ----------------------------------------------------------------------------- -- VHDL Generation -makeHDL' :: CLaSH.Backend.Backend backend => backend -> IORef CLaSHOpts -> [(String,Maybe Phase)] -> Ghc ()+makeHDL' :: CLaSH.Backend.Backend backend => (Int -> backend) -> IORef CLaSHOpts -> [(String,Maybe Phase)] -> Ghc () makeHDL' _ _ [] = throwGhcException (CmdLineError "No input files") makeHDL' backend r srcs = makeHDL backend r $ fmap fst srcs makeVHDL :: IORef CLaSHOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: VHDLState)+makeVHDL = makeHDL' (CLaSH.Backend.initBackend :: Int -> VHDLState) makeVerilog :: IORef CLaSHOpts -> [(String, Maybe Phase)] -> Ghc ()-makeVerilog = makeHDL' (CLaSH.Backend.initBackend :: VerilogState)+makeVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> VerilogState) makeSystemVerilog :: IORef CLaSHOpts -> [(String, Maybe Phase)] -> Ghc ()-makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: SystemVerilogState)+makeSystemVerilog = makeHDL' (CLaSH.Backend.initBackend :: Int -> SystemVerilogState) -- ----------------------------------------------------------------------------- -- Util
src-ghc/CLaSH/GHC/CLaSHFlags.hs view
@@ -34,6 +34,7 @@ , defFlag "clash-inline-below" (IntSuffix (liftEwM . setInlineBelow r)) , defFlag "clash-debug" (SepArg (setDebugLevel r)) , defFlag "clash-noclean" (NoArg (liftEwM (setNoClean r)))+ , defFlag "clash-intwidth" (IntSuffix (setIntWidth r)) ] setInlineLimit :: IORef CLaSHOpts@@ -60,3 +61,11 @@ setNoClean :: IORef CLaSHOpts -> IO () setNoClean r = modifyIORef r (\c -> c {opt_cleanhdl = False})++setIntWidth :: IORef CLaSHOpts+ -> Int+ -> EwM IO ()+setIntWidth r n =+ if n == 32 || n == 64+ then liftEwM $ modifyIORef r (\c -> c {opt_intWidth = n})+ else addWarn (show n ++ " is an invalid Int/Word/Integer bit-width. Allowed widths: 32, 64.")
src-ghc/CLaSH/GHC/Evaluator.hs view
@@ -23,43 +23,73 @@ reduceConstant :: HashMap.HashMap TyConName TyCon -> Bool -> Term -> Term reduceConstant tcm isSubj e@(collectArgs -> (Prim nm ty, args))- | nm == "GHC.Prim.==#" || nm == "GHC.Integer.Type.eqInteger#"+ | nm == "GHC.Prim.==#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of+ [Literal (IntLiteral i), Literal (IntLiteral j)]+ | i == j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0)+ _ -> e+ | nm == "GHC.Integer.Type.eqInteger#"+ = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]- | i == j -> Literal (IntegerLiteral 1)- | otherwise -> Literal (IntegerLiteral 0)+ | i == j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0) _ -> e- | nm == "GHC.Prim.>#" || nm == "GHC.Integer.Type.gtInteger#"+ | nm == "GHC.Prim.>#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of+ [Literal (IntLiteral i), Literal (IntLiteral j)]+ | i > j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0)+ _ -> e+ | nm == "GHC.Integer.Type.gtInteger#"+ = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]- | i > j -> Literal (IntegerLiteral 1)- | otherwise -> Literal (IntegerLiteral 0)+ | i > j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0) _ -> e- | nm == "GHC.Prim.<#" || nm == "GHC.Integer.Type.ltInteger#"+ | nm == "GHC.Prim.<#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of+ [Literal (IntLiteral i), Literal (IntLiteral j)]+ | i < j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0)+ _ -> e+ | nm == "GHC.Integer.Type.ltInteger#"+ = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]- | i < j -> Literal (IntegerLiteral 1)- | otherwise -> Literal (IntegerLiteral 0)+ | i < j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0) _ -> e- | nm == "GHC.Prim.<=#" || nm == "GHC.Integer.Type.leInteger#"+ | nm == "GHC.Prim.<=#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of+ [Literal (IntLiteral i), Literal (IntLiteral j)]+ | i <= j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0)+ _ -> e+ | nm == "GHC.Integer.Type.leInteger#"+ = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]- | i <= j -> Literal (IntegerLiteral 1)- | otherwise -> Literal (IntegerLiteral 0)+ | i <= j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0) _ -> e- | nm == "GHC.Prim.>=#" || nm == "GHC.Integer.Type.geInteger#"+ | nm == "GHC.Prim.>=#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of+ [Literal (IntLiteral i), Literal (IntLiteral j)]+ | i >= j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0)+ _ -> e+ | nm == "GHC.Integer.Type.geInteger#"+ = case (map (reduceConstant tcm isSubj) . Either.lefts) args of [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]- | i >= j -> Literal (IntegerLiteral 1)- | otherwise -> Literal (IntegerLiteral 0)+ | i >= j -> Literal (IntLiteral 1)+ | otherwise -> Literal (IntLiteral 0) _ -> e | nm == "GHC.Integer.Type.integerToInt" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of- [Literal (IntegerLiteral i)] -> Literal (IntegerLiteral i)+ [Literal (IntegerLiteral i)] -> Literal (IntLiteral i) _ -> e | nm == "GHC.Prim.tagToEnum#" = case map (Bifunctor.bimap (reduceConstant tcm isSubj) id) args of- [Right (ConstTy (TyCon tcN)), Left (Literal (IntegerLiteral i))] ->+ [Right (ConstTy (TyCon tcN)), Left (Literal (IntLiteral i))] -> let dc = do { tc <- HashMap.lookup tcN tcm ; let dcs = tyConDataCons tc ; List.find ((== (i+1)) . toInteger . dcTag) dcs@@ -68,8 +98,8 @@ _ -> e | nm == "GHC.Prim.*#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of- [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]- -> Literal (IntegerLiteral (i * j))+ [Literal (IntLiteral i), Literal (IntLiteral j)]+ -> Literal (IntLiteral (i * j)) _ -> e | nm == "GHC.Integer.Type.eqInteger" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of@@ -102,27 +132,27 @@ _ -> e | nm == "GHC.Prim.quotRemInt#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of- [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]+ [Literal (IntLiteral i), Literal (IntLiteral j)] -> let (_,tyView -> TyConApp tupTcNm tyArgs) = splitFunForallTy ty (Just tupTc) = HashMap.lookup tupTcNm tcm [tupDc] = tyConDataCons tupTc (q,r) = quotRem i j- ret = mkApps (Data tupDc) (map Right tyArgs ++ [Left (Literal (IntegerLiteral q)), Left (Literal (IntegerLiteral r))])+ ret = mkApps (Data tupDc) (map Right tyArgs ++ [Left (Literal (IntLiteral q)), Left (Literal (IntLiteral r))]) in ret _ -> e | nm == "GHC.Integer.Type.shiftLInteger" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of- [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]+ [Literal (IntegerLiteral i), Literal (IntLiteral j)] -> Literal (IntegerLiteral (i `shiftL` fromInteger j)) _ -> e | nm == "GHC.Integer.Type.shiftRInteger" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of- [Literal (IntegerLiteral i), Literal (IntegerLiteral j)]+ [Literal (IntegerLiteral i), Literal (IntLiteral j)] -> Literal (IntegerLiteral (i `shiftR` fromInteger j)) _ -> e | nm == "GHC.Prim.negateInt#" = case (map (reduceConstant tcm isSubj) . Either.lefts) args of- [Literal (IntegerLiteral i)] -> Literal (IntegerLiteral (negate i))+ [Literal (IntLiteral i)] -> Literal (IntLiteral (negate i)) _ -> e | nm == "CLaSH.Sized.Internal.Signed.minBound#" = case args of
src-ghc/CLaSH/GHC/GHC2Core.hs view
@@ -30,7 +30,6 @@ import Data.Maybe (fromMaybe) import Data.Text (isInfixOf,pack) import qualified Data.Traversable as T-import Data.Typeable (Typeable) import Unbound.Generics.LocallyNameless (bind, embed, rebind, rec, runFreshM, string2Name, unbind, unembed)@@ -310,11 +309,11 @@ -> C.Literal coreToLiteral l = case l of MachStr fs -> C.StringLiteral (Char8.unpack fs)- MachChar c -> C.StringLiteral [c]- MachInt i -> C.IntegerLiteral i- MachInt64 i -> C.IntegerLiteral i- MachWord i -> C.IntegerLiteral i- MachWord64 i -> C.IntegerLiteral i+ MachChar c -> C.CharLiteral c+ MachInt i -> C.IntLiteral i+ MachInt64 i -> C.IntLiteral i+ MachWord i -> C.WordLiteral i+ MachWord64 i -> C.WordLiteral i LitInteger i _ -> C.IntegerLiteral i MachFloat r -> C.RationalLiteral r MachDouble r -> C.RationalLiteral r@@ -393,8 +392,7 @@ coreToId i = C.Id <$> (coreToVar i) <*> (embed <$> coreToType (varType i)) -coreToVar :: Typeable a- => Var+coreToVar :: Var -> State GHC2CoreState (Unbound.Name a) coreToVar = coreToName varName varUnique qualfiedNameStringM @@ -402,8 +400,7 @@ -> State GHC2CoreState (Unbound.Name C.Term) coreToPrimVar = coreToName varName varUnique qualfiedNameString -coreToName :: Typeable a- => (b -> Name)+coreToName :: (b -> Name) -> (b -> Unique) -> (Name -> State GHC2CoreState String) -> b
src-ghc/CLaSH/GHC/LoadModules.hs view
@@ -8,6 +8,10 @@ ) where +#ifndef TOOL_VERSION_ghc+#error TOOL_VERSION_ghc undefined+#endif+ -- External Modules import Data.List (nub) import Data.Word (Word8)
src-ghc/CLaSH/GHC/NetlistTypes.hs view
@@ -4,101 +4,111 @@ (ghcTypeToHWType) where +import Data.Coerce (coerce)+import Data.Functor.Identity (Identity (..)) import Data.HashMap.Strict (HashMap,(!))-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Control.Monad.Trans.Except (ExceptT (..), mapExceptT, runExceptT) import Unbound.Generics.LocallyNameless (name2String) +import CLaSH.Core.DataCon (DataCon (..)) import CLaSH.Core.Pretty (showDoc)-import CLaSH.Core.TyCon (TyCon (..), TyConName)-import CLaSH.Core.Type (LitTy (..), Type (..), TypeView (..),- findFunSubst, tyView)+import CLaSH.Core.TyCon (TyCon (..), TyConName, tyConDataCons)+import CLaSH.Core.Type (Type (..), TypeView (..), findFunSubst,+ tyView)+import CLaSH.Core.Util (tyNatSize) import CLaSH.Netlist.Util (coreTypeToHWType) import CLaSH.Netlist.Types (HWType(..))-import CLaSH.Util+import CLaSH.Util (curLoc) -ghcTypeToHWType :: HashMap TyConName TyCon+ghcTypeToHWType :: Int+ -> HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)-ghcTypeToHWType m ty@(tyView -> TyConApp tc args) = runExceptT $- case name2String tc of- "Int" -> return Integer- "GHC.Integer.Type.Integer" -> return Integer- "GHC.Prim.Int#" -> return Integer- "GHC.Types.Int" -> return Integer- "GHC.Prim.ByteArray#" ->- fail $ "Can't translate type: " ++ showDoc ty-- "GHC.Types.Bool" -> return Bool- "GHC.Prim.~#" ->- fail $ "Can't translate type: " ++ showDoc ty-- "CLaSH.Signal.Internal.Signal'" ->- ExceptT $ return $ coreTypeToHWType ghcTypeToHWType m (args !! 1)+ghcTypeToHWType iw = go+ where+ go m ty@(tyView -> TyConApp tc args) = runExceptT $+ case name2String tc of+ "GHC.Int.Int8" -> return (Signed 8)+ "GHC.Int.Int16" -> return (Signed 16)+ "GHC.Int.Int32" -> return (Signed 32)+ "GHC.Int.Int64" ->+ if iw < 64+ then case tyConDataCons (m ! tc) of+ [dc] -> case dcArgTys dc of+ [tyView -> TyConApp nm _]+ | name2String nm == "GHC.Prim.Int#" ->+ error $ unlines ["Int64 not supported in forced 32-bit mode on a 64-bit machine."+ ,"Run CLaSH with `-clash-intwidth=64`."+ ]+ | name2String nm == "GHC.Prim.Int64#" ->+ return (Signed 64)+ _ -> error $ $(curLoc) ++ "Int64 DC has unexpected amount of arguments"+ _ -> error $ $(curLoc) ++ "Int64 TC has unexpected amount of DCs"+ else return (Signed 64)+ "GHC.Word.Word8" -> return (Unsigned 8)+ "GHC.Word.Word16" -> return (Unsigned 16)+ "GHC.Word.Word32" -> return (Unsigned 32)+ "GHC.Word.Word64" ->+ if iw < 64+ then case tyConDataCons (m ! tc) of+ [dc] -> case dcArgTys dc of+ [tyView -> TyConApp nm _]+ | name2String nm == "GHC.Prim.Word#" ->+ error $ unlines ["Word64 not supported in forced 32-bit mode on a 64-bit machine."+ ,"Run CLaSH with `-clash-intwidth=64`."+ ]+ | name2String nm == "GHC.Prim.Word64#" ->+ return (Unsigned 64)+ _ -> error $ $(curLoc) ++ "Word64 DC has unexpected amount of arguments"+ _ -> error $ $(curLoc) ++ "Word64 TC has unexpected amount of DCs"+ else return (Unsigned 64)+ "GHC.Integer.Type.Integer" -> return (Signed iw)+ "GHC.Prim.Char#" -> return (Unsigned 21)+ "GHC.Prim.Int#" -> return (Signed iw)+ "GHC.Prim.Word#" -> return (Unsigned iw)+ "GHC.Prim.Int64#" -> return (Signed 64)+ "GHC.Prim.Word64#" -> return (Unsigned 64)+ "GHC.Prim.ByteArray#" ->+ fail $ "Can't translate type: " ++ showDoc ty - "CLaSH.Sized.Internal.BitVector.BitVector" ->- BitVector <$> tyNatSize m (head args)+ "GHC.Types.Bool" -> return Bool+ "GHC.Prim.~#" ->+ fail $ "Can't translate type: " ++ showDoc ty - "CLaSH.Sized.Internal.Index.Index" ->- Index <$> tyNatSize m (head args)+ "CLaSH.Signal.Internal.Signal'" ->+ ExceptT $ return $ coreTypeToHWType go m (args !! 1) - "CLaSH.Sized.Internal.Signed.Signed" ->- Signed <$> tyNatSize m (head args)+ "CLaSH.Sized.Internal.BitVector.BitVector" ->+ BitVector <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) - "CLaSH.Sized.Internal.Unsigned.Unsigned" ->- Unsigned <$> tyNatSize m (head args)+ "CLaSH.Sized.Internal.Index.Index" ->+ Index <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) - "CLaSH.Sized.Vector.Vec" -> do- let [szTy,elTy] = args- sz <- tyNatSize m szTy- elHWTy <- ExceptT $ return $ coreTypeToHWType ghcTypeToHWType m elTy- return $ Vector sz elHWTy+ "CLaSH.Sized.Internal.Signed.Signed" ->+ Signed <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) - "String" -> return String- "GHC.Types.[]" -> case tyView (head args) of- (TyConApp (name2String -> "GHC.Types.Char") []) -> return String- _ -> fail $ "Can't translate type: " ++ showDoc ty+ "CLaSH.Sized.Internal.Unsigned.Unsigned" ->+ Unsigned <$> mapExceptT (Just . coerce) (tyNatSize m (head args)) - _ -> case m ! tc of- -- 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.- FunTyCon {tyConSubst = tcSubst} -> case findFunSubst tcSubst args of- Just ty' -> ExceptT $ return $ coreTypeToHWType ghcTypeToHWType m ty'- _ -> ExceptT Nothing- _ -> ExceptT Nothing+ "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 -ghcTypeToHWType _ _ = Nothing+ "String" -> return String+ "GHC.Types.[]" -> case tyView (head args) of+ (TyConApp (name2String -> "GHC.Types.Char") []) -> return String+ _ -> fail $ "Can't translate type: " ++ showDoc ty -tyNatSize :: HashMap TyConName TyCon- -> Type- -> ExceptT String Maybe Int-tyNatSize _ (LitTy (NumTy i)) = return i-tyNatSize m ty@(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- "GHC.TypeLits.Extra.CLog" -> do- i1' <- tyNatSize m ty1- i2' <- tyNatSize m ty2- if (i1' > 1 && i2' > 0)- then return (ceiling (logBase (fromIntegral i1' :: Double)- (fromIntegral i2' :: Double)))- else fail $ $(curLoc) ++ "Can't convert: " ++ show ty- "GHC.TypeLits.Extra.GCD" -> gcd <$> 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 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+ _ -> case m ! tc of+ -- 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.+ FunTyCon {tyConSubst = tcSubst} -> case findFunSubst tcSubst args of+ Just ty' -> ExceptT $ return $ coreTypeToHWType go m ty'+ _ -> ExceptT Nothing+ _ -> ExceptT Nothing -tyNatSize _ t = fail $ $(curLoc) ++ "Can't convert tyNat: " ++ show t+ go _ _ = Nothing