X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDLTools.hs;h=cb4ea741645619d98d37f953930167f39162ab45;hb=f2ce393c85a9ccb673f8ba2df12b7c5b649c3a34;hp=12681160b25b7556acd9cc5998590816fe4aeaa7;hpb=59b710f483534efd4a293f880235f444a5156451;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDLTools.hs b/VHDLTools.hs
index 1268116..cb4ea74 100644
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -8,6 +8,7 @@ import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Data.Monoid as Monoid
 import Data.Accessor
+import Debug.Trace
 
 -- ForSyDe
 import qualified ForSyDe.Backend.VHDL.AST as AST
@@ -126,7 +127,20 @@ varToVHDLExpr var =
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
-    Nothing -> AST.PrimName $ AST.NSimple $ varToVHDLId var
+    -- Sadly so.. tfp decimals are types, not data constructors, but instances
+    -- should still be translated to integer literals. It is probebly not the
+    -- best solution to translate them here.
+    -- FIXME: Find a better solution for translating instances of tfp integers
+    Nothing -> 
+        let 
+          ty  = Var.varType var
+          res = case Type.splitTyConApp_maybe ty of
+                  Just (tycon, args) ->
+                    case Name.getOccString (TyCon.tyConName tycon) of
+                      "Dec" -> AST.PrimLit $ (show (eval_tfp_int ty))
+                      otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
+        in
+          res
 
 -- Turn a VHDLName into an AST expression
 vhdlNameToVHDLExpr = AST.PrimName
@@ -143,8 +157,8 @@ exprToVHDLExpr = varToVHDLExpr . exprToVar
 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
 
-altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
-altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+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
@@ -243,41 +257,44 @@ mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 builtin_types = 
   Map.fromList [
     ("Bit", std_logicTM),
-    ("Bool", booleanTM) -- TysWiredIn.boolTy
+    ("Bool", booleanTM), -- TysWiredIn.boolTy
+    ("Dec", integerTM)
   ]
 
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
-vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
-vhdl_ty ty = do
+vhdl_ty :: String -> Type.Type -> VHDLSession AST.TypeMark
+vhdl_ty msg ty = do
   typemap <- getA vsTypes
+  htype <- mkHType ty
   let builtin_ty = do -- See if this is a tycon and lookup its name
         (tycon, args) <- Type.splitTyConApp_maybe ty
         let name = Name.getOccString (TyCon.tyConName tycon)
         Map.lookup name builtin_types
   -- If not a builtin type, try the custom types
-  let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
+  let existing_ty = (fmap fst) $ Map.lookup htype typemap
   case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
     -- Found a type, return it
     Just t -> return t
     -- No type yet, try to construct it
     Nothing -> do
-      newty_maybe <- (construct_vhdl_ty ty)
+      newty_maybe <- (construct_vhdl_ty msg ty)
       case newty_maybe of
         Just (ty_id, ty_def) -> do
           -- TODO: Check name uniqueness
-          modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
+          modA vsTypes (Map.insert htype (ty_id, ty_def))
+          modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
           return ty_id
-        Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
+        Nothing -> error $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
 
 -- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-construct_vhdl_ty ty = do
+construct_vhdl_ty :: String -> Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty msg ty = do
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of
         "TFVec" -> do
-          res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
+          res <- mk_vector_ty ty
           return $ Just $ (Arrow.second Right) res
         -- "SizedWord" -> do
         --   res <- mk_vector_ty (sized_word_len ty) ty
@@ -286,31 +303,33 @@ construct_vhdl_ty ty = do
           res <- mk_natural_ty 0 (ranged_word_bound ty)
           return $ Just $ (Arrow.second Right) res
         -- Create a custom type from this tycon
-        otherwise -> mk_tycon_ty tycon args
+        otherwise -> mk_tycon_ty msg tycon args
     Nothing -> return $ Nothing
 
 -- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_tycon_ty tycon args =
+mk_tycon_ty :: String -> TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty msg tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
-    [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
+    [] -> error $ "\nVHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon
     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
       -- violation? Or does it only mean not to apply it again to the same
       -- subject?
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
-      elem_tys <- mapM vhdl_ty real_arg_tys
+      let error_msg = msg ++ "\nVHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for one of the arguments."
+      elem_tys <- mapM (vhdl_ty error_msg) real_arg_tys
       let elems = zipWith AST.ElementDec recordlabels elem_tys
       -- For a single construct datatype, build a record with one field for
       -- each argument.
       -- TODO: Add argument type ids to this, to ensure uniqueness
       -- TODO: Special handling for tuples?
-      let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+      let elem_names = concat $ map prettyShow elem_tys
+      let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
       let ty_def = AST.TDR $ AST.RecordTypeDef elems
       return $ Just (ty_id, Left ty_def)
-    dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon
+    dcs -> error $ "\nVHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon
   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
@@ -322,16 +341,21 @@ mk_tycon_ty tycon args =
 
 -- | Create a VHDL vector type
 mk_vector_ty ::
-  Int -- ^ The length of the vector
-  -> Type.Type -- ^ The Haskell element type of the Vector
+  Type.Type -- ^ The Haskell type of the Vector
   -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 
-mk_vector_ty len el_ty = do
-  elem_types_map <- getA vsElemTypes
-  el_ty_tm <- vhdl_ty el_ty
+mk_vector_ty ty = do
+  types_map <- getA vsTypes
+  let (nvec_l, nvec_el) = Type.splitAppTy ty
+  let (nvec, leng) = Type.splitAppTy nvec_l
+  let vec_ty = Type.mkAppTy nvec nvec_el
+  let len = tfvec_len ty
+  let el_ty = tfvec_elem ty
+  let error_msg = "\nVHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty 
+  el_ty_tm <- vhdl_ty error_msg el_ty
   let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
   let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
-  let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
+  let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
   case existing_elem_ty of
     Just t -> do
       let ty_def = AST.SubtypeIn t (Just range)
@@ -339,8 +363,8 @@ mk_vector_ty len el_ty = do
     Nothing -> do
       let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
       let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
-      modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
-      --modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id)) 
+      modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
+      modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) 
       let ty_def = AST.SubtypeIn vec_id (Just range)
       return (ty_id, ty_def)
 
@@ -359,9 +383,53 @@ mk_natural_ty min_bound max_bound = do
 getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
 getFieldLabels ty = do
   -- Ensure that the type is generated (but throw away it's VHDLId)
-  vhdl_ty ty
+  let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
+  vhdl_ty error_msg ty
   -- Get the types map, lookup and unpack the VHDL TypeDef
   types <- getA vsTypes
-  case Map.lookup (OrdType ty) types of
+  htype <- mkHType ty
+  case Map.lookup htype types of
     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
-    _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+    _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
+    
+mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
+mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
+mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
+
+mkHType :: Type.Type -> VHDLSession HType
+mkHType ty = do
+  -- FIXME: Do we really need to do this here again?
+  let builtin_ty = do -- See if this is a tycon and lookup its name
+        (tycon, args) <- Type.splitTyConApp_maybe ty
+        let name = Name.getOccString (TyCon.tyConName tycon)
+        Map.lookup name builtin_types
+  case builtin_ty of
+    Just typ -> 
+      return $ BuiltinType $ prettyShow typ
+    Nothing ->
+      case Type.splitTyConApp_maybe ty of
+        Just (tycon, args) -> do
+          let name = Name.getOccString (TyCon.tyConName tycon)
+          case name of
+            "TFVec" -> do
+              elem_htype <- mkHType (tfvec_elem ty)
+              return $ VecType (tfvec_len ty) elem_htype
+            otherwise -> do
+              mkTyConHType tycon args
+        Nothing -> return $ StdType $ OrdType ty
+
+-- FIXME: Do we really need to do this here again?
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> VHDLSession HType
+mkTyConHType tycon args =
+  case TyCon.tyConDataCons tycon of
+    -- Not an algebraic type
+    [] -> error $ "\nVHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon
+    [dc] -> do
+      let arg_tys = DataCon.dataConRepArgTys dc
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      elem_htys <- mapM mkHType real_arg_tys
+      return $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+    dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon
+  where
+    tyvars = TyCon.tyConTyVars tycon
+    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
\ No newline at end of file