Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project
[matthijs/master-project/cλash.git] / VHDL.hs
diff --git a/VHDL.hs b/VHDL.hs
index 76102315a4a186208f20dcd6543d20c8c323be16..ecf6406f95e3f3f621b835d74497eb4feb5b2110 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -27,8 +27,13 @@ import qualified Type
 import qualified Name
 import qualified OccName
 import qualified Var
+import qualified Id
+import qualified IdInfo
 import qualified TyCon
+import qualified TcType
 import qualified DataCon
+import qualified CoreSubst
+import qualified CoreUtils
 import Outputable ( showSDoc, ppr )
 
 -- Local imports
@@ -39,20 +44,25 @@ import TranslatorTypes
 import HsValueMap
 import Pretty
 import CoreTools
+import Constants
+import Generate
+import GlobalNameTable
 
 createDesignFiles ::
   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
   -> [(AST.VHDLId, AST.DesignFile)]
 
 createDesignFiles binds =
-  (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
+  (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
-    init_session = VHDLSession Map.empty builtin_funcs
+    init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
-    ty_decls = Map.elems (final_session ^. vsTypes)
+    tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
+    ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
+    vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
     ieee_context = [
         AST.Library $ mkVHDLBasicId "IEEE",
         mkUseAll ["IEEE", "std_logic_1164"],
@@ -61,7 +71,13 @@ createDesignFiles binds =
     full_context =
       mkUseAll ["work", "types"]
       : ieee_context
-    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
+    type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (vec_decls ++ ty_decls ++ subProgSpecs)
+    type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
+    subProgSpecs = concat (map subProgSpec tyfun_decls)
+    subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
+    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
 
 -- Create a use foo.bar.all statement. Takes a list of components in the used
 -- name. Must contain at least two components
@@ -99,18 +115,19 @@ createEntity (fname, expr) = do
       -- There must be a let at top level 
       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
       res' <- mkMap res
-      let ent_decl' = createEntityAST fname args' res'
+      let vhdl_id = mkVHDLBasicId $ bndrToString fname ++ "_" ++ varToStringUniq fname
+      let ent_decl' = createEntityAST vhdl_id args' res'
       let AST.EntityDec entity_id _ = ent_decl' 
       let signature = Entity entity_id args' res'
-      modA vsSignatures (Map.insert (bndrToString fname) signature)
+      modA vsSignatures (Map.insert fname signature)
       return ent_decl'
   where
-    mkMap :: 
+    mkMap ::
       --[(SignalId, SignalInfo)] 
       CoreSyn.CoreBndr 
       -> VHDLState VHDLSignalMapElement
     -- We only need the vsTypes element from the state
-    mkMap = MonadState.lift vsTypes . (\bndr ->
+    mkMap = (\bndr ->
       let
         --info = Maybe.fromMaybe
         --  (error $ "Signal not found in the name map? This should not happen!")
@@ -129,16 +146,15 @@ createEntity (fname, expr) = do
 
   -- | Create the VHDL AST for an entity
 createEntityAST ::
-  CoreSyn.CoreBndr             -- | The name of the function
+  AST.VHDLId                   -- | The name of the function
   -> [VHDLSignalMapElement]    -- | The entity's arguments
   -> VHDLSignalMapElement      -- | The entity's result
   -> AST.EntityDec             -- | The entity with the ent_decl filled in as well
 
-createEntityAST name args res =
+createEntityAST vhdl_id args res =
   AST.EntityDec vhdl_id ports
   where
     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
-    vhdl_id = mkVHDLBasicId $ bndrToString name
     ports = Maybe.catMaybes $ 
               map (mkIfaceSigDec AST.In) args
               ++ [mkIfaceSigDec AST.Out res]
@@ -172,11 +188,11 @@ createArchitecture ::
   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 
 createArchitecture (fname, expr) = do
-  --signaturemap <- getA vsSignatures
-  --let signature = Maybe.fromMaybe 
-  --      (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
-  --      (Map.lookup hsfunc signaturemap)
-  let entity_id = mkVHDLBasicId $ bndrToString fname
+  signaturemap <- getA vsSignatures
+  let signature = Maybe.fromMaybe 
+        (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
+        (Map.lookup fname signaturemap)
+  let entity_id = ent_id signature
   -- Strip off lambda's, these will be arguments
   let (args, letexpr) = CoreSyn.collectBinders expr
   -- There must be a let at top level 
@@ -192,7 +208,7 @@ createArchitecture (fname, expr) = do
     procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
     procs' = map AST.CSPSm procs
     -- mkSigDec only uses vsTypes from the state
-    mkSigDec' = MonadState.lift vsTypes . mkSigDec
+    mkSigDec' = mkSigDec
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
@@ -221,7 +237,7 @@ mkStateProcSm (num, old, new) =
     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 
-mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec)
+mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
 mkSigDec bndr =
   if True then do --isInternalSigUse use || isStateSigUse use then do
     type_mark <- vhdl_ty $ Var.varType bndr
@@ -243,28 +259,87 @@ mkConcSm ::
   -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
-  signatures <- getA vsSignatures
-  let 
-      (CoreSyn.Var f, args) = CoreSyn.collectArgs app
-      signature = Maybe.fromMaybe
-          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
-          (Map.lookup (bndrToString f) signatures)
-      entity_id = ent_id signature
-      label = bndrToString bndr
-      -- Add a clk port if we have state
-      --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
-      --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
-      portmaps = mkAssocElems args bndr signature
-    in
-      return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+  let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+  let valargs' = filter isValArg args
+  let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
+  case Var.globalIdVarDetails f of
+    IdInfo.DataConWorkId dc ->
+        -- It's a datacon. Create a record from its arguments.
+        -- First, filter out type args. TODO: Is this the best way to do this?
+        -- The types should already have been taken into acocunt when creating
+        -- the signal, so this should probably work...
+        --let valargs = filter isValArg args in
+        if all is_var valargs then do
+          labels <- getFieldLabels (CoreUtils.exprType app)
+          let assigns = zipWith mkassign labels valargs
+          let block_id = bndrToVHDLId bndr
+          let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns
+          return $ AST.CSBSm block
+        else
+          error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
+      where
+        mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
+        mkassign label (Var arg) =
+          let sel_name = mkSelectedName bndr label in
+          mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
+    IdInfo.VanillaGlobal -> do
+      -- It's a global value imported from elsewhere. These can be builtin
+      -- functions.
+      funSignatures <- getA vsNameTable
+      case (Map.lookup (bndrToString f) funSignatures) of
+        Just (arg_count, builder) ->
+          if length valargs == arg_count then
+            let
+              sigs = map (bndrToString.varBndr) valargs
+              sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+              func = builder sigsNames
+              src_wform = AST.Wform [AST.WformElem func Nothing]
+              dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+              assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+            in
+              return $ AST.CSSASm assign
+          else
+            error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
+        Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
+    IdInfo.NotGlobalId -> do
+      signatures <- getA vsSignatures
+      -- This is a local id, so it should be a function whose definition we
+      -- have and which can be turned into a component instantiation.
+      let  
+        signature = Maybe.fromMaybe 
+          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 
+          (Map.lookup f signatures)
+        entity_id = ent_id signature
+        label = bndrToString bndr
+        -- Add a clk port if we have state
+        --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+        --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+        portmaps = mkAssocElems args bndr signature
+        in
+          return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+    details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 
 -- GHC generates some funny "r = r" bindings in let statements before
 -- simplification. This outputs some dummy ConcSM for these, so things will at
 -- least compile for now.
 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
 
--- A single alt case must be a selector
-mkConcSm (bndr, (Case (Var scrut) b ty [alt])) = error "Single case alt not supported yet"
+-- A single alt case must be a selector. This means thee scrutinee is a simple
+-- variable, the alternative is a dataalt with a single non-wild binder that
+-- is also returned.
+mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
+  case alt of
+    (DataAlt dc, bndrs, (Var sel_bndr)) -> do
+      case List.elemIndex sel_bndr bndrs of
+        Just i -> do
+          labels <- getFieldLabels (Id.idType scrut)
+          let label = labels!!i
+          let sel_name = mkSelectedName scrut label
+          let sel_expr = AST.PrimName sel_name
+          return $ mkUncondAssign (Left bndr) sel_expr
+        Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
+      
+    _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
 
 -- Multiple case alt are be conditional assignments and have only wild
 -- binders in the alts and only variables in the case values and a variable
@@ -275,15 +350,76 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)]))
     cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
     true_expr  = (varToVHDLExpr true)
     false_expr  = (varToVHDLExpr false)
-    false_wform = AST.Wform [AST.WformElem false_expr Nothing]
-    true_wform = AST.Wform [AST.WformElem true_expr Nothing]
-    whenelse = AST.WhenElse true_wform cond_expr
-    dst_name  = AST.NSimple (bndrToVHDLId bndr)
-    assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
   in
-    return $ AST.CSSASm assign
+    return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
+
+-- Create an unconditional assignment statement
+mkUncondAssign ::
+  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+  -> AST.Expr -- ^ The expression to assign
+  -> AST.ConcSm -- ^ The resulting concurrent statement
+mkUncondAssign dst expr = mkAssign dst Nothing expr
+
+-- Create a conditional assignment statement
+mkCondAssign ::
+  Either CoreBndr AST.VHDLName -- ^ The signal to assign to
+  -> AST.Expr -- ^ The condition
+  -> AST.Expr -- ^ The value when true
+  -> AST.Expr -- ^ The value when false
+  -> AST.ConcSm -- ^ The resulting concurrent statement
+mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
+
+-- Create a conditional or unconditional assignment statement
+mkAssign ::
+  Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
+  Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
+                                 -- and the value to assign when true.
+  AST.Expr -> -- ^ The value to assign when false or no condition
+  AST.ConcSm -- ^ The resulting concurrent statement
+
+mkAssign dst cond false_expr =
+  let
+    -- I'm not 100% how this assignment AST works, but this gets us what we
+    -- want...
+    whenelse = case cond of
+      Just (cond_expr, true_expr) -> 
+        let 
+          true_wform = AST.Wform [AST.WformElem true_expr Nothing] 
+        in
+          [AST.WhenElse true_wform cond_expr]
+      Nothing -> []
+    false_wform = AST.Wform [AST.WformElem false_expr Nothing]
+    dst_name  = case dst of
+      Left bndr -> AST.NSimple (bndrToVHDLId bndr)
+      Right name -> name
+    assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
+  in
+    AST.CSSASm assign
+
+-- 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 $ bndrToVHDLId bndr
+    sel_suffix = AST.SSimple $ label
+  in
+    AST.NSelected $ sel_prefix AST.:.: sel_suffix 
+
+-- 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 ty = do
+  -- Ensure that the type is generated (but throw away it's VHDLId)
+  vhdl_ty ty
+  -- Get the types map, lookup and unpack the VHDL TypeDef
+  types <- getA vsTypes
+  case Map.lookup (OrdType ty) 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)
 
 -- Turn a variable reference into a AST expression
 varToVHDLExpr :: Var.Var -> AST.Expr
@@ -326,7 +462,7 @@ mkConcSm sigs (UncondDef src dst) _ = do
           -- Create a cast expression, which is just a function call using the
           -- type name as the function name.
           let litexpr = AST.PrimLit lit
-          ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
+          ty_id <- vhdl_ty ty
           let ty_name = AST.NSimple ty_id
           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] 
           return $ AST.PrimFCall $ AST.FCall ty_name args
@@ -406,9 +542,9 @@ std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> TypeState AST.TypeMark
+vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
 vhdl_ty ty = do
-  typemap <- State.get
+  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)
@@ -420,35 +556,97 @@ vhdl_ty ty = do
     Just t -> return t
     -- No type yet, try to construct it
     Nothing -> do
-      let new_ty = do
-            -- Use the Maybe Monad for failing when one of these fails
-            (tycon, args) <- Type.splitTyConApp_maybe ty
-            let name = Name.getOccString (TyCon.tyConName tycon)
-            case name of
-              "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
-              "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
-              otherwise -> Nothing
-      -- Return new_ty when a new type was successfully created
-      Maybe.fromMaybe 
-        (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
-        new_ty
+      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: " ++ (showSDoc $ ppr 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))
+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) 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) ty
+          return $ Just $ (Arrow.second Right) res
+        -- Create a custom type from this tycon
+        otherwise -> mk_tycon_ty tycon args
+    Nothing -> return $ Nothing
+
+-- | 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 args =
+  case TyCon.tyConDataCons tycon of
+    -- Not an algebraic type
+    [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr 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 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: " ++  (showSDoc $ ppr 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
+    -- to work so far, though..
+    tyvars = TyCon.tyConTyVars tycon
+    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars 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 to create a VHDL type for
-  -> TypeState AST.TypeMark -- The typemark created.
+  -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 
-mk_vector_ty len ty = do
-  -- Assume there is a single type argument
-  let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
-  -- TODO: Use el_ty
+mk_vector_ty len el_ty 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.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
-  let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
-  let ty_dec = AST.TypeDec ty_id ty_def
-  -- TODO: Check name uniqueness
-  State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
-  return ty_id
+  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 [naturalTM] el_ty_tm
+      modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
+      modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns el_ty_tm vec_id)) 
+      let ty_def = AST.SubtypeIn vec_id (Just range)
+      return (ty_id, ty_def)
+
+mk_natural_ty ::
+  Int -- ^ The minimum bound (> 0)
+  -> Int -- ^ The maximum bound (> minimum bound)
+  -> Type.Type -- ^ The Haskell type to create a VHDL type for
+  -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+mk_natural_ty min_bound max_bound ty = do
+  let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
+  let ty_def = AST.SubtypeIn naturalTM (Nothing)
+  return (ty_id, ty_def)
 
 
 builtin_types = 
@@ -500,30 +698,16 @@ bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varN
 bndrToString ::
   CoreSyn.CoreBndr
   -> String
-
 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
 
--- | A consise representation of a (set of) ports on a builtin function
---type PortMap = HsValueMap (String, AST.TypeMark)
--- | A consise representation of a builtin function
-data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
-
--- | Translate a list of concise representation of builtin functions to a
---   SignatureMap
-mkBuiltins :: [BuiltIn] -> SignatureMap
-mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
-    (name,
-     Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
-  )
-
-builtin_hsfuncs = Map.keys builtin_funcs
-builtin_funcs = mkBuiltins
-  [ 
-    BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
-    BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
-    BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
-    BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
-  ]
+-- Get the string version a Var's unique
+varToStringUniq = show . Var.varUnique
+
+-- Extracts the string version of the name
+nameToString :: Name.Name -> String
+nameToString = OccName.occNameString . Name.nameOccName
+
+recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
 
 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 --   a VHDLSignalMap