X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDLTools.hs;h=09796399b8e24576435e0155a6621cacba35f559;hb=51213c2cae12b73b46eaf607a0ca1a6586644d73;hp=232df43a7b86c30d05cab1d6409808aeef7e5c38;hpb=597f1b6823417f2c4cc54549f2a9d1b9f131893c;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDLTools.hs b/VHDLTools.hs
index 232df43..0979639 100644
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -8,6 +8,7 @@ import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow
 import qualified Data.Monoid as Monoid
 import Data.Accessor
+import Debug.Trace
 
 -- ForSyDe
 import qualified ForSyDe.Backend.VHDL.AST as AST
@@ -76,13 +77,13 @@ mkAssign dst cond false_expr =
     AST.CSSASm assign
 
 mkAssocElems :: 
-  [CoreSyn.CoreExpr]            -- | The argument that are applied to function
-  -> CoreSyn.CoreBndr           -- | The binder in which to store the result
+  [AST.Expr]                    -- | The argument that are applied to function
+  -> AST.VHDLName               -- | The binder in which to store the result
   -> Entity                     -- | The entity to map against.
   -> [AST.AssocElem]            -- | The resulting port maps
 mkAssocElems args res entity =
     -- Create the actual AssocElems
-    Maybe.catMaybes $ zipWith mkAssocElem ports sigs
+    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
@@ -90,20 +91,18 @@ mkAssocElems args res entity =
     arg_ports = ent_args entity
     res_port  = ent_res entity
     -- Extract the id part from the (id, type) tuple
-    ports     = map (Monad.liftM fst) (res_port : arg_ports)
+    ports     = map fst (res_port : arg_ports)
     -- Translate signal numbers into names
-    sigs      = (varToString res : map (varToString.exprToVar) args)
+    sigs      = (vhdlNameToVHDLExpr res : args)
 
 -- | 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 (mkVHDLExtId signal))) 
-mkAssocElem Nothing _ = Nothing
+mkAssocElem :: AST.VHDLId -> AST.Expr -> AST.AssocElem
+mkAssocElem port signal = Just port AST.:=>: (AST.ADExpr signal) 
 
 -- | Create an VHDL port -> signal association
-mkAssocElemIndexed :: Maybe AST.VHDLId -> String -> AST.VHDLId -> Maybe AST.AssocElem
-mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName 
-                      (AST.NSimple (mkVHDLExtId signal)) [AST.PrimName $ AST.NSimple index])))
-mkAssocElemIndexed Nothing _ _ = Nothing
+mkAssocElemIndexed :: AST.VHDLId -> AST.VHDLId -> AST.VHDLId -> AST.AssocElem
+mkAssocElemIndexed port signal index = Just port AST.:=>: (AST.ADName (AST.NIndexed (AST.IndexedName 
+                      (AST.NSimple signal) [AST.PrimName $ AST.NSimple index])))
 
 mkComponentInst ::
   String -- ^ The portmap label
@@ -112,7 +111,9 @@ mkComponentInst ::
   -> AST.ConcSm
 mkComponentInst label entity_id portassigns = AST.CSISm compins
   where
-    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portassigns)
+    -- We always have a clock port, so no need to map it anywhere but here
+    clk_port = mkAssocElem (mkVHDLExtId "clk") (idToVHDLExpr $ mkVHDLExtId "clk")
+    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect (portassigns ++ [clk_port]))
 
 -----------------------------------------------------------------------------
 -- Functions to generate VHDL Exprs
@@ -126,7 +127,29 @@ varToVHDLExpr var =
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
-    Nothing -> AST.PrimName $ AST.NSimple $ varToVHDLId var
+    -- Sadly so.. tfp decimals are types, not data constructors, but instances
+    -- should still be translated to integer literals. It is probebly not the
+    -- best solution to translate them here.
+    -- FIXME: Find a better solution for translating instances of tfp integers
+    Nothing -> 
+        let 
+          ty  = Var.varType var
+          res = case Type.splitTyConApp_maybe ty of
+                  Just (tycon, args) ->
+                    case Name.getOccString (TyCon.tyConName tycon) of
+                      "Dec" -> AST.PrimLit $ (show (eval_tfp_int ty))
+                      otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
+        in
+          res
+
+-- Turn a VHDLName into an AST expression
+vhdlNameToVHDLExpr = AST.PrimName
+
+-- Turn a VHDL Id into an AST expression
+idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
+
+-- Turn a Core expression into an AST expression
+exprToVHDLExpr = varToVHDLExpr . exprToVar
 
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
@@ -157,7 +180,13 @@ dataconToVHDLExpr dc = AST.PrimLit lit
 varToVHDLId ::
   CoreSyn.CoreBndr
   -> AST.VHDLId
-varToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
+varToVHDLId = mkVHDLExtId . varToString
+
+-- Creates a VHDL Name from a binder
+varToVHDLName ::
+  CoreSyn.CoreBndr
+  -> AST.VHDLName
+varToVHDLName = AST.NSimple . varToVHDLId
 
 -- Extracts the binder name as a String
 varToString ::
@@ -207,13 +236,17 @@ mkVHDLExtId s =
 
 -- Create a record field selector that selects the given label from the record
 -- stored in the given binder.
-mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
-mkSelectedName bndr label =
-  let 
-    sel_prefix = AST.NSimple $ varToVHDLId bndr
-    sel_suffix = AST.SSimple $ label
-  in
-    AST.NSelected $ sel_prefix AST.:.: sel_suffix 
+mkSelectedName :: AST.VHDLName -> AST.VHDLId -> AST.VHDLName
+mkSelectedName name label =
+   AST.NSelected $ name AST.:.: (AST.SSimple label) 
+
+-- Create an indexed name that selects a given element from a vector.
+mkIndexedName :: AST.VHDLName -> AST.Expr -> AST.VHDLName
+-- Special case for already indexed names. Just add an index
+mkIndexedName (AST.NIndexed (AST.IndexedName name indexes)) index =
+ AST.NIndexed (AST.IndexedName name (indexes++[index]))
+-- General case for other names
+mkIndexedName name index = AST.NIndexed (AST.IndexedName name [index])
 
 -----------------------------------------------------------------------------
 -- Functions dealing with VHDL types
@@ -224,11 +257,12 @@ mkSelectedName bndr label =
 builtin_types = 
   Map.fromList [
     ("Bit", std_logicTM),
-    ("Bool", booleanTM) -- TysWiredIn.boolTy
+    ("Bool", booleanTM), -- TysWiredIn.boolTy
+    ("Dec", integerTM)
   ]
 
 -- Translate a Haskell type to a VHDL type, generating a new type if needed.
-vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
+vhdl_ty :: Type.Type -> VHDLSession AST.TypeMark
 vhdl_ty ty = do
   typemap <- getA vsTypes
   let builtin_ty = do -- See if this is a tycon and lookup its name
@@ -251,7 +285,7 @@ vhdl_ty ty = do
         Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty
 
 -- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+construct_vhdl_ty :: Type.Type -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 construct_vhdl_ty ty = do
   case Type.splitTyConApp_maybe ty of
     Just (tycon, args) -> do
@@ -271,7 +305,7 @@ construct_vhdl_ty ty = do
     Nothing -> return $ Nothing
 
 -- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLSession (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
 mk_tycon_ty tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
@@ -288,7 +322,8 @@ mk_tycon_ty tycon args =
       -- each argument.
       -- TODO: Add argument type ids to this, to ensure uniqueness
       -- TODO: Special handling for tuples?
-      let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
+      let elem_names = concat $ map prettyShow elem_tys
+      let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) ++ elem_names
       let ty_def = AST.TDR $ AST.RecordTypeDef elems
       return $ Just (ty_id, Left ty_def)
     dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon
@@ -305,7 +340,7 @@ mk_tycon_ty tycon args =
 mk_vector_ty ::
   Int -- ^ The length of the vector
   -> Type.Type -- ^ The Haskell element type of the Vector
-  -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+  -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 
 mk_vector_ty len el_ty = do
   elem_types_map <- getA vsElemTypes
@@ -328,7 +363,7 @@ mk_vector_ty len el_ty = do
 mk_natural_ty ::
   Int -- ^ The minimum bound (> 0)
   -> Int -- ^ The maximum bound (> minimum bound)
-  -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
+  -> VHDLSession (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
 mk_natural_ty min_bound max_bound = do
   let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
   let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
@@ -337,7 +372,7 @@ mk_natural_ty min_bound max_bound = do
 
 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.
-getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
+getFieldLabels :: Type.Type -> VHDLSession [AST.VHDLId]
 getFieldLabels ty = do
   -- Ensure that the type is generated (but throw away it's VHDLId)
   vhdl_ty ty