Add support for Haskell types: Word(N), Int(N), and Char

clash-ghc/src-ghc/CLaSH/GHC/Evaluator.hs

@@ -23,43 +23,73 @@ import           CLaSH.Core.Var      (Var (..))
 
 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.>#"
+  = 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.Prim.>#" || nm == "GHC.Integer.Type.gtInteger#"
+  | 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.<=#"
+  = 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.Prim.<=#" || nm == "GHC.Integer.Type.leInteger#"
+  | 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.>=#"
+  = 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.Prim.>=#" || nm == "GHC.Integer.Type.geInteger#"
+  | 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 @@ reduceConstant tcm isSubj e@(collectArgs -> (Prim nm ty, args))
       _ -> 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 @@ reduceConstant tcm isSubj e@(collectArgs -> (Prim nm ty, args))
       _ -> 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

clash-ghc/src-ghc/CLaSH/GHC/GHC2Core.hs

@@ -310,11 +310,11 @@ coreToTerm primMap unlocs coreExpr = term coreExpr
                   -> 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

clash-ghc/src-ghc/CLaSH/GHC/NetlistTypes.hs

@@ -1,9 +1,12 @@
+{-# LANGUAGE CPP             #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ViewPatterns    #-}
 module CLaSH.GHC.NetlistTypes
   (ghcTypeToHWType)
 where
 
+#include "MachDeps.h"
+
 import Data.HashMap.Strict              (HashMap,(!))
 import Control.Monad.Trans.Except       (ExceptT (..), runExceptT)
 import Unbound.Generics.LocallyNameless (name2String)
@@ -21,10 +24,18 @@ ghcTypeToHWType :: HashMap TyConName TyCon
                 -> Maybe (Either String HWType)
 ghcTypeToHWType m ty@(tyView -> TyConApp tc args) = runExceptT $
   case name2String tc of
-    "Int"                           -> return Integer
+    "GHC.Int.Int8"                  -> return (Signed 8)
+    "GHC.Int.Int16"                 -> return (Signed 16)
+    "GHC.Int.Int32"                 -> return (Signed 32)
+    "GHC.Int.Int64"                 -> return (Signed 64)
+    "GHC.Word.Word8"                -> return (Unsigned 8)
+    "GHC.Word.Word16"               -> return (Unsigned 16)
+    "GHC.Word.Word32"               -> return (Unsigned 32)
+    "GHC.Word.Word64"               -> return (Unsigned 64)
     "GHC.Integer.Type.Integer"      -> return Integer
-    "GHC.Prim.Int#"                 -> return Integer
-    "GHC.Types.Int"                 -> return Integer
+    "GHC.Prim.Char#"                -> return (Unsigned 21)
+    "GHC.Prim.Int#"                 -> return (Signed WORD_SIZE_IN_BITS)
+    "GHC.Prim.Word#"                -> return (Unsigned WORD_SIZE_IN_BITS)
     "GHC.Prim.ByteArray#"           ->
       fail $ "Can't translate type: " ++ showDoc ty
 

clash-lib/src/CLaSH/Core/Literal.hs

@@ -16,13 +16,18 @@ import Unbound.Generics.LocallyNameless.Extra ()
 import Unbound.Generics.LocallyNameless       (Alpha (..), Subst (..))
 
 import {-# SOURCE #-} CLaSH.Core.Type         (Type)
-import CLaSH.Core.TysPrim                     (intPrimTy, stringPrimTy, voidPrimTy)
+import CLaSH.Core.TysPrim                     (intPrimTy, integerPrimTy,
+                                               charPrimTy, stringPrimTy,
+                                               voidPrimTy, wordPrimTy)
 
 -- | Term Literal
 data Literal
   = IntegerLiteral  !Integer
+  | IntLiteral      !Integer
+  | WordLiteral     !Integer
   | StringLiteral   !String
   | RationalLiteral !Rational
+  | CharLiteral     !Char
   deriving (Eq,Ord,Show,Generic,NFData)
 
 instance Alpha Literal where
@@ -35,6 +40,9 @@ instance Subst a Literal where
 -- | Determines the Type of a Literal
 literalType :: Literal
             -> Type
-literalType (IntegerLiteral  _) = intPrimTy
-literalType (RationalLiteral _) = voidPrimTy
+literalType (IntegerLiteral  _) = integerPrimTy
+literalType (IntLiteral      _) = intPrimTy
+literalType (WordLiteral     _) = wordPrimTy
 literalType (StringLiteral   _) = stringPrimTy
+literalType (RationalLiteral _) = voidPrimTy
+literalType (CharLiteral     _) = charPrimTy

clash-lib/src/CLaSH/Core/Pretty.hs

@@ -121,7 +121,12 @@ instance Pretty Literal where
     IntegerLiteral i
       | i < 0         -> return $ parens (integer i)
       | otherwise     -> return $ integer i
+    IntLiteral i
+      | i < 0         -> return $ parens (integer i)
+      | otherwise     -> return $ integer i
+    WordLiteral w     -> return $ integer w
     RationalLiteral r -> return $ rational r
+    CharLiteral c     -> return $ char c
     StringLiteral s   -> return $ vcat $ map text $ showMultiLineString s
 
 instance Pretty Pat where

clash-lib/src/CLaSH/Core/TysPrim.hs

@@ -4,8 +4,11 @@ module CLaSH.Core.TysPrim
   , typeNatKind
   , typeSymbolKind
   , intPrimTy
+  , integerPrimTy
+  , charPrimTy
   , stringPrimTy
   , voidPrimTy
+  , wordPrimTy
   , tysPrimMap
   )
 where
@@ -38,25 +41,35 @@ typeNatKind    = mkTyConTy typeNatKindTyConName
 typeSymbolKind = mkTyConTy typeSymbolKindTyConName
 
 
-intPrimTyConName, stringPrimTyConName, voidPrimTyConName :: TyConName
-intPrimTyConName    = string2Name "Int"
-stringPrimTyConName = string2Name "String"
-voidPrimTyConName   = string2Name "VOID"
+intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName,
+  voidPrimTyConName, wordPrimTyConName :: TyConName
+intPrimTyConName     = string2Name "GHC.Prim.Int#"
+integerPrimTyConName = string2Name "GHC.Integer.Type.Integer"
+stringPrimTyConName  = string2Name "String"
+charPrimTyConName    = string2Name "GHC.Prim.Char#"
+voidPrimTyConName    = string2Name "VOID"
+wordPrimTyConName    = string2Name "GHC.Prim.Word#"
 
 liftedPrimTC :: TyConName
              -> TyCon
 liftedPrimTC name = PrimTyCon name liftedTypeKind 0
 
 -- | Builtin Type
-intPrimTc, stringPrimTc, voidPrimTc :: TyCon
-intPrimTc    = (liftedPrimTC intPrimTyConName )
-stringPrimTc = (liftedPrimTC stringPrimTyConName)
-voidPrimTc   = (liftedPrimTC voidPrimTyConName)
+intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc :: TyCon
+intPrimTc     = liftedPrimTC intPrimTyConName
+integerPrimTc = liftedPrimTC integerPrimTyConName
+charPrimTc    = liftedPrimTC charPrimTyConName
+stringPrimTc  = liftedPrimTC stringPrimTyConName
+voidPrimTc    = liftedPrimTC voidPrimTyConName
+wordPrimTc    = liftedPrimTC wordPrimTyConName
 
-intPrimTy, stringPrimTy, voidPrimTy :: Type
-intPrimTy    = mkTyConTy intPrimTyConName
-stringPrimTy = mkTyConTy stringPrimTyConName
-voidPrimTy   = mkTyConTy voidPrimTyConName
+intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy :: Type
+intPrimTy     = mkTyConTy intPrimTyConName
+integerPrimTy = mkTyConTy integerPrimTyConName
+charPrimTy    = mkTyConTy charPrimTyConName
+stringPrimTy  = mkTyConTy stringPrimTyConName
+voidPrimTy    = mkTyConTy voidPrimTyConName
+wordPrimTy    = mkTyConTy wordPrimTyConName
 
 tysPrimMap :: HashMap TyConName TyCon
 tysPrimMap = HashMap.fromList
@@ -65,6 +78,9 @@ tysPrimMap = HashMap.fromList
   , (typeNatKindTyConName,typeNatKindtc)
   , (typeSymbolKindTyConName,typeSymbolKindtc)
   , (intPrimTyConName,intPrimTc)
+  , (integerPrimTyConName,integerPrimTc)
+  , (charPrimTyConName,charPrimTc)
   , (stringPrimTyConName,stringPrimTc)
   , (voidPrimTyConName,voidPrimTc)
+  , (wordPrimTyConName,wordPrimTc)
   ]

clash-lib/src/CLaSH/Netlist.hs

@@ -1,13 +1,17 @@
+{-# LANGUAGE CPP             #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections   #-}
 
 -- | Create Netlists out of normalized CoreHW Terms
 module CLaSH.Netlist where
 
+#include "MachDeps.h"
+
 import           Control.Lens                     ((.=), (<<%=))
 import qualified Control.Lens                     as Lens
 import           Control.Monad.State.Strict       (runStateT)
 import           Control.Monad.Writer.Strict      (listen, runWriterT, tell)
+import           Data.Char                        (ord)
 import           Data.Either                      (lefts,partitionEithers)
 import           Data.HashMap.Lazy                (HashMap)
 import qualified Data.HashMap.Lazy                as HashMap
@@ -226,7 +230,10 @@ mkDeclarations bndr (Case scrut altTy alts) = do
       (,altDecls) <$> case pat of
         DefaultPat           -> return (Nothing,altExpr)
         DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)
-        LitPat  (Embed (IntegerLiteral i)) -> return (Just (NumLit $ fromInteger i),altExpr)
+        LitPat  (Embed (IntegerLiteral i)) -> return (Just (NumLit i),altExpr)
+        LitPat  (Embed (IntLiteral i)) -> return (Just (NumLit i), altExpr)
+        LitPat  (Embed (WordLiteral w)) -> return (Just (NumLit w), altExpr)
+        LitPat  (Embed (CharLiteral c)) -> return (Just (NumLit . toInteger $ ord c), altExpr)
         _                    -> error $ $(curLoc) ++ "Not an integer literal in LitPat"
 
     mkScrutExpr :: HWType -> Pat -> Expr -> Expr
@@ -301,11 +308,11 @@ mkExpr :: Bool -- ^ Treat BlackBox expression as declaration
        -> Type -- ^ Type of the LHS of the let-binder
        -> Term -- ^ Term to convert to an expression
        -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations
-mkExpr _ _ (Core.Literal lit) = return (HW.Literal (Just (Integer,32)) . NumLit $ fromInteger  $! i,[])
-  where
-    i = case lit of
-          (IntegerLiteral i') -> i'
-          _ -> error $ $(curLoc) ++ "not an integer literal"
+mkExpr _ _ (Core.Literal (IntegerLiteral i)) = return (HW.Literal (Just (Integer,32)) $ NumLit i, [])
+mkExpr _ _ (Core.Literal (IntLiteral i)) = return (HW.Literal (Just (Signed WORD_SIZE_IN_BITS,WORD_SIZE_IN_BITS)) $ NumLit i, [])
+mkExpr _ _ (Core.Literal (WordLiteral w)) = return (HW.Literal (Just (Unsigned WORD_SIZE_IN_BITS,WORD_SIZE_IN_BITS)) $ NumLit w, [])
+mkExpr _ _ (Core.Literal (CharLiteral c)) = return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, [])
+mkExpr _ _ (Core.Literal _) = error $ $(curLoc) ++ "not an integer literal"
 
 mkExpr bbEasD ty app = do
   let (appF,args) = collectArgs app