Added builtin foldl function

[matthijs/master-project/cλash.git] / VHDL.hs

diff --git a/VHDL.hs b/VHDL.hs
index 418ac181fc95a4c6e0bb43f83410a463de7623b6..3bd2fe218faf182ca6e63ceeb701948e7aee3606 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -3,111 +3,162 @@
 --
 module VHDL where
 
 --
 module VHDL where
 

-import qualified Data.Foldable as Foldable
+-- Standard modules

 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Maybe
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Maybe
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow

-import qualified Data.Traversable as Traversable
+import qualified Control.Monad.Trans.State as State

 import qualified Data.Monoid as Monoid
 import Data.Accessor
 
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 

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

 import qualified Name
 import qualified Name

+import qualified Var
+import qualified Id
+import qualified IdInfo

 import qualified TyCon
 import qualified TyCon

+import qualified DataCon
+--import qualified CoreSubst
+import qualified CoreUtils

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

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

 import VHDLTypes
 import VHDLTypes

-import Flatten
-import FlattenTypes
-import TranslatorTypes
+import VHDLTools

 import Pretty
 import Pretty

-
-getDesignFiles :: [FuncData] -> [AST.DesignFile]
-getDesignFiles funcs =
-  map (AST.DesignFile context) units
-  where
-    units = filter (not.null) $ map getLibraryUnits funcs
-    context = [
-      AST.Library $ mkVHDLId "IEEE",
-      AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
+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_dec, type_package_body]) :
+  map (Arrow.second $ AST.DesignFile full_context) units

   
   

+  where
+    init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
+    (units, final_session) = 
+      State.runState (createLibraryUnits binds) init_session
+    tyfun_decls = map snd $ 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))
+    tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
+    tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
+    tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
+    ieee_context = [
+        AST.Library $ mkVHDLBasicId "IEEE",
+        mkUseAll ["IEEE", "std_logic_1164"],
+        mkUseAll ["IEEE", "numeric_std"]
+      ]
+    full_context =
+      mkUseAll ["work", "types"]
+      : (mkUseAll ["work"]
+      : ieee_context)
+    type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
+    type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+    subProgSpecs = map subProgSpec tyfun_decls
+    subProgSpec = \(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
+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 ::
+  [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+  -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
+
+createLibraryUnits binds = do
+  entities <- Monad.mapM createEntity binds
+  archs <- Monad.mapM createArchitecture binds
+  return $ zipWith 
+    (\ent arch -> 
+      let AST.EntityDec id _ = ent in 
+      (id, [AST.LUEntity ent, AST.LUArch arch])
+    )
+    entities archs
+

 -- | Create an entity for a given function
 createEntity ::
 -- | Create an entity for a given function
 createEntity ::

-  HsFunction        -- | The function signature
-  -> FuncData       -- | The function data collected so far
-  -> Maybe Entity   -- | The resulting entity. Should return the existing
-                    ---  Entity for builtin functions.
-
-createEntity hsfunc fdata = 
-  case fdata ^. fdFlatFunc of
-    -- Skip (builtin) functions without a FlatFunction
-    Nothing -> fdata ^. fdEntity
-    -- Create an entity for all other functions
-    Just 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'
-        pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
-        pkg_decl = if null ty_decls && null ty_decls'
-          then Nothing
-          else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
-        AST.EntityDec entity_id _ = ent_decl' 
-      in 
-        Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl
+  (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
+  -> VHDLSession AST.EntityDec -- | The resulting entity
+
+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 vhdl_id = mkVHDLBasicId $ varToString 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 fname signature)
+      return ent_decl'

   where
   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
+    mkMap ::
+      --[(SignalId, SignalInfo)] 
+      CoreSyn.CoreBndr 
+      -> VHDLSession 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 = varToVHDLId 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
+  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 hsfunc args res =
+createEntityAST vhdl_id 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.
+    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 std_logicTM

       else
       else

-        []
+        Nothing

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


@@ -118,44 +169,47 @@ mkIfaceSigDec ::
 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 mkIfaceSigDec _ Nothing = Nothing
 
 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
 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 ::

-  FuncMap           -- ^ The functions in the current session
-  -> HsFunction     -- ^ The function signature
-  -> FuncData       -- ^ The function data collected so far
-  -> Maybe AST.ArchBody -- ^ The architecture for this function
-
-createArchitecture funcs hsfunc fdata = 
-  case fdata ^. fdFlatFunc of
-    -- Skip (builtin) functions without a FlatFunction
-    Nothing -> fdata ^. fdArch
-    -- Create an architecture for all other functions
-    Just flatfunc ->
-      let
-        sigs = flat_sigs flatfunc
-        args = flat_args flatfunc
-        res  = flat_res  flatfunc
-        defs = flat_defs flatfunc
-        entity_id = Maybe.fromMaybe
-                      (error $ "Building architecture without an entity? This should not happen!")
-                      (getEntityId fdata)
-        -- Create signal declarations for all signals that are not in args and
-        -- res
-        (ty_decls, sig_decs)  = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
-        -- TODO: Unique ty_decls
-        -- TODO: Store ty_decls somewhere
-        -- Create concurrent statements for all signal definitions
-        statements = zipWith (mkConcSm funcs sigs) defs [0..]
-        procs = map mkStateProcSm (makeStatePairs flatfunc)
-        procs' = map AST.CSPSm procs
-      in
-        Just $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+  (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
+  -> VHDLSession AST.ArchBody -- ^ The architecture for this function
+
+createArchitecture (fname, expr) = do
+  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 
+  let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
+
+  -- Create signal declarations for all binders in the let expression, except
+  -- for the output port (that will already have an output port declared in
+  -- the entity).
+  sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
+  let sig_decs = Maybe.catMaybes $ sig_dec_maybes
+
+  statementss <- Monad.mapM mkConcSm binds
+  let statements = concat statementss
+  return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
+  where
+    procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
+    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.
 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.
 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]


@@ -175,218 +229,141 @@ 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)
-  else
-    ([], Nothing)
-  where
-    ty = sigTy info
-

 -- | 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
-      (error $ "Unnamed signal? This should not happen!")
-      (sigName info)
+  mkVHDLExtId $ Maybe.fromMaybe
+    (error $ "Unnamed signal? This should not happen!")
+    (sigName info)
+-}
+   
+mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (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 (varToVHDLId bndr) type_mark Nothing)
+  else
+    return Nothing

 
 

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

 mkConcSm ::
 mkConcSm ::

-  FuncMap                  -- ^ The functions in the current 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 funcs sigs (FApp hsfunc args res) num =
-  let 
-    fdata_maybe = Map.lookup hsfunc funcs
-    fdata = Maybe.fromMaybe
-        (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
-        fdata_maybe
-    entity = Maybe.fromMaybe
-        (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
-        (fdata ^. fdEntity)
-    entity_id = ent_id entity
-    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 entity ++ (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) _ =
-  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)
-  in
-    AST.CSSASm assign
-  where
-    vhdl_expr (Left id) = mkIdExpr sigs id
-    vhdl_expr (Right expr) =
-      case expr of
-        (EqLit id lit) ->
-          (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
-        (Literal lit) ->
-          AST.PrimLit lit
-        (Eq a b) ->
-          (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
-
-mkConcSm _ sigs (CondDef cond true false dst) _ =
+  (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
+  -> VHDLSession [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
+
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out.
+mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
+
+-- For simple a = b assignments, just generate an unconditional signal
+-- assignment. This should only happen for dataconstructors without arguments.
+-- TODO: Integrate this with the below code for application (essentially this
+-- is an application without arguments)
+mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
+
+mkConcSm (bndr, app@(CoreSyn.App _ _))= do
+  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)
+          return $ zipWith mkassign labels valargs
+        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.
+      signatures <- getA vsSignatures
+      case (Map.lookup (varToString f) globalNameTable) of
+        Just (arg_count, builder) ->
+          if length valargs == arg_count then
+            case builder of
+              Left funBuilder -> do
+                let sigs = map (varToVHDLExpr.exprToVar) valargs
+                func <- funBuilder bndr sigs
+                let src_wform = AST.Wform [AST.WformElem func Nothing]
+                let dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))
+                let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+                return [AST.CSSASm assign]
+              Right genBuilder -> do
+                let sigs = map exprToVar valargs
+                let signature = Maybe.fromMaybe
+                      (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!") 
+                      (Map.lookup (head sigs) signatures)
+                let arg = tail sigs
+                genSm <- genBuilder signature (arg ++ [bndr])  
+                return [genSm]
+          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 '" ++ (varToString f) ++ "' without signature? This should not happen!") 
+          (Map.lookup f signatures)
+        entity_id = ent_id signature
+        label = "comp_ins_" ++ varToString bndr
+        -- Add a clk port if we have state
+        --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+        clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+        --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+        portmaps = clk_port : mkAssocElems args bndr signature
+        in
+          return [mkComponentInst label entity_id portmaps]
+    details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+
+-- 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
+-- 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

-    cond_expr  = mkIdExpr sigs cond
-    true_expr  = mkIdExpr sigs true
-    false_expr  = mkIdExpr sigs 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 (getSignalId $ signalInfo sigs dst)
-    assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+    cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
+    true_expr  = (varToVHDLExpr true)
+    false_expr  = (varToVHDLExpr false)

   in
   in

-    AST.CSSASm assign
-
--- | Turn a SignalId into a VHDL Expr
-mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
-mkIdExpr sigs id =
-  let src_name  = AST.NSimple (getSignalId $ signalInfo sigs id) in
-  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
-  -> Entity                     -- | The entity to map against.
-  -> [AST.AssocElem]            -- | The resulting port maps
-
-mkAssocElems sigmap 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?
-    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
-    -- Extract the id part from the (id, type) tuple
-    ports     = (map (fmap fst) (arg_ports ++ res_ports)) 
-    -- Translate signal numbers into names
-    sigs      = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
-
--- | Look up a signal in the signal name map
-lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
-lookupSigName sigs sig = name
-  where
-    info = Maybe.fromMaybe
-      (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
-      (lookup sig sigs)
-    name = Maybe.fromMaybe
-      (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
-      (sigName info)
-
--- | 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 Nothing _ = Nothing
-
--- | Extracts the generated entity id from the given funcdata
-getEntityId :: FuncData -> Maybe AST.VHDLId
-getEntityId fdata =
-  case fdata ^. fdEntity of
-    Nothing -> Nothing
-    Just e  -> case ent_decl e of
-      Nothing -> Nothing
-      Just (AST.EntityDec id _) -> Just id
-
-getLibraryUnits ::
-  FuncData                    -- | A function from the session
-  -> [AST.LibraryUnit]  -- | The entity, architecture and optional package for the function
-
-getLibraryUnits fdata =
-  case fdata ^. fdEntity of 
-    Nothing -> []
-    Just ent -> 
-      case ent_decl ent of
-      Nothing -> []
-      Just decl ->
-        case fdata ^. fdArch of
-          Nothing -> []
-          Just arch ->
-              [AST.LUEntity decl, AST.LUArch arch]
-              ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
-
--- | The VHDL Bit type
-bit_ty :: AST.TypeMark
-bit_ty = AST.unsafeVHDLBasicId "Bit"
-
--- | The VHDL Boolean type
-bool_ty :: AST.TypeMark
-bool_ty = AST.unsafeVHDLBasicId "Boolean"
-
--- | The VHDL std_logic
-std_logic_ty :: AST.TypeMark
-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
-  where
-    -- Strip invalid characters.
-    strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
-    -- Strip multiple adjacent underscores
-    strip_multiscore = concat . map (\cs -> 
-        case cs of 
-          ('_':_) -> "_"
-          _ -> cs
-      ) . List.group
+    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