diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: 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.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 diff --git a/src-bin/InteractiveUI.hs b/src-bin/InteractiveUI.hs --- a/src-bin/InteractiveUI.hs +++ b/src-bin/InteractiveUI.hs @@ -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 diff --git a/src-bin/Main.hs b/src-bin/Main.hs --- a/src-bin/Main.hs +++ b/src-bin/Main.hs @@ -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 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 @@ -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.") 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 @@ -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 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 @@ -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 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 @@ -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) 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,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