-- Standard modules
import qualified Maybe
+import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
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
AST.CSSASm assign
mkAssocElems ::
- [CoreSyn.CoreExpr] -- | The argument that are applied to function
- -> CoreSyn.CoreBndr -- | The binder in which to store the result
+ [AST.Expr] -- | The argument that are applied to function
+ -> AST.VHDLName -- | The binder in which to store the result
-> Entity -- | The entity to map against.
-> [AST.AssocElem] -- | The resulting port maps
mkAssocElems args res entity =
-- Create the actual AssocElems
- Maybe.catMaybes $ zipWith mkAssocElem ports sigs
+ zipWith mkAssocElem ports sigs
where
-- Turn the ports and signals from a map into a flat list. This works,
-- since the maps must have an identical form by definition. TODO: Check
arg_ports = ent_args entity
res_port = ent_res entity
-- Extract the id part from the (id, type) tuple
- ports = map (Monad.liftM fst) (res_port : arg_ports)
+ ports = map fst (res_port : arg_ports)
-- Translate signal numbers into names
- sigs = (varToString res : map (varToString.exprToVar) args)
+ sigs = (vhdlNameToVHDLExpr res : args)
-- | Create an VHDL port -> signal association
-mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
-mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
-mkAssocElem Nothing _ = Nothing
+mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
+mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal)
-- | Create an VHDL port -> signal association
-mkAssocElemIndexed :: Maybe AST.VHDLId -> String -> AST.VHDLId -> Maybe AST.AssocElem
-mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
- (AST.NSimple (mkVHDLExtId signal)) [AST.PrimName $ AST.NSimple index])))
-mkAssocElemIndexed Nothing _ _ = Nothing
+mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
+mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName
+ (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
mkComponentInst ::
String -- ^ The portmap label
-> AST.ConcSm
mkComponentInst label entity_id portassigns = AST.CSISm compins
where
- compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portassigns)
+ -- We always have a clock port, so no need to map it anywhere but here
+ clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
+ compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
-----------------------------------------------------------------------------
-- Functions to generate VHDL Exprs
-- 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
+
+-- Turn a VHDL Id into an AST expression
+idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
+
+-- Turn a Core expression into an AST expression
+exprToVHDLExpr = varToVHDLExpr . exprToVar
-- Turn a alternative constructor into an AST expression. For
-- dataconstructors, this is only the constructor itself, not any arguments it
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
varToVHDLId ::
CoreSyn.CoreBndr
-> AST.VHDLId
-varToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
+varToVHDLId = mkVHDLExtId . varToString
+
+-- Creates a VHDL Name from a binder
+varToVHDLName ::
+ CoreSyn.CoreBndr
+ -> AST.VHDLName
+varToVHDLName = AST.NSimple . varToVHDLId
-- Extracts the binder name as a String
varToString ::
-- Create a record field selector that selects the given label from the record
-- stored in the given binder.
-mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
-mkSelectedName bndr label =
- let
- sel_prefix = AST.NSimple $ varToVHDLId bndr
- sel_suffix = AST.SSimple $ label
- in
- AST.NSelected $ sel_prefix AST.:.: sel_suffix
+mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
+mkSelectedName name label =
+ AST.NSelected $ name AST.:.: (AST.SSimple label)
+
+-- Create an indexed name that selects a given element from a vector.
+mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
+-- Special case for already indexed names. Just add an index
+mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
+ AST.NIndexed (AST.IndexedName name (indexes++[index]))
+-- General case for other names
+mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
-----------------------------------------------------------------------------
-- Functions dealing with VHDL types
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 -> VHDLState AST.TypeMark
-vhdl_ty ty = do
+-- Returns an error value, using the given message, when no type could be
+-- created.
+vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
+vhdl_ty msg ty = do
+ tm_either <- vhdl_ty_either ty
+ case tm_either of
+ Right tm -> return tm
+ Left err -> error $ msg ++ "\n" ++ err
+
+-- Translate a Haskell type to a VHDL type, generating a new type if needed.
+-- Returns either an error message or the resulting type.
+vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
+vhdl_ty_either ty = do
typemap <- getA vsTypes
- 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
- 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)
- case newty_maybe of
- Just (ty_id, ty_def) -> do
- -- TODO: Check name uniqueness
- modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
- return ty_id
- Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
-
--- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ htype_either <- mkHType ty
+ case htype_either of
+ -- No errors
+ Right htype -> do
+ 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 htype typemap
+ case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+ -- Found a type, return it
+ Just t -> return (Right t)
+ -- No type yet, try to construct it
+ Nothing -> do
+ newty_maybe <- (construct_vhdl_ty ty)
+ case newty_maybe of
+ Right (ty_id, ty_def) -> do
+ -- TODO: Check name uniqueness
+ modA vsTypes (Map.insert htype (ty_id, ty_def))
+ modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)])
+ return (Right ty_id)
+ Left err -> return $ Left $
+ "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
+ ++ err
+ -- Error when constructing htype
+ Left err -> return $ Left err
+
+-- Construct a new VHDL type for the given Haskell type. Returns an error
+-- message or the resulting typemark and typedef.
+construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
construct_vhdl_ty 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)
- return $ Just $ (Arrow.second Right) res
- -- "SizedWord" -> do
- -- res <- mk_vector_ty (sized_word_len ty) ty
- -- return $ Just $ (Arrow.second Left) res
- "RangedWord" -> do
- res <- mk_natural_ty 0 (ranged_word_bound ty)
- return $ Just $ (Arrow.second Right) res
+ "TFVec" -> mk_vector_ty ty
+ "SizedWord" -> mk_unsigned_ty ty
+ "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
-- Create a custom type from this tycon
otherwise -> mk_tycon_ty tycon args
- Nothing -> return $ Nothing
+ Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
-- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
mk_tycon_ty tycon args =
case TyCon.tyConDataCons tycon of
-- Not an algebraic type
- [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
+ [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
[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 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 ty_def = AST.TDR $ AST.RecordTypeDef elems
- return $ Just (ty_id, Left ty_def)
- dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon
+ elem_tys_either <- mapM vhdl_ty_either real_arg_tys
+ case Either.partitionEithers elem_tys_either of
+ -- No errors in element types
+ ([], elem_tys) -> do
+ 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 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 $ Right (ty_id, Left ty_def)
+ -- There were errors in element types
+ (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"
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
-- | Create a VHDL vector type
mk_vector_ty ::
- Int -- ^ The length of the vector
- -> Type.Type -- ^ The Haskell element type of the Vector
- -> VHDLState (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
- 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
- case existing_elem_ty of
- Just t -> do
- let ty_def = AST.SubtypeIn t (Just range)
- return (ty_id, ty_def)
- 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))
- let ty_def = AST.SubtypeIn vec_id (Just range)
- return (ty_id, ty_def)
+ Type.Type -- ^ The Haskell type of the Vector
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -- ^ An error message or The typemark created.
+
+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
+ el_ty_tm_either <- vhdl_ty_either el_ty
+ case el_ty_tm_either of
+ -- Could create element type
+ Right el_ty_tm -> do
+ 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 (StdType $ OrdType vec_ty) types_map
+ case existing_elem_ty of
+ Just t -> do
+ let ty_def = AST.SubtypeIn t (Just range)
+ return (Right (ty_id, Right ty_def))
+ 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 (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 (Right (ty_id, Right ty_def))
+ -- Could not create element type
+ Left err -> return $ Left $
+ "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
+ ++ err
mk_natural_ty ::
Int -- ^ The minimum bound (> 0)
-> Int -- ^ The maximum bound (> minimum bound)
- -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+ -- ^ An error message or The typemark created.
mk_natural_ty min_bound max_bound = do
let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
let ty_def = AST.SubtypeIn naturalTM (Just range)
- return (ty_id, ty_def)
+ return (Right (ty_id, Right ty_def))
+
+mk_unsigned_ty ::
+ Type.Type -- ^ Haskell type of the signed integer
+ -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_unsigned_ty ty = do
+ let size = sized_word_len ty
+ let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
+ let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+ let ty_def = AST.SubtypeIn signedTM (Just range)
+ return (Right (ty_id, Right ty_def))
-- Finds the field labels for VHDL type generated for the given Core type,
-- which must result in a record type.
-getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
+getFieldLabels :: Type.Type -> TypeSession [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
+ -- Assume the type for which we want labels is really translatable
+ Right 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 -> TypeSession (Either String 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 $ Right $ 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
+ let el_ty = tfvec_elem ty
+ elem_htype_either <- mkHType el_ty
+ case elem_htype_either of
+ -- Could create element type
+ Right elem_htype -> do
+ len <- vec_len ty
+ return $ Right $ VecType len elem_htype
+ -- Could not create element type
+ Left err -> return $ Left $
+ "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n"
+ ++ err
+ "SizedWord" -> return $ Right $ StdType $ OrdType ty
+ "RangedWord" -> return $ Right $ StdType $ OrdType ty
+ otherwise -> do
+ mkTyConHType tycon args
+ Nothing -> return $ Right $ StdType $ OrdType ty
+
+-- FIXME: Do we really need to do this here again?
+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"
+ [dc] -> do
+ let arg_tys = DataCon.dataConRepArgTys dc
+ let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+ elem_htys_either <- mapM mkHType real_arg_tys
+ case Either.partitionEithers elem_htys_either of
+ -- No errors in element types
+ ([], elem_htys) -> do
+ 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"
+ ++ (concat errors)
+ dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
+ where
+ tyvars = TyCon.tyConTyVars tycon
+ subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+ ty_either <- vhdl_ty_either ty
+ return $ case ty_either of
+ Left _ -> False
+ Right _ -> True
+
+vec_len :: Type.Type -> TypeSession Int
+vec_len ty = do
+ veclens <- getA vsTfpInts
+ let len_ty = tfvec_len_ty ty
+ let existing_len = Map.lookup (OrdType len_ty) veclens
+ case existing_len of
+ Just len -> return len
+ Nothing -> do
+ let new_len = tfvec_len ty
+ modA vsTfpInts (Map.insert (OrdType len_ty) (new_len))
+ return new_len
\ No newline at end of file
projects / matthijs / master-project / cλash.git / blobdiff