X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Translator.hs;h=4992d1cca7910940f4c1cfc6cc22cdf686ca143b;hb=a628d8d874df6af54c6d4f766012bac117eea037;hp=78b1466e4efa026cfa95c11a73e97f72bc8f0c61;hpb=698e8d4deb062bca9b6a0452f228f6e8e9cb1c6d;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 78b1466..4992d1c 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -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)
@@ -49,6 +50,7 @@ main =
           -- Turn bind into VHDL
           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
@@ -106,7 +108,7 @@ getPortMapEntry ::
   
 -- 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 (Signal portname _) (Signal signame _) = 
   (Just portname) AST.:=>: (AST.ADName (AST.NSimple signame))
 
 getInstantiations ::
@@ -206,7 +208,7 @@ expandExpr ::
                                          -- 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
@@ -224,10 +226,10 @@ expandExpr binds lam@(Lam b expr) = do
           res_signal')
 
 expandExpr binds (Var id) =
-  return ([], [], [], Signal signal_id)
+  return ([], [], [], Signal signal_id ty)
   where
     -- Lookup the id in our binds map
-    Signal signal_id = Maybe.fromMaybe
+    Signal signal_id ty = Maybe.fromMaybe
       (error $ "Argument " ++ getOccString id ++ "is unknown")
       (lookup id binds)
 
@@ -329,7 +331,7 @@ expandApplicationExpr ::
 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 vhdl_id inports outport <- getHWFunc name
   -- Expand each of the args, so each of them is reduced to output signals
@@ -337,7 +339,7 @@ expandApplicationExpr binds ty f args = do
   -- 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
@@ -361,7 +363,7 @@ createAssocElems ::
   -> SignalNameMap   -- The signals to bind to it
   -> [AST.AssocElem]            -- The resulting port map lines
   
-createAssocElems (Signal port_id) (Signal signal_id) = 
+createAssocElems (Signal port_id _) (Signal signal_id _) = 
   [(Just port_id) AST.:=>: (AST.ADName (AST.NSimple signal_id))]
 
 createAssocElems (Tuple ports) (Tuple signals) = 
@@ -384,9 +386,8 @@ mkSignalsFromMap ::
   SignalNameMap 
   -> [AST.SigDec]
 
-mkSignalsFromMap (Signal id) =
-  -- TODO: This uses the bit type hardcoded
-  [mkSignalFromId id vhdl_bit_ty]
+mkSignalsFromMap (Signal id ty) =
+  [mkSignalFromId id ty]
 
 mkSignalsFromMap (Tuple signals) =
   concat $ map mkSignalsFromMap signals
@@ -444,7 +445,7 @@ mapOutputPorts ::
 
 -- Map the output port of a component to the output port of the containing
 -- entity.
-mapOutputPorts (Signal portname) (Signal signalname) =
+mapOutputPorts (Signal portname _) (Signal signalname _) =
   [(Just portname) AST.:=>: (AST.ADName (AST.NSimple signalname))]
 
 -- Map matching output ports in the tuple
@@ -484,9 +485,8 @@ mkIfaceSigDecs ::
   -> SignalNameMap        -- The ports to generate a map for
   -> [AST.IfaceSigDec]            -- The resulting ports
   
-mkIfaceSigDecs mode (Signal port_id) =
-  -- TODO: Remove hardcoded type
-  [AST.IfaceSigDec port_id mode vhdl_bit_ty]
+mkIfaceSigDecs mode (Signal port_id ty) =
+  [AST.IfaceSigDec port_id mode ty]
 
 mkIfaceSigDecs mode (Tuple ports) =
   concat $ map (mkIfaceSigDecs mode) ports
@@ -500,7 +500,7 @@ createSignalAssignments ::
 
 -- 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 (Signal dst _) (Signal src _) =
     [AST.CSSASm assign]
   where
     src_name  = AST.NSimple src
@@ -517,7 +517,7 @@ createSignalAssignments dst src =
 
 data SignalNameMap =
   Tuple [SignalNameMap]
-  | Signal AST.VHDLId
+  | Signal AST.VHDLId AST.TypeMark   -- A signal (or port) of the given (VDHL) type
   deriving (Show)
 
 -- Generate a port name map (or multiple for tuple types) in the given direction for
@@ -533,8 +533,7 @@ getPortNameMapForTy name ty =
     -- 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)
+    Signal (AST.unsafeVHDLBasicId name) (vhdl_ty ty)
   where
     (tycon, args) = Type.splitTyConApp ty 
 
@@ -597,7 +596,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
@@ -605,13 +604,31 @@ mkVHDLId = AST.unsafeVHDLBasicId
 
 builtin_funcs = 
   [ 
-    ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwand", HWFunction (mkVHDLId "hwand") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwor", HWFunction (mkVHDLId "hwor") [Signal $ mkVHDLId "a", Signal $ mkVHDLId "b"] (Signal $ mkVHDLId "o")),
-    ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal $ mkVHDLId "i"] (Signal $ mkVHDLId "o"))
+    ("hwxor", HWFunction (mkVHDLId "hwxor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
+    ("hwand", HWFunction (mkVHDLId "hwand") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
+    ("hwor", HWFunction (mkVHDLId "hwor") [Signal (mkVHDLId "a") vhdl_bit_ty, Signal (mkVHDLId "b") vhdl_bit_ty] (Signal (mkVHDLId "o") vhdl_bit_ty)),
+    ("hwnot", HWFunction (mkVHDLId "hwnot") [Signal (mkVHDLId "i") vhdl_bit_ty] (Signal (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: