Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project
authorChristiaan Baaij <christiaan.baaij@gmail.com>
Fri, 19 Jun 2009 10:17:44 +0000 (12:17 +0200)
committerChristiaan Baaij <christiaan.baaij@gmail.com>
Fri, 19 Jun 2009 10:17:44 +0000 (12:17 +0200)
* 'cλash' of http://git.stderr.nl/matthijs/projects/master-project:
  Use highordtest in main, since that can now be normalized.
  Add a (fairly complete) set of transforms.
  Add is_lam and is_fun predicates.
  Add a inlinebind helper function.
  Add a substitute helper function.
  Print the type in the transform debug output.
  Add infrastructure for running core to core transformations.
  Add a higher order testcase.
  Add is_wild function to check for wild binders.
  Generate VHDL from Core instead of flat functions.

Conflicts:
Translator.hs
VHDL.hs

1  2 
CoreTools.hs
Main.hs
Translator.hs
VHDL.hs
VHDLTypes.hs

diff --combined CoreTools.hs
index 5fbe8716e9f5ceb2321e6769eec65c585c28de0e,3dfaf5016cedb0ede442564d2e22452d9cc16e37..a8dce3fab43ac345762307704a27b6d1e31592b3
@@@ -11,11 -11,16 +11,16 @@@ import qualified HsExp
  import qualified HsTypes
  import qualified HsBinds
  import qualified RdrName
+ import qualified Name
  import qualified OccName
  import qualified TysWiredIn
  import qualified Bag
  import qualified DynFlags
  import qualified SrcLoc
+ import qualified CoreSyn
+ import qualified Var
+ import qualified Unique
+ import qualified CoreUtils
  
  import GhcTools
  import HsTools
@@@ -56,24 -61,41 +61,41 @@@ sized_word_len ty 
  
  -- | Evaluate a core Type representing type level int from the TypeLevel
  -- library to a real int.
 -eval_type_level_int :: Type.Type -> Int
 -eval_type_level_int ty =
 -  unsafeRunGhc $ do
 -    -- Automatically import modules for any fully qualified identifiers
 -    setDynFlag DynFlags.Opt_ImplicitImportQualified
 -
 -    let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
 -    let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
 -    let undef = hsTypedUndef $ coreToHsType ty
 -    let app = HsExpr.HsApp (to_int) (undef)
 -
 -    core <- toCore [] app
 -    execCore core 
 +-- eval_type_level_int :: Type.Type -> Int
 +-- eval_type_level_int ty =
 +--   unsafeRunGhc $ do
 +--     -- Automatically import modules for any fully qualified identifiers
 +--     setDynFlag DynFlags.Opt_ImplicitImportQualified
 +-- 
 +--     let to_int_name = mkRdrName "Data.TypeLevel.Num.Sets" "toInt"
 +--     let to_int = SrcLoc.noLoc $ HsExpr.HsVar to_int_name
 +--     let undef = hsTypedUndef $ coreToHsType ty
 +--     let app = HsExpr.HsApp (to_int) (undef)
 +-- 
 +--     core <- toCore [] app
 +--     execCore core 
  
  -- | Get the length of a FSVec type
 -fsvec_len :: Type.Type -> Int
 -fsvec_len ty =
 -  eval_type_level_int len
 +tfvec_len :: Type.Type -> Int
 +tfvec_len ty =
 +  eval_tfp_int len
    where 
      (tycon, args) = Type.splitTyConApp ty
      [len, el_ty] = args
+ -- Is this a wild binder?
+ is_wild :: CoreSyn.CoreBndr -> Bool
+ -- wild binders have a particular unique, that we copied from MkCore.lhs to
+ -- here. However, this comparison didn't work, so we'll just check the
+ -- occstring for now... TODO
+ --(Var.varUnique bndr) == (Unique.mkBuiltinUnique 1)
+ is_wild bndr = "wild" == (OccName.occNameString . Name.nameOccName . Var.varName) bndr
+ -- Is the given core expression a lambda abstraction?
+ is_lam :: CoreSyn.CoreExpr -> Bool
+ is_lam (CoreSyn.Lam _ _) = True
+ is_lam _ = False
+ -- Is the given core expression of a function type?
+ is_fun :: CoreSyn.CoreExpr -> Bool
+ is_fun = Type.isFunTy . CoreUtils.exprType
diff --combined Main.hs
index be0a0a077f5496d7c9f3c06daa4fd58ae12779b7,0000000000000000000000000000000000000000..be48aa3bb3d86aaac2b0ac7e4aaf4fc6614a79ac
mode 100644,000000..100644
--- /dev/null
+++ b/Main.hs
@@@ -1,6 -1,0 +1,6 @@@
-   makeVHDL "Alu.hs" "exec" True
 +module Main where
 +
 +import Translator
 +
 +main = do
++  makeVHDL "Adders.hs" "highordtest" True
diff --combined Translator.hs
index f377152c775c9deaf7b8efed06453a63403e7a3b,3f60330b37a68b8680cdedec20996f28134c5a42..0f60277671f99b646ec427deb8fd82ce92d53169
@@@ -1,6 -1,8 +1,8 @@@
  module Translator where
  import qualified Directory
  import qualified List
+ import Debug.Trace
+ import qualified Control.Arrow as Arrow
  import GHC hiding (loadModule, sigName)
  import CoreSyn
  import qualified CoreUtils
@@@ -26,6 -28,7 +28,7 @@@ import MonadUtils ( liftIO 
  import Outputable ( showSDoc, ppr )
  import GHC.Paths ( libdir )
  import DynFlags ( defaultDynFlags )
+ import qualified UniqSupply
  import List ( find )
  import qualified List
  import qualified Monad
@@@ -43,13 -46,14 +46,14 @@@ import Text.PrettyPrint.HughesPJ (rende
  import TranslatorTypes
  import HsValueMap
  import Pretty
+ import Normalize
  import Flatten
  import FlattenTypes
  import VHDLTypes
  import qualified VHDL
  
 -main = do
 -  makeVHDL "Adders.hs" "highordtest" True
 +-- main = do
 +--   makeVHDL "Alu.hs" "exec" True
  
  makeVHDL :: String -> String -> Bool -> IO ()
  makeVHDL filename name stateful = do
@@@ -58,7 -62,7 +62,7 @@@
    -- Translate to VHDL
    vhdl <- moduleToVHDL core [(name, stateful)]
    -- Write VHDL to file
 -  let dir = "../vhdl/vhdl/" ++ name ++ "/"
 +  let dir = "./vhdl/" ++ name ++ "/"
    mapM (writeVHDL dir) vhdl
    return ()
  
@@@ -81,25 -85,31 +85,31 @@@ listBind filename name = d
  moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
  moduleToVHDL core list = do
    let (names, statefuls) = unzip list
-   --liftIO $ putStr $ prettyShow (cm_binds core)
    let binds = findBinds core names
-   --putStr $ prettyShow binds
+   -- Generate a UniqSupply
+   -- Running 
+   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
+   -- on the compiler dir of ghc suggests that 'z' is not used to generate a
+   -- unique supply anywhere.
+   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
    -- Turn bind into VHDL
-   let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (TranslatorSession core 0 Map.empty)
+   let (vhdl, sess) = State.runState (mkVHDL uniqSupply binds statefuls) (TranslatorSession core 0 Map.empty)
    mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
    putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
    return vhdl
    where
      -- Turns the given bind into VHDL
-     mkVHDL :: [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
-     mkVHDL binds statefuls = do
+     mkVHDL :: UniqSupply.UniqSupply -> [(CoreBndr, CoreExpr)] -> [Bool] -> TranslatorState [(AST.VHDLId, AST.DesignFile)]
+     mkVHDL uniqSupply binds statefuls = do
+       let binds'' = map (Arrow.second $ normalize uniqSupply) binds
+       let binds' = trace ("Before:\n\n" ++ showSDoc ( ppr binds ) ++ "\n\nAfter:\n\n" ++ showSDoc ( ppr binds'')) binds''
        -- Add the builtin functions
        --mapM addBuiltIn builtin_funcs
        -- Create entities and architectures for them
-       Monad.zipWithM processBind statefuls binds
-       modA tsFlatFuncs (Map.map nameFlatFunction)
-       flatfuncs <- getA tsFlatFuncs
-       return $ VHDL.createDesignFiles flatfuncs
+       --Monad.zipWithM processBind statefuls binds
+       --modA tsFlatFuncs (Map.map nameFlatFunction)
+       --flatfuncs <- getA tsFlatFuncs
+       return $ VHDL.createDesignFiles binds'
  
  -- | Write the given design file to a file with the given name inside the
  --   given dir
@@@ -126,7 -136,7 +136,7 @@@ loadModule filename 
        --setTargets [target]
        --load LoadAllTargets
        --core <- GHC.compileToCoreSimplified "Adders.hs"
-       core <- GHC.compileToCoreSimplified filename
+       core <- GHC.compileToCoreModule filename
        return core
  
  -- | Extracts the named binds from the given module.
@@@ -270,7 -280,7 +280,7 @@@ resolvFunc hsfunc = d
    -- Don't do anything if there is already a flat function for this hsfunc or
    -- when it is a builtin function.
    Monad.unless (Map.member hsfunc flatfuncmap) $ do
-   Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+   -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
    -- New function, resolve it
    core <- getA tsCoreModule
    -- Find the named function
diff --combined VHDL.hs
index 846cd814e376ed2e84ca965fc44ba57562d943f5,561c2790d5537bc56d4f5b12d6d9505b2f2a30fb..d177a10b934dc8004425a150552de5df83c12e4e
+++ b/VHDL.hs
@@@ -16,6 -16,7 +16,7 @@@ import qualified Data.Monoid as Monoi
  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 qualified Type
  import qualified Name
+ import qualified OccName
+ import qualified Var
  import qualified TyCon
+ import qualified CoreSyn
  import Outputable ( showSDoc, ppr )
  
  -- Local imports
@@@ -34,22 -38,19 +38,22 @@@ import TranslatorType
  import HsValueMap
  import Pretty
  import CoreTools
 +import Constants
 +import Generate
 +import GlobalNameTable
  
  createDesignFiles ::
-   FlatFuncMap
+   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
    -> [(AST.VHDLId, AST.DesignFile)]
  
- createDesignFiles flatfuncmap =
+ createDesignFiles binds =
    (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
    map (Arrow.second $ AST.DesignFile full_context) units
    
    where
 -    init_session = VHDLSession Map.empty builtin_funcs
 +    init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
      (units, final_session) = 
-       State.runState (createLibraryUnits flatfuncmap) init_session
+       State.runState (createLibraryUnits binds) init_session
      ty_decls = Map.elems (final_session ^. vsTypes)
      ieee_context = [
          AST.Library $ mkVHDLBasicId "IEEE",
@@@ -72,14 -73,12 +76,12 @@@ mkUseAll ss 
      select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
        
  createLibraryUnits ::
-   FlatFuncMap
+   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
    -> 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 
  
  -- | 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
  
- createEntity hsfunc flatfunc = do
-       let sigs    = flat_sigs flatfunc
-       let args    = flat_args flatfunc
-       let res     = flat_res  flatfunc
-       args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
-       res' <- Traversable.traverse (mkMap sigs) res
-       let ent_decl' = createEntityAST hsfunc args' res'
+ 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 hsfunc signature)
+       modA vsSignatures (Map.insert (bndrToString fname) signature)
        return ent_decl'
    where
      mkMap :: 
-       [(SignalId, SignalInfo)] 
-       -> SignalId 
+       --[(SignalId, SignalInfo)] 
+       CoreSyn.CoreBndr 
        -> VHDLState VHDLSignalMapElement
      -- We only need the vsTypes element from the state
-     mkMap sigmap = (\id ->
 -    mkMap = MonadState.lift vsTypes . (\bndr ->
++    mkMap = (\bndr ->
        let
-         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
+         --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 isPortSigUse $ sigUse info
+         if True -- isPortSigUse $ sigUse info
            then do
              type_mark <- vhdl_ty ty
-             return $ Just (mkVHDLExtId nm, type_mark)
+             return $ Just (id, type_mark)
            else
              return $ Nothing
         )
  
    -- | 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
-     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
-     clk_port = if hasState hsfunc
+     clk_port = if True -- hasState hsfunc
        then
-         [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]
+         Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
        else
-         []
+         Nothing
  
  -- | Create a port declaration
  mkIfaceSigDec ::
@@@ -170,31 -167,31 +170,31 @@@ mkEntityId hsfunc 
  
  -- | 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
  
- 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
+ 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' . snd) sigs
+   sig_dec_maybes <- mapM (mkSigDec' . fst) binds
    let sig_decs = Maybe.catMaybes $ sig_dec_maybes
-   -- Create concurrent statements for all signal definitions
-   statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
+   statements <- Monad.mapM mkConcSm binds
    return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
    where
-     sigs = flat_sigs flatfunc
-     args = flat_args flatfunc
-     res  = flat_res  flatfunc
-     defs = flat_defs flatfunc
-     procs = map mkStateProcSm (makeStatePairs flatfunc)
+     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.
@@@ -223,16 -220,13 +223,13 @@@ 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 :: SignalInfo -> VHDLState (Maybe AST.SigDec)
- mkSigDec info =
-   let use = sigUse info in
-   if isInternalSigUse use || isStateSigUse use then do
-     type_mark <- vhdl_ty ty
-     return $ Just (AST.SigDec (getSignalId info) type_mark 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
+     return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
    else
      return Nothing
-   where
-     ty = sigTy info
  
  -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
  --   is not named.
@@@ -242,28 -236,33 +239,33 @@@ getSignalId 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 ::
-   [(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.
+   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
    -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
  
- mkConcSm sigs (FApp hsfunc args res) num = do
+ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
    signatures <- getA vsSignatures
    let 
+       (CoreSyn.Var f, args) = CoreSyn.collectArgs app
        signature = Maybe.fromMaybe
-           (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
-           (Map.lookup hsfunc signatures)
+           (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
+           (Map.lookup (bndrToString f) signatures)
        entity_id = ent_id signature
-       label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
+       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 [])
+       --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") [] []
+ {-
  mkConcSm sigs (UncondDef src dst) _ = do
    src_expr <- vhdl_expr src
    let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
            -- 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
@@@ -301,7 -300,7 +303,7 @@@ mkConcSm sigs (CondDef cond true false 
      assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
    in
      return $ AST.CSSASm assign
+ -}
  -- | Turn a SignalId into a VHDL Expr
  mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
  mkIdExpr sigs id =
    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
  
- 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?
-     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
-     ports     = (map (fmap fst) (arg_ports ++ res_ports)) 
+     ports     = map (Monad.liftM fst) (res_port : arg_ports)
      -- 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
@@@ -360,9 -361,9 +364,9 @@@ std_logic_ty :: AST.TypeMar
  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)
              (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
 +              "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
  mk_vector_ty ::
    Int -- ^ The length of the vector
    -> Type.Type -- ^ The Haskell type to create a VHDL type for
 -  -> TypeState AST.TypeMark -- The typemark created.
 +  -> VHDLState AST.TypeMark -- The typemark created.
  
  mk_vector_ty len ty = do
    -- Assume there is a single type argument
    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))
 +  --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
  
  
@@@ -445,29 -444,43 +449,43 @@@ mkVHDLExtId s 
      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
- type PortMap = HsValueMap (String, AST.TypeMark)
--type PortMap = HsValueMap (String, AST.TypeMark)
  -- | 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) ->
-     (HsFunction name (map useAsPort args) (useAsPort res),
-      Entity (VHDL.mkVHDLBasicId 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 "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
- toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
- toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))
+ toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
+ toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)
diff --combined VHDLTypes.hs
index f317167a86b857a02f675f8570c03b07cbe52805,784b09706e6a6742a4fb504640983e8973349225..e517a8ba08166d6c5800bdb5d4f41b3e4ab74876
@@@ -12,6 -12,7 +12,7 @@@ import qualified Data.Accessor.Templat
  
  -- GHC API imports
  import qualified Type
+ import qualified CoreSyn
  
  -- ForSyDe imports
  import qualified ForSyDe.Backend.VHDL.AST as AST
@@@ -30,8 -31,8 +31,8 @@@ type VHDLSignalMap = HsValueMap VHDLSig
  -- ports.
  data Entity = Entity { 
    ent_id     :: AST.VHDLId,           -- The id of the entity
-   ent_args   :: [VHDLSignalMap],      -- A mapping of each function argument to port names
-   ent_res    :: VHDLSignalMap         -- A mapping of the function result to port names
+   ent_args   :: [VHDLSignalMapElement],      -- A mapping of each function argument to port names
+   ent_res    :: VHDLSignalMapElement         -- A mapping of the function result to port names
  } deriving (Show);
  
  -- A orderable equivalent of CoreSyn's Type for use as a map key
@@@ -44,25 -45,15 +45,25 @@@ instance Ord OrdType wher
  -- A map of a Core type to the corresponding type name
  type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec)
  
 +-- A map of a vector Core type to the coressponding VHDL functions
 +type TypeFunMap = Map.Map OrdType [AST.SubProgBody]
 +
  -- A map of a Haskell function to a hardware signature
- type SignatureMap = Map.Map HsFunction Entity
+ type SignatureMap = Map.Map String Entity
  
 +-- A map of a builtin function to VHDL function builder 
 +type NameTable = Map.Map String (Int, [AST.Expr] -> AST.Expr )
 +
  data VHDLSession = VHDLSession {
    -- | A map of Core type -> VHDL Type
 -  vsTypes_ :: TypeMap,
 +  vsTypes_      :: TypeMap,
 +  -- | A map of vector Core type -> VHDL type function
 +  vsTypeFuns_   :: TypeFunMap,
    -- | A map of HsFunction -> hardware signature (entity name, port names,
    --   etc.)
 -  vsSignatures_ :: SignatureMap
 +  vsSignatures_ :: SignatureMap,
 +  -- | A map of Vector HsFunctions -> VHDL function call
 +  vsNameTable_  :: NameTable
  }
  
  -- Derive accessors