Keys for typemap can now deal with vector lengths based on type operators

Implementation is very slow, evalCoreExpr has to be run every time we
lookup and insert a new vector.

diff --git a/Adders.hs b/Adders.hs
index 6ada7df0f58d522c73522df6a3014c8944eb047c..9e78fcf87dd6a0b4c431133b5e6ad5bbfb9b918e 100644 (file)
--- a/Adders.hs
+++ b/Adders.hs
@@ -174,8 +174,8 @@ highordtest = \x ->
 
 xand a b = hwand a b
 
-functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit)
-functiontest = \v -> let r = (concat v, head v) in r
+functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit, TFVec D3 (TFVec D3 Bit))
+functiontest = \v -> let r = (concat v, head v, tail v) in r
 
 xhwnot x = hwnot x
 

diff --git a/Generate.hs b/Generate.hs
index 55f015608de743e03540a18e52633d66dfbead5f..dfd9fad8bbfaed867db25a8d368493387cae7c57 100644 (file)
--- a/Generate.hs
+++ b/Generate.hs
@@ -71,16 +71,16 @@ genOperator1' op _ f [arg] = return $ op arg
 
 -- | Generate a function call from the destination binder, function name and a
 -- list of expressions (its arguments)
-genFCall :: BuiltinBuilder 
-genFCall = genExprArgs $ genExprRes genFCall'
-genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
-genFCall' (Left res) f args = do
+genFCall :: Bool -> BuiltinBuilder 
+genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
+genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genFCall' switch (Left res) f args = do
   let fname = varToString f
-  let el_ty = (tfvec_elem . Var.varType) res
+  let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
   id <- vectorFunId el_ty fname
   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
-genFCall' (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
 -- | Generate a generate statement for the builtin function "map"
 genMap :: BuiltinBuilder
@@ -874,40 +874,40 @@ genUnconsVectorFuns elemTM vectorTM  =
 -- builder function.
 globalNameTable :: NameTable
 globalNameTable = Map.fromList
-  [ (exId             , (2, genFCall                ) )
-  , (replaceId        , (3, genFCall                ) )
-  , (headId           , (1, genFCall                ) )
-  , (lastId           , (1, genFCall                ) )
-  , (tailId           , (1, genFCall                ) )
-  , (initId           , (1, genFCall                ) )
-  , (takeId           , (2, genFCall                ) )
-  , (dropId           , (2, genFCall                ) )
-  , (selId            , (4, genFCall                ) )
-  , (plusgtId         , (2, genFCall                ) )
-  , (ltplusId         , (2, genFCall                ) )
-  , (plusplusId       , (2, genFCall                ) )
+  [ (exId             , (2, genFCall False          ) )
+  , (replaceId        , (3, genFCall False          ) )
+  , (headId           , (1, genFCall True           ) )
+  , (lastId           , (1, genFCall True           ) )
+  , (tailId           , (1, genFCall False          ) )
+  , (initId           , (1, genFCall False          ) )
+  , (takeId           , (2, genFCall False          ) )
+  , (dropId           , (2, genFCall False          ) )
+  , (selId            , (4, genFCall False          ) )
+  , (plusgtId         , (2, genFCall False          ) )
+  , (ltplusId         , (2, genFCall False          ) )
+  , (plusplusId       , (2, genFCall False          ) )
   , (mapId            , (2, genMap                  ) )
   , (zipWithId        , (3, genZipWith              ) )
   , (foldlId          , (3, genFoldl                ) )
   , (foldrId          , (3, genFoldr                ) )
   , (zipId            , (2, genZip                  ) )
   , (unzipId          , (1, genUnzip                ) )
-  , (shiftlId         , (2, genFCall                ) )
-  , (shiftrId         , (2, genFCall                ) )
-  , (rotlId           , (1, genFCall                ) )
-  , (rotrId           , (1, genFCall                ) )
+  , (shiftlId         , (2, genFCall False          ) )
+  , (shiftrId         , (2, genFCall False          ) )
+  , (rotlId           , (1, genFCall False          ) )
+  , (rotrId           , (1, genFCall False          ) )
   , (concatId         , (1, genConcat               ) )
-  , (reverseId        , (1, genFCall                ) )
+  , (reverseId        , (1, genFCall False          ) )
   , (iteratenId       , (3, genIteraten             ) )
   , (iterateId        , (2, genIterate              ) )
   , (generatenId      , (3, genGeneraten            ) )
   , (generateId       , (2, genGenerate             ) )
-  , (emptyId          , (0, genFCall                ) )
-  , (singletonId      , (1, genFCall                ) )
-  , (copynId          , (2, genFCall                ) )
+  , (emptyId          , (0, genFCall False          ) )
+  , (singletonId      , (1, genFCall False          ) )
+  , (copynId          , (2, genFCall False          ) )
   , (copyId           , (1, genCopy                 ) )
-  , (lengthTId        , (1, genFCall                ) )
-  , (nullId           , (1, genFCall                ) )
+  , (lengthTId        , (1, genFCall False          ) )
+  , (nullId           , (1, genFCall False          ) )
   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
   , (hwandId          , (2, genOperator2 AST.And    ) )
   , (hworId           , (2, genOperator2 AST.Or     ) )

diff --git a/VHDLTools.hs b/VHDLTools.hs
index 3b49b27fed8270259e2fbc30f6fe2331b098e9e7..cb4ea741645619d98d37f953930167f39162ab45 100644 (file)
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -265,12 +265,13 @@ builtin_types =
 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
@@ -280,7 +281,7 @@ vhdl_ty msg ty = do
       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 $ msg ++ "\nVHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
@@ -354,7 +355,7 @@ mk_vector_ty ty = do
   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 vec_ty) 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)
@@ -362,7 +363,7 @@ mk_vector_ty 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 vsTypes (Map.insert (OrdType vec_ty) (vec_id, (Left vec_def)))
+      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)
@@ -386,10 +387,49 @@ getFieldLabels ty = do
   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 $ "\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

diff --git a/VHDLTypes.hs b/VHDLTypes.hs
index 61fb0035650002fa61c95db39bb6c56429114bfb..4a1b01719300f0cc9dab8de620a19ed18b2dc21f 100644 (file)
--- a/VHDLTypes.hs
+++ b/VHDLTypes.hs
@@ -38,8 +38,14 @@ instance Eq OrdType where
 instance Ord OrdType where
   compare (OrdType a) (OrdType b) = Type.tcCmpType a b
 
+data HType = StdType OrdType |
+             ADTType String [HType] |
+             VecType Int HType |
+             BuiltinType String
+  deriving (Eq, Ord)
+
 -- A map of a Core type to the corresponding type name
-type TypeMap = Map.Map OrdType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
+type TypeMap = Map.Map HType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
 
 -- A map of a vector Core element type and function name to the coressponding
 -- VHDLId of the function and the function body.