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 ccd1d464645f76f2f7f171232546c017e939fed0..8eb130fad8e0d11e016e3222e011f55b36977e05 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -3,6 +3,7 @@
 --
 module VHDL where
 
 --
 module VHDL where
 

+-- Standard modules

 import qualified Data.Foldable as Foldable
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Data.Foldable as Foldable
 import qualified Data.List as List
 import qualified Data.Map as Map


@@ -13,51 +14,75 @@ import qualified Control.Monad.Trans.State as State
 import qualified Data.Traversable as Traversable
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import qualified Data.Traversable as Traversable
 import qualified Data.Monoid as Monoid
 import Data.Accessor

+import qualified Data.Accessor.MonadState as MonadState
+import Text.Regex.Posix
+import Debug.Trace

 
 

+-- ForSyDe
+import qualified ForSyDe.Backend.VHDL.AST as AST
+
+-- GHC API
+import CoreSyn

 import qualified Type
 import qualified Type

-import qualified TysWiredIn

 import qualified Name
 import qualified Name

+import qualified OccName
+import qualified Var

 import qualified TyCon
 import qualified TyCon

+import qualified DataCon

 import Outputable ( showSDoc, ppr )
 
 import Outputable ( showSDoc, ppr )
 

-import qualified ForSyDe.Backend.VHDL.AST as AST
-
+-- Local imports

 import VHDLTypes
 import Flatten
 import FlattenTypes
 import TranslatorTypes
 import HsValueMap
 import Pretty
 import VHDLTypes
 import Flatten
 import FlattenTypes
 import TranslatorTypes
 import HsValueMap
 import Pretty

+import CoreTools
+import Constants
+import Generate
+import GlobalNameTable

 
 createDesignFiles ::
 
 createDesignFiles ::

-  FlatFuncMap
+  [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]

   -> [(AST.VHDLId, AST.DesignFile)]
 
   -> [(AST.VHDLId, AST.DesignFile)]
 

-createDesignFiles flatfuncmap =
-  -- TODO: Output types
-  (mkVHDLId "types", AST.DesignFile [] [type_package]) :
-  map (Arrow.second $ AST.DesignFile context) units
+createDesignFiles binds =
+  (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
+  map (Arrow.second $ AST.DesignFile full_context) units

   
   where
   
   where

-    init_session = VHDLSession Map.empty builtin_funcs
+    init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable

     (units, final_session) = 
     (units, final_session) = 

-      State.runState (createLibraryUnits flatfuncmap) init_session
+      State.runState (createLibraryUnits binds) init_session

     ty_decls = Map.elems (final_session ^. vsTypes)
     ty_decls = Map.elems (final_session ^. vsTypes)

-    context = [
-      AST.Library $ mkVHDLId "IEEE",
-      AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All,
-      AST.Use $ (AST.NSimple $ mkVHDLId "work.types") AST.:.: AST.All]
-    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLId "types") (map (AST.PDITD . snd) ty_decls)
-
+    ieee_context = [
+        AST.Library $ mkVHDLBasicId "IEEE",
+        mkUseAll ["IEEE", "std_logic_1164"],
+        mkUseAll ["IEEE", "numeric_std"]
+      ]
+    full_context =
+      mkUseAll ["work", "types"]
+      : ieee_context
+    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
+
+-- Create a use foo.bar.all statement. Takes a list of components in the used
+-- name. Must contain at least two components
+mkUseAll :: [String] -> AST.ContextItem
+mkUseAll ss = 
+  AST.Use $ from AST.:.: AST.All
+  where
+    base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
+    from = foldl select base_prefix (tail ss)
+    select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
+      

 createLibraryUnits ::
 createLibraryUnits ::

-  FlatFuncMap
+  [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]

   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
 
   -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
 

-createLibraryUnits flatfuncmap = do
-  let hsfuncs = Map.keys flatfuncmap
-  let flatfuncs = Map.elems flatfuncmap
-  entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
-  archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
+createLibraryUnits binds = do
+  entities <- Monad.mapM createEntity binds
+  archs <- Monad.mapM createArchitecture binds

   return $ zipWith 
     (\ent arch -> 
       let AST.EntityDec id _ = ent in 
   return $ zipWith 
     (\ent arch -> 
       let AST.EntityDec id _ = ent in 


@@ -67,68 +92,66 @@ createLibraryUnits flatfuncmap = do
 
 -- | Create an entity for a given function
 createEntity ::
 
 -- | Create an entity for a given function
 createEntity ::

-  HsFunction -- | The function signature
-  -> FlatFunction -- | The FlatFunction
+  (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function

   -> VHDLState AST.EntityDec -- | The resulting entity
 
   -> VHDLState AST.EntityDec -- | The resulting entity
 

-createEntity hsfunc flatfunc = 
-      let 
-        sigs    = flat_sigs flatfunc
-        args    = flat_args flatfunc
-        res     = flat_res  flatfunc
-        (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
-        (ty_decls', res') = Traversable.traverse (mkMap sigs) res
-        -- TODO: Unique ty_decls
-        ent_decl' = createEntityAST hsfunc args' res'
-        AST.EntityDec entity_id _ = ent_decl' 
-        signature = Entity entity_id args' res'
-      in do
-        modA vsSignatures (Map.insert hsfunc signature)
-        return ent_decl'
+createEntity (fname, expr) = do
+      -- Strip off lambda's, these will be arguments
+      let (args, letexpr) = CoreSyn.collectBinders expr
+      args' <- Monad.mapM mkMap args
+      -- 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 AST.EntityDec entity_id _ = ent_decl' 
+      let signature = Entity entity_id args' res'
+      modA vsSignatures (Map.insert (bndrToString fname) signature)
+      return ent_decl'

   where
     mkMap :: 
   where
     mkMap :: 

-      [(SignalId, SignalInfo)] 
-      -> SignalId 
-      -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
-    mkMap sigmap id =
-      if isPortSigUse $ sigUse info
-        then
-          let (decs, type_mark) = vhdl_ty ty in
-          (decs, Just (mkVHDLId nm, type_mark))
-        else
-          (Monoid.mempty, Nothing)
-      where
-        info = Maybe.fromMaybe
-          (error $ "Signal not found in the name map? This should not happen!")
-          (lookup id sigmap)
-        nm = Maybe.fromMaybe
-          (error $ "Signal not named? This should not happen!")
-          (sigName info)
-        ty = sigTy info
+      --[(SignalId, SignalInfo)] 
+      CoreSyn.CoreBndr 
+      -> VHDLState VHDLSignalMapElement
+    -- We only need the vsTypes element from the state
+    mkMap = (\bndr ->
+      let
+        --info = Maybe.fromMaybe
+        --  (error $ "Signal not found in the name map? This should not happen!")
+        --  (lookup id sigmap)
+        --  Assume the bndr has a valid VHDL id already
+        id = bndrToVHDLId bndr
+        ty = Var.varType bndr
+      in
+        if True -- isPortSigUse $ sigUse info
+          then do
+            type_mark <- vhdl_ty ty
+            return $ Just (id, type_mark)
+          else
+            return $ Nothing
+       )

 
   -- | Create the VHDL AST for an entity
 createEntityAST ::
 
   -- | Create the VHDL AST for an entity
 createEntityAST ::

-  HsFunction            -- | The signature of the function we're working with
-  -> [VHDLSignalMap]    -- | The entity's arguments
-  -> VHDLSignalMap      -- | The entity's result
-  -> AST.EntityDec      -- | The entity with the ent_decl filled in as well
+  CoreSyn.CoreBndr             -- | 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 hsfunc args res =
+createEntityAST name args res =

   AST.EntityDec vhdl_id ports
   where
   AST.EntityDec vhdl_id ports
   where

-    vhdl_id = mkEntityId hsfunc
-    ports = concatMap (mapToPorts AST.In) args
-            ++ mapToPorts AST.Out res
-            ++ clk_port
-    mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec] 
-    mapToPorts mode m =
-      Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
+    -- 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]
+              ++ [clk_port]

     -- Add a clk port if we have state
     -- Add a clk port if we have state

-    clk_port = if hasState hsfunc
+    clk_port = if True -- hasState hsfunc

       then
       then

-        [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
+        Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty

       else
       else

-        []
+        Nothing

 
 -- | Create a port declaration
 mkIfaceSigDec ::
 
 -- | Create a port declaration
 mkIfaceSigDec ::


@@ -142,34 +165,37 @@ mkIfaceSigDec _ Nothing = Nothing
 -- | Generate a VHDL entity name for the given hsfunc
 mkEntityId hsfunc =
   -- TODO: This doesn't work for functions with multiple signatures!
 -- | Generate a VHDL entity name for the given hsfunc
 mkEntityId hsfunc =
   -- TODO: This doesn't work for functions with multiple signatures!

-  mkVHDLId $ hsFuncName hsfunc
+  -- Use a Basic Id, since using extended id's for entities throws off
+  -- precision and causes problems when generating filenames.
+  mkVHDLBasicId $ hsFuncName hsfunc

 
 -- | Create an architecture for a given function
 createArchitecture ::
 
 -- | Create an architecture for a given function
 createArchitecture ::

-  HsFunction -- ^ The function signature
-  -> FlatFunction -- ^ The FlatFunction
+  (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function

   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 
   -> VHDLState AST.ArchBody -- ^ The architecture for this function
 

-createArchitecture hsfunc flatfunc = 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 = ent_id signature
-    -- Create concurrent statements for all signal definitions
-  let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
-  return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+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
+  -- Strip off lambda's, these will be arguments
+  let (args, letexpr) = CoreSyn.collectBinders expr
+  -- There must be a let at top level 
+  let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
+
+  -- Create signal declarations for all internal and state signals
+  sig_dec_maybes <- mapM (mkSigDec' . fst) binds
+  let sig_decs = Maybe.catMaybes $ sig_dec_maybes
+
+  statements <- Monad.mapM mkConcSm binds
+  return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')

   where
   where

-    sigs = flat_sigs flatfunc
-    args = flat_args flatfunc
-    res  = flat_res  flatfunc
-    defs = flat_defs flatfunc
-    -- Create signal declarations for all internal and state signals
-    (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
-    -- TODO: Unique ty_decls
-    -- TODO: Store ty_decls somewhere
-    procs = map mkStateProcSm (makeStatePairs flatfunc)
+    procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)

     procs' = map AST.CSPSm procs
     procs' = map AST.CSPSm procs

+    -- mkSigDec only uses vsTypes from the state
+    mkSigDec' = mkSigDec

 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.


@@ -190,75 +216,140 @@ mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
 mkStateProcSm (num, old, new) =
   AST.ProcSm label [clk] [statement]
   where
 mkStateProcSm (num, old, new) =
   AST.ProcSm label [clk] [statement]
   where

-    label       = mkVHDLId $ "state_" ++ (show num)
-    clk         = mkVHDLId "clk"
-    rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
+    label       = mkVHDLExtId $ "state_" ++ (show num)
+    clk         = mkVHDLExtId "clk"
+    rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"

     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 
     wform       = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
     assign      = AST.SigAssign (AST.NSimple $ getSignalId old) wform
     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 :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
-mkSigDec info =
-  let use = sigUse info in
-  if isInternalSigUse use || isStateSigUse use then
-    let (ty_decls, type_mark) = vhdl_ty ty in
-    (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
+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
+    return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)

   else
   else

-    ([], Nothing)
-  where
-    ty = sigTy info
+    return Nothing

 
 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 --   is not named.
 getSignalId :: SignalInfo -> AST.VHDLId
 getSignalId info =
 
 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
 --   is not named.
 getSignalId :: SignalInfo -> AST.VHDLId
 getSignalId info =

-    mkVHDLId $ Maybe.fromMaybe
+    mkVHDLExtId $ Maybe.fromMaybe

       (error $ "Unnamed signal? This should not happen!")
       (sigName info)
 
       (error $ "Unnamed signal? This should not happen!")
       (sigName info)
 

--- | Transforms a signal definition into a VHDL concurrent statement
+-- | Transforms a core binding into a VHDL concurrent statement

 mkConcSm ::
 mkConcSm ::

-  SignatureMap             -- ^ The interfaces of functions in the session
-  -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
-  -> SigDef                -- ^ The signal definition 
-  -> Int                   -- ^ A number that will be unique for all
-                           --   concurrent statements in the architecture.
-  -> AST.ConcSm            -- ^ The corresponding VHDL component instantiation.
-
-mkConcSm signatures sigs (FApp hsfunc args res) num =
-  let 
-    signature = Maybe.fromMaybe
-        (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
-        (Map.lookup hsfunc signatures)
-    entity_id = ent_id signature
-    label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
-    -- Add a clk port if we have state
-    clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
-    portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
-  in
-    AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
-
-mkConcSm _ sigs (UncondDef src dst) _ =
+  (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
+  -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
+
+mkConcSm (bndr, app@(CoreSyn.App _ _))= do
+  signatures <- getA vsSignatures
+  funSignatures <- getA vsNameTable
+  let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+  case (Map.lookup (bndrToString f) funSignatures) of
+    Just funSignature ->
+      let
+        sigs = map (bndrToString.varBndr) args
+        sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+        func = (snd funSignature) 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
+    Nothing ->
+      let  
+        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)
+
+-- 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"
+
+-- 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
+-- for a scrutinee. We check the constructor of the second alt, since the
+-- first is the default case, if there is any.
+mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =

   let
   let

-    src_expr  = vhdl_expr src
-    src_wform = AST.Wform [AST.WformElem src_expr Nothing]
-    dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
-    assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+    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
   in

-    AST.CSSASm assign
+    return $ AST.CSSASm assign
+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"
+
+-- Turn a variable reference into a AST expression
+varToVHDLExpr :: Var.Var -> AST.Expr
+varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
+
+-- Turn a constructor into an AST expression. For dataconstructors, this is
+-- only the constructor itself, not any arguments it has. Should not be called
+-- with a DEFAULT constructor.
+conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
+  where
+    tycon = DataCon.dataConTyCon dc
+    tyname = TyCon.tyConName tycon
+    dcname = DataCon.dataConName dc
+    lit = case Name.getOccString tyname of
+      -- TODO: Do something more robust than string matching
+      "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+      "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
+conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+
+
+
+{-
+mkConcSm sigs (UncondDef src dst) _ = do
+  src_expr <- vhdl_expr src
+  let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
+  let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
+  let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+  return $ AST.CSSASm assign

   where
   where

-    vhdl_expr (Left id) = mkIdExpr sigs id
+    vhdl_expr (Left id) = return $ mkIdExpr sigs id

     vhdl_expr (Right expr) =
       case expr of
         (EqLit id lit) ->
     vhdl_expr (Right expr) =
       case expr of
         (EqLit id lit) ->

-          (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
-        (Literal lit) ->
-          AST.PrimLit lit
+          return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+        (Literal lit Nothing) ->
+          return $ AST.PrimLit lit
+        (Literal lit (Just ty)) -> 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 <- 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

         (Eq a b) ->
         (Eq a b) ->

-          (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
+         return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)

 
 

-mkConcSm _ sigs (CondDef cond true false dst) _ =
+mkConcSm sigs (CondDef cond true false dst) _ =

   let
     cond_expr  = mkIdExpr sigs cond
     true_expr  = mkIdExpr sigs true
   let
     cond_expr  = mkIdExpr sigs cond
     true_expr  = mkIdExpr sigs true


@@ -269,8 +360,8 @@ mkConcSm _ sigs (CondDef cond true false dst) _ =
     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
   in
     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
   in

-    AST.CSSASm assign
-
+    return $ AST.CSSASm assign
+-}

 -- | Turn a SignalId into a VHDL Expr
 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 mkIdExpr sigs id =
 -- | Turn a SignalId into a VHDL Expr
 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
 mkIdExpr sigs id =


@@ -278,27 +369,29 @@ mkIdExpr sigs id =
   AST.PrimName src_name
 
 mkAssocElems :: 
   AST.PrimName src_name
 
 mkAssocElems :: 

-  [(SignalId, SignalInfo)]      -- | The signals in the current architecture
-  -> [SignalMap]                -- | The signals that are applied to function
-  -> SignalMap                  -- | the signals in which to store the function result
+  [CoreSyn.CoreExpr]            -- | The argument that are applied to function
+  -> CoreSyn.CoreBndr           -- | The binder in which to store the result

   -> Entity                     -- | The entity to map against.
   -> [AST.AssocElem]            -- | The resulting port maps
 
   -> Entity                     -- | The entity to map against.
   -> [AST.AssocElem]            -- | The resulting port maps
 

-mkAssocElems sigmap args res entity =
+mkAssocElems args res entity =

     -- Create the actual AssocElems
     Maybe.catMaybes $ 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
     -- the similar form?
     -- Create the actual AssocElems
     Maybe.catMaybes $ 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
     -- the similar form?

-    arg_ports = concat (map Foldable.toList (ent_args entity))
-    res_ports = Foldable.toList (ent_res entity)
-    arg_sigs  = (concat (map Foldable.toList args))
-    res_sigs  = Foldable.toList res
+    arg_ports = ent_args entity
+    res_port  = ent_res entity

     -- Extract the id part from the (id, type) tuple
     -- Extract the id part from the (id, type) tuple

-    ports     = (map (fmap fst) (arg_ports ++ res_ports)) 
+    ports     = map (Monad.liftM fst) (res_port : arg_ports)

     -- Translate signal numbers into names
     -- Translate signal numbers into names

-    sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
+    sigs      = (bndrToString res : map (bndrToString.varBndr) args)
+
+-- Turns a Var CoreExpr into the Id inside it. Will of course only work for
+-- simple Var CoreExprs, not complexer ones.
+varBndr :: CoreSyn.CoreExpr -> Var.Id
+varBndr (CoreSyn.Var id) = id

 
 -- | Look up a signal in the signal name map
 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
 
 -- | Look up a signal in the signal name map
 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String


@@ -313,7 +406,7 @@ lookupSigName sigs sig = name
 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 
 -- | 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 (mkVHDLId signal))) 
+mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal))) 

 mkAssocElem Nothing _ = Nothing
 
 -- | The VHDL Bit type
 mkAssocElem Nothing _ = Nothing
 
 -- | The VHDL Bit type


@@ -329,46 +422,72 @@ std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type

-vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
-vhdl_ty ty = Maybe.fromMaybe
-  (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
-  (vhdl_ty_maybe ty)
-
--- Translate a Haskell type to a VHDL type, optionally generating a type
--- declaration for the type.
-vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
-vhdl_ty_maybe ty =
-  if Type.coreEqType ty TysWiredIn.boolTy
-    then
-      Just ([], bool_ty)
-    else
-      case Type.splitTyConApp_maybe ty of
-        Just (tycon, args) ->
-          let name = TyCon.tyConName tycon in
-            -- TODO: Do something more robust than string matching
-            case Name.getOccString name of
-              "Bit"      -> Just ([], std_logic_ty)
-              "FSVec"    ->
-                let 
-                  [len, el_ty] = args 
-                  -- TODO: Find actual number
-                  ty_id = mkVHDLId ("vector_" ++ (show len))
-                  -- TODO: Use el_ty
-                  range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
-                  ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
-                  ty_dec = AST.TypeDec ty_id ty_def
-                in
-                  Just ([ty_dec], ty_id)
-              otherwise  -> Nothing
-        otherwise -> Nothing
-
--- Shortcut
-mkVHDLId :: String -> AST.VHDLId
-mkVHDLId s = 
-  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
+vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
+vhdl_ty 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
+      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
+              "TFVec" -> Just $ mk_vector_ty (tfvec_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
+
+-- | Create a VHDL vector type
+mk_vector_ty ::
+  Int -- ^ The length of the vector
+  -> Type.Type -- ^ The Haskell type to create a VHDL type for
+  -> VHDLState AST.TypeMark -- 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
+  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))
+  modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
+  modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
+  return ty_id
+
+
+builtin_types = 
+  Map.fromList [
+    ("Bit", std_logic_ty),
+    ("Bool", bool_ty) -- TysWiredIn.boolTy
+  ]
+
+-- Shortcut for 
+-- Can only contain alphanumerics and underscores. The supplied string must be
+-- a valid basic id, otherwise an error value is returned. This function is
+-- not meant to be passed identifiers from a source file, use mkVHDLExtId for
+-- that.
+mkVHDLBasicId :: String -> AST.VHDLId
+mkVHDLBasicId s = 
+  AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s

   where
     -- Strip invalid characters.
     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
   where
     -- Strip invalid characters.
     strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")

+    -- Strip leading numbers and underscores
+    strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")

     -- Strip multiple adjacent underscores
     strip_multiscore = concat . map (\cs -> 
         case cs of 
     -- Strip multiple adjacent underscores
     strip_multiscore = concat . map (\cs -> 
         case cs of 


@@ -376,29 +495,55 @@ mkVHDLId s =
           _ -> cs
       ) . List.group
 
           _ -> cs
       ) . List.group
 

+-- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
+-- different characters than basic ids, but can never be used to refer to
+-- basic ids.
+-- Use extended Ids for any values that are taken from the source file.
+mkVHDLExtId :: String -> AST.VHDLId
+mkVHDLExtId s = 
+  AST.unsafeVHDLExtId $ strip_invalid s
+  where 
+    -- Allowed characters, taken from ForSyde's mkVHDLExtId
+    allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+    strip_invalid = filter (`elem` allowed)
+
+-- Creates a VHDL Id from a binder
+bndrToVHDLId ::
+  CoreSyn.CoreBndr
+  -> AST.VHDLId
+
+bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
+
+-- Extracts the binder name as a String
+bndrToString ::
+  CoreSyn.CoreBndr
+  -> String
+
+bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
+

 -- | A consise representation of a (set of) ports on a builtin function
 -- | A consise representation of a (set of) ports on a builtin function

-type PortMap = HsValueMap (String, AST.TypeMark)
+--type PortMap = HsValueMap (String, AST.TypeMark)

 -- | A consise representation of a builtin function
 -- | A consise representation of a builtin function

-data BuiltIn = BuiltIn String [PortMap] PortMap
+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) ->
 
 -- | Translate a list of concise representation of builtin functions to a
 --   SignatureMap
 mkBuiltins :: [BuiltIn] -> SignatureMap
 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->

-    (HsFunction name (map useAsPort args) (useAsPort res),
-     Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
+    (name,
+     Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))

   )
 
 builtin_hsfuncs = Map.keys builtin_funcs
 builtin_funcs = mkBuiltins
   [ 
   )
 
 builtin_hsfuncs = Map.keys builtin_funcs
 builtin_funcs = mkBuiltins
   [ 

-    BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
-    BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
-    BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
-    BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
+    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)

   ]
 
 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 --   a VHDLSignalMap
   ]
 
 -- | Map a port specification of a builtin function to a VHDL Signal to put in
 --   a VHDLSignalMap

-toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
-toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLId name, ty))
+toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
+toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)