Add support for enumeration types.

The generated VHDL 'show' function is kind of lame, it only prints
the name of the type, not the actual datacon.

diff --git a/cλash/CLasH/Translator/TranslatorTypes.hs b/cλash/CLasH/Translator/TranslatorTypes.hs
index 7483504fd08c12083c4ff58038eca4a916ffafe5..c9c94055a199a124ab34588cd10f14f3f1f70fa0 100644 (file)
--- a/cλash/CLasH/Translator/TranslatorTypes.hs
+++ b/cλash/CLasH/Translator/TranslatorTypes.hs
@@ -47,6 +47,7 @@ instance Ord OrdType where
 
 data HType = StdType OrdType |
              ADTType String [HType] |
+             EnumType String [String] |
              VecType Int HType |
              SizedWType Int |
              RangedWType Int |

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index dee2a794694394b371f26129a1e79c54ae6c5da2..da8be8a7afda04735e7ba3e07abae4c5252ae602 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -234,7 +234,8 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
 -- first is the default case, if there is any.
 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
-  let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
+  altcon <- MonadState.lift tsType $ altconToVHDLExpr con
+  let cond_expr = scrut' AST.:=: altcon
   true_expr <- MonadState.lift tsType $ varToVHDLExpr true
   false_expr <- MonadState.lift tsType $ varToVHDLExpr false
   return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])

diff --git a/cλash/CLasH/VHDL/VHDLTools.hs b/cλash/CLasH/VHDL/VHDLTools.hs
index cff65a68606a0a508ff05d8e882dab2ac49a981a..5fc34739611f4fa9efd4825e8fb32d65164dfd31 100644 (file)
--- a/cλash/CLasH/VHDL/VHDLTools.hs
+++ b/cλash/CLasH/VHDL/VHDLTools.hs
@@ -129,7 +129,7 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 varToVHDLExpr :: Var.Var -> TypeSession AST.Expr
 varToVHDLExpr var = do
   case Id.isDataConWorkId_maybe var of
-    Just dc -> return $ dataconToVHDLExpr dc
+    Just dc -> dataconToVHDLExpr dc
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
@@ -159,23 +159,37 @@ exprToVHDLExpr core = varToVHDLExpr (exprToVar core)
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 -- has. Should not be called with a DEFAULT constructor.
-altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+altconToVHDLExpr :: CoreSyn.AltCon -> TypeSession AST.Expr
 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
 
 -- Turn a datacon (without arguments!) into a VHDL expression.
-dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
-dataconToVHDLExpr dc = AST.PrimLit lit
-  where
-    tycon = DataCon.dataConTyCon dc
-    tyname = TyCon.tyConName tycon
-    dcname = DataCon.dataConName dc
-    lit = case Name.getOccString tyname of
-      -- TODO: Do something more robust than string matching
-      "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
-      "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+dataconToVHDLExpr :: DataCon.DataCon -> TypeSession AST.Expr
+dataconToVHDLExpr dc = do
+  typemap <- getA tsTypes
+  htype_either <- mkHType (DataCon.dataConRepType dc)
+  case htype_either of
+    -- No errors
+    Right htype -> do
+      let existing_ty = (Monad.liftM $ fmap fst) $ Map.lookup htype typemap
+      case existing_ty of
+        Just ty -> do
+          let dcname = DataCon.dataConName dc
+          let lit    = idToVHDLExpr $ mkVHDLExtId $ Name.getOccString dcname
+          return lit
+        Nothing -> do
+          let tycon = DataCon.dataConTyCon dc
+          let tyname = TyCon.tyConName tycon
+          let dcname = DataCon.dataConName dc
+          let lit = case Name.getOccString tyname of
+              -- TODO: Do something more robust than string matching
+                "Bit"  -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+                "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+          return $ AST.PrimLit lit
+    -- Error when constructing htype
+    Left err -> error err
 
 -----------------------------------------------------------------------------
 -- Functions dealing with names, variables and ids
@@ -380,7 +394,19 @@ mk_tycon_ty ty tycon args =
         (errors, _) -> return $ Left $
           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)
-    dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+    dcs -> do
+      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      case real_arg_tys of
+        [] -> do
+          let elems = map (mkVHDLExtId . nameToString . DataCon.dataConName) dcs
+          let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+          let ty_def = AST.TDE $ AST.EnumTypeDef elems
+          let enumShow = mkEnumShow elems ty_id
+          modA tsTypeFuns $ Map.insert (OrdType ty, showIdString) (showId, enumShow)
+          return $ Right $ Just (ty_id, Left ty_def)
+        xs -> return $ Left $
+          "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
   where
     -- Create a subst that instantiates all types passed to the tycon
     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
@@ -529,7 +555,7 @@ mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
-    [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
+    [] -> return $ Left $ "VHDLTools.mkTyConHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
@@ -540,9 +566,16 @@ mkTyConHType tycon args =
           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
         -- There were errors in element types
         (errors, _) -> return $ Left $
-          "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+          "VHDLTools.mkTyConHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
           ++ (concat errors)
-    dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+    dcs -> do
+      let arg_tys = concat $ map DataCon.dataConRepArgTys dcs
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      case real_arg_tys of
+        [] ->
+          return $ Right $ EnumType (nameToString (TyCon.tyConName tycon)) (map (nameToString . DataCon.dataConName) dcs)
+        xs -> return $ Left $
+          "VHDLTools.mkTyConHType: Only enum-like constructor datatypes supported: " ++ pprString dcs ++ "\n"
   where
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
@@ -609,6 +642,17 @@ mkTupleShow elemTMs tupleTM = AST.SubProgBody showSpec [] [showExpr]
     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
     tupSize = length elemTMs
 
+mkEnumShow ::
+  [AST.VHDLId]
+  -> AST.TypeMark
+  -> AST.SubProgBody
+mkEnumShow elemIds enumTM = AST.SubProgBody showSpec [] [showExpr]
+  where
+    enumPar    = AST.unsafeVHDLBasicId "enum"
+    showSpec  = AST.Function showId [AST.IfaceVarDec enumPar enumTM] stringTM
+    showExpr  = AST.ReturnSm (Just $
+                  AST.PrimLit (show $ tail $ init $ AST.fromVHDLId enumTM))
+
 mkVectorShow ::
   AST.TypeMark -- ^ elemtype
   -> AST.TypeMark -- ^ vectype