Introduce a new type HsValueMap.
[matthijs/master-project/cλash.git] / Translator.hs
index 6fa043c5e61039a6c52dd82f7920909b3f65c33d..8f1c3fd4d6e1a49326c2086cca2b756b8fc798ac 100644 (file)
@@ -26,6 +26,7 @@ import qualified Monad
 -- ForSyDe to get access to these modules.
 import qualified ForSyDe.Backend.VHDL.AST as AST
 import qualified ForSyDe.Backend.VHDL.Ppr
+import qualified ForSyDe.Backend.VHDL.FileIO
 import qualified ForSyDe.Backend.Ppr
 -- This is needed for rendering the pretty printed VHDL
 import Text.PrettyPrint.HughesPJ (render)
@@ -43,24 +44,29 @@ main =
           --load LoadAllTargets
           --core <- GHC.compileToCoreSimplified "Adders.hs"
           core <- GHC.compileToCoreSimplified "Adders.hs"
-          liftIO $ printBinds (cm_binds core)
-          let bind = findBind "full_adder" (cm_binds core)
-          let NonRec var expr = bind
+          --liftIO $ printBinds (cm_binds core)
+          let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["full_adder", "half_adder"]
+          liftIO $ printBinds binds
           -- Turn bind into VHDL
-          let vhdl = State.evalState (mkVHDL bind) (VHDLSession 0 builtin_funcs)
-          liftIO $ putStr $ showSDoc $ ppr expr
-          liftIO $ putStr "\n\n"
-          liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr $ vhdl
-          return expr
+          let vhdl = State.evalState (mkVHDL binds) (VHDLSession 0 [])
+          liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
+          liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
+          return ()
   where
     -- Turns the given bind into VHDL
-    mkVHDL bind = do
-      -- Get the function signature
-      (name, f) <- mkHWFunction bind
-      -- Add it to the session
-      addFunc name f
-      arch <- getArchitecture bind
-      return arch
+    mkVHDL binds = do
+      -- Add the builtin functions
+      mapM (uncurry addFunc) builtin_funcs
+      -- Get the function signatures
+      funcs <- mapM mkHWFunction binds
+      -- Add them to the session
+      mapM (uncurry addFunc) funcs
+      let entities = map getEntity (snd $ unzip funcs)
+      -- Create architectures for them
+      archs <- mapM getArchitecture binds
+      return $ AST.DesignFile 
+        []
+        ((map AST.LUEntity entities) ++ (map AST.LUArch archs))
 
 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
   print $ show file
@@ -81,128 +87,44 @@ printBind (Rec binds) = do
 
 printBind' (b, expr) = do
   putStr $ getOccString b
-  --putStr $ showSDoc $ ppr expr
+  putStr $ showSDoc $ ppr expr
   putStr "\n"
 
-findBind :: String -> [CoreBind] -> CoreBind
-findBind lookfor =
+findBind :: [CoreBind] -> String -> Maybe CoreBind
+findBind binds lookfor =
   -- This ignores Recs and compares the name of the bind with lookfor,
   -- disregarding any namespaces in OccName and extra attributes in Name and
   -- Var.
-  Maybe.fromJust . find (\b -> case b of 
+  find (\b -> case b of 
     Rec l -> False
     NonRec var _ -> lookfor == (occNameString $ nameOccName $ getName var)
-  )
+  ) binds
 
 getPortMapEntry ::
-  SignalNameMap AST.VHDLId  -- The port name to bind to
-  -> SignalNameMap AST.VHDLId 
+  SignalNameMap  -- The port name to bind to
+  -> SignalNameMap 
                             -- The signal or port to bind to it
   -> AST.AssocElem          -- The resulting port map entry
   
 -- Accepts a port name and an argument to map to it.
 -- Returns the appropriate line for in the port map
-getPortMapEntry (Signal portname) (Signal signame) = 
+getPortMapEntry (Single (portname, _)) (Single (signame, _)) = 
   (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
-
-getInstantiations ::
-  [SignalNameMap AST.VHDLId]   -- The arguments that need to be applied to the
-                               -- expression.
-  -> SignalNameMap AST.VHDLId  -- The output ports that the expression should generate.
-  -> [(CoreBndr, SignalNameMap AST.VHDLId)] 
-                               -- A list of bindings in effect
-  -> CoreSyn.CoreExpr          -- The expression to generate an architecture for
-  -> VHDLState ([AST.SigDec], [AST.ConcSm])    
-                               -- The resulting VHDL code
-
--- A lambda expression binds the first argument (a) to the binder b.
-getInstantiations (a:as) outs binds (Lam b expr) =
-  getInstantiations as outs ((b, a):binds) expr
-
--- A case expression that checks a single variable and has a single
--- alternative, can be used to take tuples apart
-getInstantiations args outs binds (Case (Var v) b _ [res]) =
-  -- Split out the type of alternative constructor, the variables it binds
-  -- and the expression to evaluate with the variables bound.
-  let (altcon, bind_vars, expr) = res in
-  case altcon of
-    DataAlt datacon ->
-      if (DataCon.isTupleCon datacon) then
-        let 
-          -- Lookup the scrutinee (which must be a variable bound to a tuple) in
-          -- the existing bindings list and get the portname map for each of
-          -- it's elements.
-          Tuple tuple_ports = Maybe.fromMaybe 
-            (error $ "Case expression uses unknown scrutinee " ++ getOccString v)
-            (lookup v binds)
-          -- Merge our existing binds with the new binds.
-          binds' = (zip bind_vars tuple_ports) ++ binds 
-        in
-          -- Evaluate the expression with the new binds list
-          getInstantiations args outs binds' expr
-      else
-        error "Data constructors other than tuples not supported"
-    otherwise ->
-      error "Case binders other than tuples not supported"
-
--- An application is an instantiation of a component
-getInstantiations args outs binds app@(App expr arg) = do
-  let ((Var f), fargs) = collectArgs app
-      name = getOccString f
-  if isTupleConstructor f 
-    then do
-      -- Get the signals we should bind our results to
-      let Tuple outports = outs
-      -- Split the tuple constructor arguments into types and actual values.
-      let (_, vals) = splitTupleConstructorArgs fargs
-      -- Bind each argument to each output signal
-      res <- sequence $ zipWith 
-        (\outs' expr' -> getInstantiations args outs' binds expr')
-        outports vals
-      -- res is a list of pairs of lists, so split out the signals and
-      -- components into separate lists of lists
-      let (sigs, comps) = unzip res
-      -- And join all the signals and component instantiations together
-      return $ (concat sigs, concat comps)
-    else do
-      -- This is an normal function application, which maps to a component
-      -- instantiation.
-      -- Lookup the hwfunction to instantiate
-      HWFunction inports outport <- getHWFunc name
-      -- Generate a unique name for the application
-      appname <- uniqueName "app"
-      -- Expand each argument to a signal or port name, possibly generating
-      -- new signals and component instantiations
-      (sigs, comps, args) <- expandArgs binds fargs
-      -- Bind each of the input ports to the expanded signal or port
-      let inmaps = zipWith getPortMapEntry inports args
-      -- Bind each of the output ports to our output signals
-      let outmaps = mapOutputPorts outport outs
-      -- Build and return a component instantiation
-      let comp = AST.CompInsSm
-            (AST.unsafeVHDLBasicId appname)
-            (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
-            (AST.PMapAspect (inmaps ++ outmaps))
-      return (sigs, (AST.CSISm comp) : comps)
-
-getInstantiations args outs binds expr = 
-  error $ "Unsupported expression" ++ (showSDoc $ ppr $ expr)
-
 expandExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
+  [(CoreBndr, SignalNameMap)] 
                                          -- A list of bindings in effect
   -> CoreExpr                            -- The expression to expand
   -> VHDLState (
        [AST.SigDec],                     -- Needed signal declarations
        [AST.ConcSm],                     -- Needed component instantations and
                                          -- signal assignments.
-       [SignalNameMap AST.VHDLId],       -- The signal names corresponding to
+       [SignalNameMap],       -- The signal names corresponding to
                                          -- the expression's arguments
-       SignalNameMap AST.VHDLId)         -- The signal names corresponding to
+       SignalNameMap)         -- The signal names corresponding to
                                          -- the expression's result.
 expandExpr binds lam@(Lam b expr) = do
   -- Generate a new signal to which we will expect this argument to be bound.
-  signal_name <- uniqueName ("arg-" ++ getOccString b)
+  signal_name <- uniqueName ("arg_" ++ getOccString b)
   -- Find the type of the binder
   let (arg_ty, _) = Type.splitFunTy (CoreUtils.exprType lam)
   -- Create signal names for the binder
@@ -220,19 +142,35 @@ expandExpr binds lam@(Lam b expr) = do
           res_signal')
 
 expandExpr binds (Var id) =
-  return ([], [], [], Signal signal_id)
+  return ([], [], [], Single (signal_id, ty))
   where
     -- Lookup the id in our binds map
-    Signal signal_id = Maybe.fromMaybe
+    Single (signal_id, ty) = Maybe.fromMaybe
       (error $ "Argument " ++ getOccString id ++ "is unknown")
       (lookup id binds)
 
+expandExpr binds l@(Let (NonRec b bexpr) expr) = do
+  (signal_decls, statements, arg_signals, res_signals) <- expandExpr binds bexpr
+  let binds' = (b, res_signals) : binds
+  (signal_decls', statements', arg_signals', res_signals') <- expandExpr binds' expr
+  return (
+    signal_decls ++ signal_decls',
+    statements ++ statements',
+    arg_signals',
+    res_signals')
+
 expandExpr binds app@(App _ _) = do
-  let ((Var f), args) = collectArgs app
-  if isTupleConstructor f 
-    then
-      expandBuildTupleExpr binds args
-    else
+  -- Is this a data constructor application?
+  case CoreUtils.exprIsConApp_maybe app of
+    -- Is this a tuple construction?
+    Just (dc, args) -> if DataCon.isTupleCon dc 
+      then
+        expandBuildTupleExpr binds (dataConAppArgs dc args)
+      else
+        error "Data constructors other than tuples not supported"
+    otherise ->
+      -- Normal function application, should map to a component instantiation
+      let ((Var f), args) = collectArgs app in
       expandApplicationExpr binds (CoreUtils.exprType app) f args
 
 expandExpr binds expr@(Case (Var v) b _ alts) =
@@ -248,17 +186,16 @@ expandExpr binds expr =
 
 -- Expands the construction of a tuple into VHDL
 expandBuildTupleExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
+  [(CoreBndr, SignalNameMap)] 
                                          -- A list of bindings in effect
   -> [CoreExpr]                          -- A list of expressions to put in the tuple
-  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
+  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
                                          -- See expandExpr
 expandBuildTupleExpr binds args = do
   -- Split the tuple constructor arguments into types and actual values.
-  let (_, vals) = splitTupleConstructorArgs args
   -- Expand each of the values in the tuple
   (signals_declss, statementss, arg_signalss, res_signals) <-
-    (Monad.liftM List.unzip4) $ mapM (expandExpr binds) vals
+    (Monad.liftM List.unzip4) $ mapM (expandExpr binds) args
   if any (not . null) arg_signalss
     then error "Putting high order functions in tuples not supported"
     else
@@ -272,12 +209,12 @@ expandBuildTupleExpr binds args = do
 -- and has a single alternative. This simple form currently allows only for
 -- unpacking tuple variables.
 expandSingleAltCaseExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
+  [(CoreBndr, SignalNameMap)] 
                             -- A list of bindings in effect
   -> Var.Var                -- The scrutinee
   -> CoreBndr               -- The binder to bind the scrutinee to
   -> CoreAlt                -- The single alternative
-  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
+  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
                                          -- See expandExpr
 
 expandSingleAltCaseExpr binds v b alt@(DataAlt datacon, bind_vars, expr) =
@@ -305,25 +242,25 @@ expandSingleAltCaseExpr _ _ _ alt =
 
 -- Expands the application of argument to a function into VHDL
 expandApplicationExpr ::
-  [(CoreBndr, SignalNameMap AST.VHDLId)] 
+  [(CoreBndr, SignalNameMap)] 
                                          -- A list of bindings in effect
   -> Type                                -- The result type of the function call
   -> Var.Var                             -- The function to call
   -> [CoreExpr]                          -- A list of argumetns to apply to the function
-  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId], SignalNameMap AST.VHDLId)
+  -> VHDLState ( [AST.SigDec], [AST.ConcSm], [SignalNameMap], SignalNameMap)
                                          -- See expandExpr
 expandApplicationExpr binds ty f args = do
   let name = getOccString f
   -- Generate a unique name for the application
-  appname <- uniqueName ("app-" ++ name)
+  appname <- uniqueName ("app_" ++ name)
   -- Lookup the hwfunction to instantiate
-  HWFunction inports outport <- getHWFunc name
+  HWFunction vhdl_id inports outport <- getHWFunc name
   -- Expand each of the args, so each of them is reduced to output signals
   (arg_signal_decls, arg_statements, arg_res_signals) <- expandArgs binds args
   -- Bind each of the input ports to the expanded arguments
   let inmaps = concat $ zipWith createAssocElems inports arg_res_signals
   -- Create signal names for our result
-  let res_signal = getPortNameMapForTy (appname ++ "-out") ty
+  let res_signal = getPortNameMapForTy (appname ++ "_out") ty
   -- Create the corresponding signal declarations
   let signal_decls = mkSignalsFromMap res_signal
   -- Bind each of the output ports to our output signals
@@ -331,7 +268,7 @@ expandApplicationExpr binds ty f args = do
   -- Instantiate the component
   let component = AST.CSISm $ AST.CompInsSm
         (AST.unsafeVHDLBasicId appname)
-        (AST.IUEntity (AST.NSimple (AST.unsafeVHDLBasicId name)))
+        (AST.IUEntity (AST.NSimple vhdl_id))
         (AST.PMapAspect (inmaps ++ outmaps))
   -- Merge the generated declarations
   return (
@@ -343,11 +280,11 @@ expandApplicationExpr binds ty f args = do
 -- Creates a list of AssocElems (port map lines) that maps the given signals
 -- to the given ports.
 createAssocElems ::
-  SignalNameMap AST.VHDLId      -- The port names to bind to
-  -> SignalNameMap AST.VHDLId   -- The signals to bind to it
+  SignalNameMap      -- The port names to bind to
+  -> SignalNameMap   -- The signals to bind to it
   -> [AST.AssocElem]            -- The resulting port map lines
   
-createAssocElems (Signal port_id) (Signal signal_id) = 
+createAssocElems (Single (port_id, _)) (Single (signal_id, _)) = 
   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
 
 createAssocElems (Tuple ports) (Tuple signals) = 
@@ -367,20 +304,19 @@ mkSignalFromId id ty =
 
 -- Generates signal declarations for all the signals in the given map
 mkSignalsFromMap ::
-  SignalNameMap AST.VHDLId 
+  SignalNameMap 
   -> [AST.SigDec]
 
-mkSignalsFromMap (Signal id) =
-  -- TODO: This uses the bit type hardcoded
-  [mkSignalFromId id vhdl_bit_ty]
+mkSignalsFromMap (Single (id, ty)) =
+  [mkSignalFromId id ty]
 
 mkSignalsFromMap (Tuple signals) =
   concat $ map mkSignalsFromMap signals
 
 expandArgs :: 
-  [(CoreBndr, SignalNameMap AST.VHDLId)] -- A list of bindings in effect
+  [(CoreBndr, SignalNameMap)] -- A list of bindings in effect
   -> [CoreExpr]                          -- The arguments to expand
-  -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap AST.VHDLId])  
+  -> VHDLState ([AST.SigDec], [AST.ConcSm], [SignalNameMap])  
                                          -- The resulting signal declarations,
                                          -- component instantiations and a
                                          -- VHDLName for each of the
@@ -399,38 +335,22 @@ expandArgs binds (e:exprs) = do
 
 expandArgs _ [] = return ([], [], [])
 
--- Is the given name a (binary) tuple constructor
-isTupleConstructor :: Var.Var -> Bool
-isTupleConstructor var =
-  Name.isWiredInName name
-  && Name.nameModule name == tuple_mod
-  && (Name.occNameString $ Name.nameOccName name) == "(,)"
-  where
-    name = Var.varName var
-    mod = nameModule name
-    tuple_mod = Module.mkModule (Module.stringToPackageId "ghc-prim") (Module.mkModuleName "GHC.Tuple")
-
--- Split arguments into type arguments and value arguments This is probably
--- not really sufficient (not sure if Types can actually occur as value
--- arguments...)
-splitTupleConstructorArgs :: [CoreExpr] -> ([CoreExpr], [CoreExpr])
-splitTupleConstructorArgs (e:es) =
-  case e of
-    Type t     -> (e:tys, vals)
-    otherwise  -> (tys, e:vals)
+-- Extract the arguments from a data constructor application (that is, the
+-- normal args, leaving out the type args).
+dataConAppArgs :: DataCon -> [CoreExpr] -> [CoreExpr]
+dataConAppArgs dc args =
+    drop tycount args
   where
-    (tys, vals) = splitTupleConstructorArgs es
-
-splitTupleConstructorArgs [] = ([], [])
+    tycount = length $ DataCon.dataConAllTyVars dc
 
 mapOutputPorts ::
-  SignalNameMap AST.VHDLId      -- The output portnames of the component
-  -> SignalNameMap AST.VHDLId   -- The output portnames and/or signals to map these to
+  SignalNameMap      -- The output portnames of the component
+  -> SignalNameMap   -- The output portnames and/or signals to map these to
   -> [AST.AssocElem]            -- The resulting output ports
 
 -- Map the output port of a component to the output port of the containing
 -- entity.
-mapOutputPorts (Signal portname) (Signal signalname) =
+mapOutputPorts (Single (portname, _)) (Single (signalname, _)) =
   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
 
 -- Map matching output ports in the tuple
@@ -445,28 +365,47 @@ getArchitecture (Rec _) = error "Recursive binders not supported"
 
 getArchitecture (NonRec var expr) = do
   let name = (getOccString var)
-  HWFunction inports outport <- getHWFunc name
+  HWFunction vhdl_id inports outport <- getHWFunc name
   sess <- State.get
   (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
   let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
   let outport_assigns = createSignalAssignments outport res_signal
   return $ AST.ArchBody
     (AST.unsafeVHDLBasicId "structural")
-    -- Use unsafe for now, to prevent pulling in ForSyDe error handling
-    (AST.NSimple (AST.unsafeVHDLBasicId name))
+    (AST.NSimple vhdl_id)
     (map AST.BDISD signal_decls)
     (inport_assigns ++ outport_assigns ++ statements)
 
+-- Generate a VHDL entity declaration for the given function
+getEntity :: HWFunction -> AST.EntityDec  
+getEntity (HWFunction vhdl_id inports outport) = 
+  AST.EntityDec vhdl_id ports
+  where
+    ports = 
+      (concat $ map (mkIfaceSigDecs AST.In) inports)
+      ++ mkIfaceSigDecs AST.Out outport
+
+mkIfaceSigDecs ::
+  AST.Mode                        -- The port's mode (In or Out)
+  -> SignalNameMap        -- The ports to generate a map for
+  -> [AST.IfaceSigDec]            -- The resulting ports
+  
+mkIfaceSigDecs mode (Single (port_id, ty)) =
+  [AST.IfaceSigDec port_id mode ty]
+
+mkIfaceSigDecs mode (Tuple ports) =
+  concat $ map (mkIfaceSigDecs mode) ports
+
 -- Create concurrent assignments of one map of signals to another. The maps
 -- should have a similar form.
 createSignalAssignments ::
-  SignalNameMap AST.VHDLId         -- The signals to assign to
-  -> SignalNameMap AST.VHDLId      -- The signals to assign
+  SignalNameMap         -- The signals to assign to
+  -> SignalNameMap      -- The signals to assign
   -> [AST.ConcSm]                  -- The resulting assignments
 
 -- A simple assignment of one signal to another (greatly complicated because
 -- signal assignments can be conditional with multiple conditions in VHDL).
-createSignalAssignments (Signal dst) (Signal src) =
+createSignalAssignments (Single (dst, _)) (Single (src, _)) =
     [AST.CSSASm assign]
   where
     src_name  = AST.NSimple src
@@ -481,32 +420,37 @@ createSignalAssignments (Tuple dsts) (Tuple srcs) =
 createSignalAssignments dst src =
   error $ "Non matching source and destination: " ++ show dst ++ "\nand\n" ++  show src
 
-data SignalNameMap t =
-  Tuple [SignalNameMap t]
-  | Signal  t
+type SignalNameMap = HsValueMap (AST.VHDLId, AST.TypeMark)
+
+-- | A datatype that maps each of the single values in a haskell structure to
+-- a mapto. The map has the same structure as the haskell type mapped, ie
+-- nested tuples etc.
+data HsValueMap mapto =
+  Tuple [HsValueMap mapto]
+  | Single mapto
   deriving (Show)
 
 -- Generate a port name map (or multiple for tuple types) in the given direction for
 -- each type given.
-getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap AST.VHDLId]
+getPortNameMapForTys :: String -> Int -> [Type] -> [SignalNameMap]
 getPortNameMapForTys prefix num [] = [] 
 getPortNameMapForTys prefix num (t:ts) =
   (getPortNameMapForTy (prefix ++ show num) t) : getPortNameMapForTys prefix (num + 1) ts
 
-getPortNameMapForTy :: String -> Type -> SignalNameMap AST.VHDLId
+getPortNameMapForTy :: String -> Type -> SignalNameMap
 getPortNameMapForTy name ty =
   if (TyCon.isTupleTyCon tycon) then
     -- Expand tuples we find
     Tuple (getPortNameMapForTys name 0 args)
   else -- Assume it's a type constructor application, ie simple data type
-    -- TODO: Add type?
-    Signal (AST.unsafeVHDLBasicId name)
+    Single ((AST.unsafeVHDLBasicId name), (vhdl_ty ty))
   where
     (tycon, args) = Type.splitTyConApp ty 
 
 data HWFunction = HWFunction { -- A function that is available in hardware
-  inPorts   :: [SignalNameMap AST.VHDLId],
-  outPort   :: SignalNameMap AST.VHDLId
+  vhdlId    :: AST.VHDLId,
+  inPorts   :: [SignalNameMap],
+  outPort   :: SignalNameMap
   --entity    :: AST.EntityDec
 } deriving (Show)
 
@@ -517,9 +461,9 @@ mkHWFunction ::
   -> VHDLState (String, HWFunction)          -- The name of the function and its interface
 
 mkHWFunction (NonRec var expr) =
-    return (name, HWFunction inports outport)
+    return (name, HWFunction (mkVHDLId name) inports outport)
   where
-    name = (getOccString var)
+    name = getOccString var
     ty = CoreUtils.exprType expr
     (fargs, res) = Type.splitFunTys ty
     args = if length fargs == 1 then fargs else (init fargs)
@@ -562,7 +506,7 @@ uniqueName :: String -> VHDLState String
 uniqueName name = do
   count <- State.gets nameCount -- Get the funcs element from the session
   State.modify (\s -> s {nameCount = count + 1})
-  return $ name ++ "-" ++ (show count)
+  return $ name ++ "_" ++ (show count)
 
 -- Shortcut
 mkVHDLId :: String -> AST.VHDLId
@@ -570,13 +514,31 @@ mkVHDLId = AST.unsafeVHDLBasicId
 
 builtin_funcs = 
   [ 
-    ("hwxor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwand", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwor", HWFunction [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwnot", HWFunction [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
+    ("hwxor", HWFunction (mkVHDLId "hwxor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+    ("hwand", HWFunction (mkVHDLId "hwand") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+    ("hwor", HWFunction (mkVHDLId "hwor") [Single (mkVHDLId "a", vhdl_bit_ty), Single (mkVHDLId "b", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty))),
+    ("hwnot", HWFunction (mkVHDLId "hwnot") [Single (mkVHDLId "i", vhdl_bit_ty)] (Single (mkVHDLId "o", vhdl_bit_ty)))
   ]
 
 vhdl_bit_ty :: AST.TypeMark
 vhdl_bit_ty = AST.unsafeVHDLBasicId "Bit"
 
+-- Translate a Haskell type to a VHDL type
+vhdl_ty :: Type -> 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
+vhdl_ty_maybe :: Type -> Maybe AST.TypeMark
+vhdl_ty_maybe ty =
+  case Type.splitTyConApp_maybe ty of
+    Just (tycon, args) ->
+      let name = TyCon.tyConName tycon in
+        -- TODO: Do something more robust than string matching
+        case getOccString name of
+          "Bit"      -> Just vhdl_bit_ty
+          otherwise  -> Nothing
+    otherwise -> Nothing
+
 -- vim: set ts=8 sw=2 sts=2 expandtab: