e4aad6f497a685c1b6d6dbd0e732bb98ac0f456c
[matthijs/master-project/cλash.git] / VHDLTools.hs
1 module VHDLTools where
2
3 -- Standard modules
4 import qualified Maybe
5 import qualified Data.Either as Either
6 import qualified Data.List as List
7 import qualified Data.Map as Map
8 import qualified Control.Monad as Monad
9 import qualified Control.Arrow as Arrow
10 import qualified Data.Monoid as Monoid
11 import Data.Accessor
12 import Debug.Trace
13
14 -- ForSyDe
15 import qualified ForSyDe.Backend.VHDL.AST as AST
16
17 -- GHC API
18 import CoreSyn
19 import qualified Name
20 import qualified OccName
21 import qualified Var
22 import qualified Id
23 import qualified TyCon
24 import qualified Type
25 import qualified DataCon
26 import qualified CoreSubst
27
28 -- Local imports
29 import VHDLTypes
30 import CoreTools
31 import Pretty
32 import Constants
33
34 -----------------------------------------------------------------------------
35 -- Functions to generate concurrent statements
36 -----------------------------------------------------------------------------
37
38 -- Create an unconditional assignment statement
39 mkUncondAssign ::
40   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
41   -> AST.Expr -- ^ The expression to assign
42   -> AST.ConcSm -- ^ The resulting concurrent statement
43 mkUncondAssign dst expr = mkAssign dst Nothing expr
44
45 -- Create a conditional assignment statement
46 mkCondAssign ::
47   Either CoreBndr AST.VHDLName -- ^ The signal to assign to
48   -> AST.Expr -- ^ The condition
49   -> AST.Expr -- ^ The value when true
50   -> AST.Expr -- ^ The value when false
51   -> AST.ConcSm -- ^ The resulting concurrent statement
52 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
53
54 -- Create a conditional or unconditional assignment statement
55 mkAssign ::
56   Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
57   Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
58                                  -- and the value to assign when true.
59   AST.Expr -> -- ^ The value to assign when false or no condition
60   AST.ConcSm -- ^ The resulting concurrent statement
61 mkAssign dst cond false_expr =
62   let
63     -- I'm not 100% how this assignment AST works, but this gets us what we
64     -- want...
65     whenelse = case cond of
66       Just (cond_expr, true_expr) -> 
67         let 
68           true_wform = AST.Wform [AST.WformElem true_expr Nothing] 
69         in
70           [AST.WhenElse true_wform cond_expr]
71       Nothing -> []
72     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
73     dst_name  = case dst of
74       Left bndr -> AST.NSimple (varToVHDLId bndr)
75       Right name -> name
76     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
77   in
78     AST.CSSASm assign
79
80 mkAssocElems :: 
81   [AST.Expr]                    -- | The argument that are applied to function
82   -> AST.VHDLName               -- | The binder in which to store the result
83   -> Entity                     -- | The entity to map against.
84   -> [AST.AssocElem]            -- | The resulting port maps
85 mkAssocElems args res entity =
86     -- Create the actual AssocElems
87     zipWith mkAssocElem ports sigs
88   where
89     -- Turn the ports and signals from a map into a flat list. This works,
90     -- since the maps must have an identical form by definition. TODO: Check
91     -- the similar form?
92     arg_ports = ent_args entity
93     res_port  = ent_res entity
94     -- Extract the id part from the (id, type) tuple
95     ports     = map fst (res_port : arg_ports)
96     -- Translate signal numbers into names
97     sigs      = (vhdlNameToVHDLExpr res : args)
98
99 -- | Create an VHDL port -> signal association
100 mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
101 mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
102
103 -- | Create an VHDL port -> signal association
104 mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
105 mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName 
106                       (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
107
108 mkComponentInst ::
109   String -- ^ The portmap label
110   -> AST.VHDLId -- ^ The entity name
111   -> [AST.AssocElem] -- ^ The port assignments
112   -> AST.ConcSm
113 mkComponentInst label entity_id portassigns = AST.CSISm compins
114   where
115     -- We always have a clock port, so no need to map it anywhere but here
116     clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
117     compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
118
119 -----------------------------------------------------------------------------
120 -- Functions to generate VHDL Exprs
121 -----------------------------------------------------------------------------
122
123 -- Turn a variable reference into a AST expression
124 varToVHDLExpr :: Var.Var -> AST.Expr
125 varToVHDLExpr var = 
126   case Id.isDataConWorkId_maybe var of
127     Just dc -> dataconToVHDLExpr dc
128     -- This is a dataconstructor.
129     -- Not a datacon, just another signal. Perhaps we should check for
130     -- local/global here as well?
131     -- Sadly so.. tfp decimals are types, not data constructors, but instances
132     -- should still be translated to integer literals. It is probebly not the
133     -- best solution to translate them here.
134     -- FIXME: Find a better solution for translating instances of tfp integers
135     Nothing -> 
136         let 
137           ty  = Var.varType var
138           res = case Type.splitTyConApp_maybe ty of
139                   Just (tycon, args) ->
140                     case Name.getOccString (TyCon.tyConName tycon) of
141                       "Dec" -> AST.PrimLit $ (show (eval_tfp_int ty))
142                       otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
143         in
144           res
145
146 -- Turn a VHDLName into an AST expression
147 vhdlNameToVHDLExpr = AST.PrimName
148
149 -- Turn a VHDL Id into an AST expression
150 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
151
152 -- Turn a Core expression into an AST expression
153 exprToVHDLExpr = varToVHDLExpr . exprToVar
154
155 -- Turn a alternative constructor into an AST expression. For
156 -- dataconstructors, this is only the constructor itself, not any arguments it
157 -- has. Should not be called with a DEFAULT constructor.
158 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
159 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
160
161 altconToVHDLExpr (LitAlt _) = error "\nVHDL.conToVHDLExpr: Literals not support in case alternatives yet"
162 altconToVHDLExpr DEFAULT = error "\nVHDL.conToVHDLExpr: DEFAULT alternative should not occur here!"
163
164 -- Turn a datacon (without arguments!) into a VHDL expression.
165 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
166 dataconToVHDLExpr dc = AST.PrimLit lit
167   where
168     tycon = DataCon.dataConTyCon dc
169     tyname = TyCon.tyConName tycon
170     dcname = DataCon.dataConName dc
171     lit = case Name.getOccString tyname of
172       -- TODO: Do something more robust than string matching
173       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
174       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
175
176 -----------------------------------------------------------------------------
177 -- Functions dealing with names, variables and ids
178 -----------------------------------------------------------------------------
179
180 -- Creates a VHDL Id from a binder
181 varToVHDLId ::
182   CoreSyn.CoreBndr
183   -> AST.VHDLId
184 varToVHDLId = mkVHDLExtId . varToString
185
186 -- Creates a VHDL Name from a binder
187 varToVHDLName ::
188   CoreSyn.CoreBndr
189   -> AST.VHDLName
190 varToVHDLName = AST.NSimple . varToVHDLId
191
192 -- Extracts the binder name as a String
193 varToString ::
194   CoreSyn.CoreBndr
195   -> String
196 varToString = OccName.occNameString . Name.nameOccName . Var.varName
197
198 -- Get the string version a Var's unique
199 varToStringUniq :: Var.Var -> String
200 varToStringUniq = show . Var.varUnique
201
202 -- Extracts the string version of the name
203 nameToString :: Name.Name -> String
204 nameToString = OccName.occNameString . Name.nameOccName
205
206 -- Shortcut for Basic VHDL Ids.
207 -- Can only contain alphanumerics and underscores. The supplied string must be
208 -- a valid basic id, otherwise an error value is returned. This function is
209 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
210 -- that.
211 mkVHDLBasicId :: String -> AST.VHDLId
212 mkVHDLBasicId s = 
213   AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
214   where
215     -- Strip invalid characters.
216     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
217     -- Strip leading numbers and underscores
218     strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
219     -- Strip multiple adjacent underscores
220     strip_multiscore = concat . map (\cs -> 
221         case cs of 
222           ('_':_) -> "_"
223           _ -> cs
224       ) . List.group
225
226 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
227 -- different characters than basic ids, but can never be used to refer to
228 -- basic ids.
229 -- Use extended Ids for any values that are taken from the source file.
230 mkVHDLExtId :: String -> AST.VHDLId
231 mkVHDLExtId s = 
232   AST.unsafeVHDLExtId $ strip_invalid s
233   where 
234     -- Allowed characters, taken from ForSyde's mkVHDLExtId
235     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
236     strip_invalid = filter (`elem` allowed)
237
238 -- Create a record field selector that selects the given label from the record
239 -- stored in the given binder.
240 mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
241 mkSelectedName name label =
242    AST.NSelected $ name AST.:.: (AST.SSimple label) 
243
244 -- Create an indexed name that selects a given element from a vector.
245 mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
246 -- Special case for already indexed names. Just add an index
247 mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
248  AST.NIndexed (AST.IndexedName name (indexes++[index]))
249 -- General case for other names
250 mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
251
252 -----------------------------------------------------------------------------
253 -- Functions dealing with VHDL types
254 -----------------------------------------------------------------------------
255
256 -- | Maps the string name (OccName) of a type to the corresponding VHDL type,
257 -- for a few builtin types.
258 builtin_types = 
259   Map.fromList [
260     ("Bit", std_logicTM),
261     ("Bool", booleanTM), -- TysWiredIn.boolTy
262     ("Dec", integerTM)
263   ]
264
265 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
266 -- Returns an error value, using the given message, when no type could be
267 -- created.
268 vhdl_ty :: String -> Type.Type -> TypeSession AST.TypeMark
269 vhdl_ty msg ty = do
270   tm_either <- vhdl_ty_either ty
271   case tm_either of
272     Right tm -> return tm
273     Left err -> error $ msg ++ "\n" ++ err
274
275 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
276 -- Returns either an error message or the resulting type.
277 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
278 vhdl_ty_either ty = do
279   typemap <- getA vsTypes
280   htype_either <- mkHType ty
281   case htype_either of
282     -- No errors
283     Right htype -> do
284       let builtin_ty = do -- See if this is a tycon and lookup its name
285             (tycon, args) <- Type.splitTyConApp_maybe ty
286             let name = Name.getOccString (TyCon.tyConName tycon)
287             Map.lookup name builtin_types
288       -- If not a builtin type, try the custom types
289       let existing_ty = (fmap fst) $ Map.lookup htype typemap
290       case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
291         -- Found a type, return it
292         Just t -> return (Right t)
293         -- No type yet, try to construct it
294         Nothing -> do
295           newty_maybe <- (construct_vhdl_ty ty)
296           case newty_maybe of
297             Right (ty_id, ty_def) -> do
298               -- TODO: Check name uniqueness
299               modA vsTypes (Map.insert htype (ty_id, ty_def))
300               modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
301               return (Right ty_id)
302             Left err -> return $ Left $
303               "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
304               ++ err
305     -- Error when constructing htype
306     Left err -> return $ Left err 
307
308 -- Construct a new VHDL type for the given Haskell type. Returns an error
309 -- message or the resulting typemark and typedef.
310 construct_vhdl_ty :: Type.Type -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
311 construct_vhdl_ty ty = do
312   case Type.splitTyConApp_maybe ty of
313     Just (tycon, args) -> do
314       let name = Name.getOccString (TyCon.tyConName tycon)
315       case name of
316         "TFVec" -> mk_vector_ty ty
317         -- "SizedWord" -> do
318         --   res <- mk_vector_ty (sized_word_len ty) ty
319         --   return $ Just $ (Arrow.second Left) res
320         "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
321         -- Create a custom type from this tycon
322         otherwise -> mk_tycon_ty tycon args
323     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
324
325 -- | Create VHDL type for a custom tycon
326 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
327 mk_tycon_ty tycon args =
328   case TyCon.tyConDataCons tycon of
329     -- Not an algebraic type
330     [] -> return (Left $ "VHDLTools.mk_tycon_ty: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n")
331     [dc] -> do
332       let arg_tys = DataCon.dataConRepArgTys dc
333       -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
334       -- violation? Or does it only mean not to apply it again to the same
335       -- subject?
336       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
337       elem_tys_either <- mapM vhdl_ty_either real_arg_tys
338       case Either.partitionEithers elem_tys_either of
339         -- No errors in element types
340         ([], elem_tys) -> do
341           let elems = zipWith AST.ElementDec recordlabels elem_tys
342           -- For a single construct datatype, build a record with one field for
343           -- each argument.
344           -- TODO: Add argument type ids to this, to ensure uniqueness
345           -- TODO: Special handling for tuples?
346           let elem_names = concat $ map prettyShow elem_tys
347           let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
348           let ty_def = AST.TDR $ AST.RecordTypeDef elems
349           return $ Right (ty_id, Left ty_def)
350         -- There were errors in element types
351         (errors, _) -> return $ Left $
352           "VHDLTools.mk_tycon_ty: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
353           ++ (concat errors)
354     dcs -> return $ Left $ "VHDLTools.mk_tycon_ty: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
355   where
356     -- Create a subst that instantiates all types passed to the tycon
357     -- TODO: I'm not 100% sure that this is the right way to do this. It seems
358     -- to work so far, though..
359     tyvars = TyCon.tyConTyVars tycon
360     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
361     -- Generate a bunch of labels for fields of a record
362     recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
363
364 -- | Create a VHDL vector type
365 mk_vector_ty ::
366   Type.Type -- ^ The Haskell type of the Vector
367   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
368       -- ^ An error message or The typemark created.
369
370 mk_vector_ty ty = do
371   types_map <- getA vsTypes
372   let (nvec_l, nvec_el) = Type.splitAppTy ty
373   let (nvec, leng) = Type.splitAppTy nvec_l
374   let vec_ty = Type.mkAppTy nvec nvec_el
375   let len = tfvec_len ty
376   let el_ty = tfvec_elem ty
377   el_ty_tm_either <- vhdl_ty_either el_ty
378   case el_ty_tm_either of
379     -- Could create element type
380     Right el_ty_tm -> do
381       let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
382       let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
383       let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map
384       case existing_elem_ty of
385         Just t -> do
386           let ty_def = AST.SubtypeIn t (Just range)
387           return (Right (ty_id, Right ty_def))
388         Nothing -> do
389           let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
390           let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
391           modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def)))
392           modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) 
393           let ty_def = AST.SubtypeIn vec_id (Just range)
394           return (Right (ty_id, Right ty_def))
395     -- Could not create element type
396     Left err -> return $ Left $ 
397       "VHDLTools.mk_vector_ty: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
398       ++ err
399
400 mk_natural_ty ::
401   Int -- ^ The minimum bound (> 0)
402   -> Int -- ^ The maximum bound (> minimum bound)
403   -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
404       -- ^ An error message or The typemark created.
405 mk_natural_ty min_bound max_bound = do
406   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
407   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
408   let ty_def = AST.SubtypeIn naturalTM (Just range)
409   return (Right (ty_id, Right ty_def))
410
411 -- Finds the field labels for VHDL type generated for the given Core type,
412 -- which must result in a record type.
413 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
414 getFieldLabels ty = do
415   -- Ensure that the type is generated (but throw away it's VHDLId)
416   let error_msg = "\nVHDLTools.getFieldLabels: Can not get field labels, because: " ++ pprString ty ++ "can not be generated." 
417   vhdl_ty error_msg ty
418   -- Get the types map, lookup and unpack the VHDL TypeDef
419   types <- getA vsTypes
420   -- Assume the type for which we want labels is really translatable
421   Right htype <- mkHType ty
422   case Map.lookup htype types of
423     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
424     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
425     
426 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
427 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
428 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
429
430 mkHType :: Type.Type -> TypeSession (Either String HType)
431 mkHType ty = do
432   -- FIXME: Do we really need to do this here again?
433   let builtin_ty = do -- See if this is a tycon and lookup its name
434         (tycon, args) <- Type.splitTyConApp_maybe ty
435         let name = Name.getOccString (TyCon.tyConName tycon)
436         Map.lookup name builtin_types
437   case builtin_ty of
438     Just typ -> 
439       return $ Right $ BuiltinType $ prettyShow typ
440     Nothing ->
441       case Type.splitTyConApp_maybe ty of
442         Just (tycon, args) -> do
443           let name = Name.getOccString (TyCon.tyConName tycon)
444           case name of
445             "TFVec" -> do
446               let el_ty = tfvec_elem ty
447               elem_htype_either <- mkHType el_ty
448               case elem_htype_either of
449                 -- Could create element type
450                 Right elem_htype -> do
451                   len <- vec_len ty
452                   return $ Right $ VecType len elem_htype
453                 -- Could not create element type
454                 Left err -> return $ Left $ 
455                   "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
456                   ++ err
457             otherwise -> do
458               mkTyConHType tycon args
459         Nothing -> return $ Right $ StdType $ OrdType ty
460
461 -- FIXME: Do we really need to do this here again?
462 mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)
463 mkTyConHType tycon args =
464   case TyCon.tyConDataCons tycon of
465     -- Not an algebraic type
466     [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"
467     [dc] -> do
468       let arg_tys = DataCon.dataConRepArgTys dc
469       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
470       elem_htys_either <- mapM mkHType real_arg_tys
471       case Either.partitionEithers elem_htys_either of
472         -- No errors in element types
473         ([], elem_htys) -> do
474           return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
475         -- There were errors in element types
476         (errors, _) -> return $ Left $
477           "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
478           ++ (concat errors)
479     dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"
480   where
481     tyvars = TyCon.tyConTyVars tycon
482     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
483
484 -- Is the given type representable at runtime?
485 isReprType :: Type.Type -> TypeSession Bool
486 isReprType ty = do
487   ty_either <- vhdl_ty_either ty
488   return $ case ty_either of
489     Left _ -> False
490     Right _ -> True
491
492 vec_len :: Type.Type -> TypeSession Int
493 vec_len ty = do
494   veclens <- getA vsTfpInts
495   let len_ty = tfvec_len_ty ty
496   let existing_len = Map.lookup (OrdType len_ty) veclens
497   case existing_len of
498     Just len -> return len
499     Nothing -> do
500       let new_len = tfvec_len ty
501       modA vsTfpInts (Map.insert (OrdType len_ty) (new_len))
502       return new_len