Clean up the code a bit more.

This removes some unused parts, makes some naming a bit more consistent
and moves some code around.

Additionally, this disables vector function generating for now, since that
would create a dependency loop. Next up is changing the structure of that.

diff --git a/Constants.hs b/Constants.hs
index 61889af964ed1a8c2c9e72cd0e094548515e56a9..cf77025771f11cc7ce5730eb49192ec5a33f71bc 100644 (file)
--- a/Constants.hs
+++ b/Constants.hs
@@ -161,6 +161,10 @@ copyId = AST.unsafeVHDLBasicId "copy"
 -- VHDL type marks
 ------------------
 
 -- VHDL type marks
 ------------------
 

+-- | The Bit type mark
+bitTM :: AST.TypeMark
+bitTM = AST.unsafeVHDLBasicId "Bit"
+

 -- | Stardard logic type mark
 std_logicTM :: AST.TypeMark
 std_logicTM = AST.unsafeVHDLBasicId "std_logic"
 -- | Stardard logic type mark
 std_logicTM :: AST.TypeMark
 std_logicTM = AST.unsafeVHDLBasicId "std_logic"


@@ -179,4 +183,4 @@ naturalTM = AST.unsafeVHDLBasicId "natural"
 
 -- | integer TypeMark
 integerTM :: AST.TypeMark
 
 -- | integer TypeMark
 integerTM :: AST.TypeMark

-integerTM = AST.unsafeVHDLBasicId "integer"
\ No newline at end of file
+integerTM = AST.unsafeVHDLBasicId "integer"

diff --git a/CoreTools.hs b/CoreTools.hs
index 3c26793c8c804ce7f9dd7262851565398638195d..b08f3ce9897d65b607c14a7ed3db2ed8eca195ad 100644 (file)
--- a/CoreTools.hs
+++ b/CoreTools.hs
@@ -142,3 +142,8 @@ is_applicable expr = is_fun expr || is_poly expr
 -- Does the given CoreExpr have any free type vars?
 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)
 -- Does the given CoreExpr have any free type vars?
 has_free_tyvars :: CoreSyn.CoreExpr -> Bool
 has_free_tyvars = not . VarSet.isEmptyVarSet . (CoreFVs.exprSomeFreeVars Var.isTyVar)

+
+-- Turns a Var CoreExpr into the Id inside it. Will of course only work for
+-- simple Var CoreExprs, not complexer ones.
+exprToVar :: CoreSyn.CoreExpr -> Var.Id
+exprToVar (CoreSyn.Var id) = id

diff --git a/Generate.hs b/Generate.hs
index 22795440fe81daf4ecfc7ba26546ae20ca695a88..654dc8625cbc864ce49c15a9c7963d05419bda80 100644 (file)
--- a/Generate.hs
+++ b/Generate.hs
@@ -41,8 +41,8 @@ genMapCall ::
 genMapCall entity [arg, res] = genSm
   where
     -- Setup the generate scheme
 genMapCall entity [arg, res] = genSm
   where
     -- Setup the generate scheme

-    len         = getVectorLen res
-    label       = mkVHDLExtId ("mapVector" ++ (bndrToString res))
+    len         = (tfvec_len . Var.varType) res
+    label       = mkVHDLExtId ("mapVector" ++ (varToString res))

     nPar        = AST.unsafeVHDLBasicId "n"
     range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
     genScheme   = AST.ForGn nPar range
     nPar        = AST.unsafeVHDLBasicId "n"
     range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
     genScheme   = AST.ForGn nPar range


@@ -51,13 +51,13 @@ genMapCall entity [arg, res] = genSm
     argport     = map (Monad.liftM fst) (ent_args entity)
     resport     = (Monad.liftM fst) (ent_res entity)
     -- Assign the ports
     argport     = map (Monad.liftM fst) (ent_args entity)
     resport     = (Monad.liftM fst) (ent_res entity)
     -- Assign the ports

-    inport      = mkAssocElemIndexed (head argport) (bndrToString arg) nPar
-    outport     = mkAssocElemIndexed resport (bndrToString res) nPar
+    inport      = mkAssocElemIndexed (head argport) (varToString arg) nPar
+    outport     = mkAssocElemIndexed resport (varToString res) nPar

     clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
     portassigns = Maybe.catMaybes [inport,outport,clk_port]
     -- Generate the portmap
     mapLabel    = "map" ++ (AST.fromVHDLId entity_id)
     clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
     portassigns = Maybe.catMaybes [inport,outport,clk_port]
     -- Generate the portmap
     mapLabel    = "map" ++ (AST.fromVHDLId entity_id)

-    compins     = genComponentInst mapLabel entity_id portassigns
+    compins     = mkComponentInst mapLabel entity_id portassigns

     -- Return the generate functions
     genSm       = AST.GenerateSm label genScheme [] [compins]
 
     -- Return the generate functions
     genSm       = AST.GenerateSm label genScheme [] [compins]
 


@@ -248,4 +248,4 @@ genUnconsVectorFuns elemTM vectorTM  =
              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
                                           (AST.PrimName $ AST.NSimple aPar)])
     -- return res
              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
                                           (AST.PrimName $ AST.NSimple aPar)])
     -- return res

-    copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
\ No newline at end of file
+    copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)

diff --git a/VHDL.hs b/VHDL.hs
index 1f08abe1016b9b251a84b0eb27cbb29d60e3cf15..da35a9018b9de03665f8f19fedb12a740d504210 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -18,14 +18,14 @@ import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- GHC API
 import CoreSyn
 
 -- GHC API
 import CoreSyn

-import qualified Type
+--import qualified Type

 import qualified Name
 import qualified Var
 import qualified Id
 import qualified IdInfo
 import qualified TyCon
 import qualified DataCon
 import qualified Name
 import qualified Var
 import qualified Id
 import qualified IdInfo
 import qualified TyCon
 import qualified DataCon

-import qualified CoreSubst
+--import qualified CoreSubst

 import qualified CoreUtils
 import Outputable ( showSDoc, ppr )
 
 import qualified CoreUtils
 import Outputable ( showSDoc, ppr )
 


@@ -109,7 +109,7 @@ createEntity (fname, expr) = do
       -- There must be a let at top level 
       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
       res' <- mkMap res
       -- There must be a let at top level 
       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
       res' <- mkMap res

-      let vhdl_id = mkVHDLBasicId $ bndrToString fname ++ "_" ++ varToStringUniq fname
+      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'
       let ent_decl' = createEntityAST vhdl_id args' res'
       let AST.EntityDec entity_id _ = ent_decl' 
       let signature = Entity entity_id args' res'


@@ -127,7 +127,7 @@ createEntity (fname, expr) = do
         --  (error $ "Signal not found in the name map? This should not happen!")
         --  (lookup id sigmap)
         --  Assume the bndr has a valid VHDL id already
         --  (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
+        id = varToVHDLId bndr

         ty = Var.varType bndr
       in
         if True -- isPortSigUse $ sigUse info
         ty = Var.varType bndr
       in
         if True -- isPortSigUse $ sigUse info


@@ -156,7 +156,7 @@ createEntityAST vhdl_id args res =
     -- Add a clk port if we have state
     clk_port = if True -- hasState hsfunc
       then
     -- Add a clk port if we have state
     clk_port = if True -- hasState hsfunc
       then

-        Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logic_ty
+        Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM

       else
         Nothing
 
       else
         Nothing
 


@@ -250,7 +250,7 @@ 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
 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)
+    return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)

   else
     return Nothing
 
   else
     return Nothing
 


@@ -296,24 +296,24 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
       -- functions.
       funSignatures <- getA vsNameTable
       signatures <- getA vsSignatures
       -- functions.
       funSignatures <- getA vsNameTable
       signatures <- getA vsSignatures

-      case (Map.lookup (bndrToString f) funSignatures) of
+      case (Map.lookup (varToString f) funSignatures) of

         Just (arg_count, builder) ->
           if length valargs == arg_count then
             case builder of
               Left funBuilder ->
                 let
         Just (arg_count, builder) ->
           if length valargs == arg_count then
             case builder of
               Left funBuilder ->
                 let

-                  sigs = map (varToVHDLExpr.varBndr) valargs
+                  sigs = map (varToVHDLExpr.exprToVar) valargs

                   func = funBuilder sigs
                   src_wform = AST.Wform [AST.WformElem func Nothing]
                   func = funBuilder sigs
                   src_wform = AST.Wform [AST.WformElem func Nothing]

-                  dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+                  dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))

                   assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
                 in
                   return [AST.CSSASm assign]
               Right genBuilder ->
                 let
                   assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
                 in
                   return [AST.CSSASm assign]
               Right genBuilder ->
                 let

-                  sigs = map varBndr valargs
+                  sigs = map exprToVar valargs

                   signature = Maybe.fromMaybe
                   signature = Maybe.fromMaybe

-                    (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!") 
+                    (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!") 

                     (Map.lookup (head sigs) signatures)
                   arg = tail sigs
                   genSm = genBuilder signature (arg ++ [bndr])  
                     (Map.lookup (head sigs) signatures)
                   arg = tail sigs
                   genSm = genBuilder signature (arg ++ [bndr])  


@@ -327,17 +327,17 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
       -- have and which can be turned into a component instantiation.
       let  
         signature = Maybe.fromMaybe 
       -- have and which can be turned into a component instantiation.
       let  
         signature = Maybe.fromMaybe 

-          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 
+          (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") 

           (Map.lookup f signatures)
         entity_id = ent_id signature
           (Map.lookup f signatures)
         entity_id = ent_id signature

-        label = "comp_ins_" ++ bndrToString bndr
+        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
         -- 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 [genComponentInst label entity_id portmaps]
+          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
     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


@@ -371,178 +371,3 @@ mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)]))
 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
 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

-
--- 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 ty = do
-  -- Ensure that the type is generated (but throw away it's VHDLId)
-  vhdl_ty ty
-  -- Get the types map, lookup and unpack the VHDL TypeDef
-  types <- getA vsTypes
-  case Map.lookup (OrdType ty) types of
-    Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
-    _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
-
-{-
-mkConcSm sigs (UncondDef src dst) _ = do
-  src_expr <- vhdl_expr src
-  let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
-  let dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
-  let assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
-  return $ AST.CSSASm assign
-  where
-    vhdl_expr (Left id) = return $ mkIdExpr sigs id
-    vhdl_expr (Right expr) =
-      case expr of
-        (EqLit id lit) ->
-          return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
-        (Literal lit Nothing) ->
-          return $ AST.PrimLit lit
-        (Literal lit (Just ty)) -> do
-          -- 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 <- 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
-        (Eq a b) ->
-         return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
-
-mkConcSm sigs (CondDef cond true false dst) _ =
-  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)
-  in
-    return $ 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
-
--- | 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)
--}
-
--- Translate a Haskell type to a VHDL type
-vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
-vhdl_ty ty = do
-  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)
-        Map.lookup name builtin_types
-  -- If not a builtin type, try the custom types
-  let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
-  case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
-    -- Found a type, return it
-    Just t -> return t
-    -- No type yet, try to construct it
-    Nothing -> do
-      newty_maybe <- (construct_vhdl_ty ty)
-      case newty_maybe of
-        Just (ty_id, ty_def) -> do
-          -- TODO: Check name uniqueness
-          modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
-          return ty_id
-        Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr 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 ty = do
-  case Type.splitTyConApp_maybe ty of
-    Just (tycon, args) -> do
-      let name = Name.getOccString (TyCon.tyConName tycon)
-      case name of
-        "TFVec" -> do
-          res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
-          return $ Just $ (Arrow.second Right) res
-        -- "SizedWord" -> do
-        --   res <- mk_vector_ty (sized_word_len ty) ty
-        --   return $ Just $ (Arrow.second Left) res
-        "RangedWord" -> do 
-          res <- mk_natural_ty 0 (ranged_word_bound ty)
-          return $ Just $ (Arrow.second Right) res
-        -- Create a custom type from this tycon
-        otherwise -> mk_tycon_ty tycon args
-    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 args =
-  case TyCon.tyConDataCons tycon of
-    -- Not an algebraic type
-    [] -> error $ "Only custom algebraic types are supported: " ++  (showSDoc $ ppr tycon)
-    [dc] -> do
-      let arg_tys = DataCon.dataConRepArgTys dc
-      -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
-      -- violation? Or does it only mean not to apply it again to the same
-      -- subject?
-      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
-      elem_tys <- mapM vhdl_ty real_arg_tys
-      let elems = zipWith AST.ElementDec recordlabels elem_tys
-      -- For a single construct datatype, build a record with one field for
-      -- 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 ty_def = AST.TDR $ AST.RecordTypeDef elems
-      return $ Just (ty_id, Left ty_def)
-    dcs -> error $ "Only single constructor datatypes supported: " ++  (showSDoc $ ppr tycon)
-  where
-    -- Create a subst that instantiates all types passed to the tycon
-    -- TODO: I'm not 100% sure that this is the right way to do this. It seems
-    -- to work so far, though..
-    tyvars = TyCon.tyConTyVars tycon
-    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
-    
--- | Create a VHDL vector type
-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.
-
-mk_vector_ty len el_ty = do
-  elem_types_map <- getA vsElemTypes
-  el_ty_tm <- vhdl_ty el_ty
-  let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
-  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
-  let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
-  case existing_elem_ty of
-    Just t -> do
-      let ty_def = AST.SubtypeIn t (Just range)
-      return (ty_id, ty_def)
-    Nothing -> do
-      let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
-      let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
-      modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
-      modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id)) 
-      let ty_def = AST.SubtypeIn vec_id (Just range)
-      return (ty_id, ty_def)
-
-mk_natural_ty ::
-  Int -- ^ The minimum bound (> 0)
-  -> Int -- ^ The maximum bound (> minimum bound)
-  -> VHDLState (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))
-  let ty_def = AST.SubtypeIn naturalTM (Just range)
-  return (ty_id, ty_def)
\ No newline at end of file

diff --git a/VHDLTools.hs b/VHDLTools.hs
index cc80e92ad60e00fa0c5e90c51e66d95c215c77c2..232df43a7b86c30d05cab1d6409808aeef7e5c38 100644 (file)
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -5,6 +5,9 @@ import qualified Maybe
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Data.List as List
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad

+import qualified Control.Arrow as Arrow
+import qualified Data.Monoid as Monoid
+import Data.Accessor

 
 -- ForSyDe
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- ForSyDe
 import qualified ForSyDe.Backend.VHDL.AST as AST


@@ -16,11 +19,19 @@ import qualified OccName
 import qualified Var
 import qualified Id
 import qualified TyCon
 import qualified Var
 import qualified Id
 import qualified TyCon

+import qualified Type

 import qualified DataCon
 import qualified DataCon

+import qualified CoreSubst

 
 -- Local imports
 import VHDLTypes
 import CoreTools
 
 -- Local imports
 import VHDLTypes
 import CoreTools

+import Pretty
+import Constants
+
+-----------------------------------------------------------------------------
+-- Functions to generate concurrent statements
+-----------------------------------------------------------------------------

 
 -- Create an unconditional assignment statement
 mkUncondAssign ::
 
 -- Create an unconditional assignment statement
 mkUncondAssign ::


@@ -58,22 +69,12 @@ mkAssign dst cond false_expr =
       Nothing -> []
     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
     dst_name  = case dst of
       Nothing -> []
     false_wform = AST.Wform [AST.WformElem false_expr Nothing]
     dst_name  = case dst of

-      Left bndr -> AST.NSimple (bndrToVHDLId bndr)
+      Left bndr -> AST.NSimple (varToVHDLId bndr)

       Right name -> name
     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
   in
     AST.CSSASm assign
 
       Right name -> name
     assign    = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
   in
     AST.CSSASm assign
 

--- 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 $ bndrToVHDLId bndr
-    sel_suffix = AST.SSimple $ label
-  in
-    AST.NSelected $ sel_prefix AST.:.: sel_suffix 
-

 mkAssocElems :: 
   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
   -> CoreSyn.CoreBndr           -- | The binder in which to store the result
 mkAssocElems :: 
   [CoreSyn.CoreExpr]            -- | The argument that are applied to function
   -> CoreSyn.CoreBndr           -- | The binder in which to store the result


@@ -91,7 +92,7 @@ mkAssocElems args res entity =
     -- Extract the id part from the (id, type) tuple
     ports     = map (Monad.liftM fst) (res_port : arg_ports)
     -- Translate signal numbers into names
     -- Extract the id part from the (id, type) tuple
     ports     = map (Monad.liftM fst) (res_port : arg_ports)
     -- Translate signal numbers into names

-    sigs      = (bndrToString res : map (bndrToString.varBndr) args)
+    sigs      = (varToString res : map (varToString.exprToVar) args)

 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
 
 -- | Create an VHDL port -> signal association
 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem


@@ -104,6 +105,19 @@ mkAssocElemIndexed (Just port) signal index = Just $ Just port AST.:=>: (AST.ADN
                       (AST.NSimple (mkVHDLExtId signal)) [AST.PrimName $ AST.NSimple index])))
 mkAssocElemIndexed Nothing _ _ = Nothing
 
                       (AST.NSimple (mkVHDLExtId signal)) [AST.PrimName $ AST.NSimple index])))
 mkAssocElemIndexed Nothing _ _ = Nothing
 

+mkComponentInst ::
+  String -- ^ The portmap label
+  -> AST.VHDLId -- ^ The entity name
+  -> [AST.AssocElem] -- ^ The port assignments
+  -> 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)
+
+-----------------------------------------------------------------------------
+-- Functions to generate VHDL Exprs
+-----------------------------------------------------------------------------
+

 -- Turn a variable reference into a AST expression
 varToVHDLExpr :: Var.Var -> AST.Expr
 varToVHDLExpr var = 
 -- Turn a variable reference into a AST expression
 varToVHDLExpr :: Var.Var -> AST.Expr
 varToVHDLExpr var = 


@@ -112,7 +126,7 @@ varToVHDLExpr var =
     -- This is a dataconstructor.
     -- Not a datacon, just another signal. Perhaps we should check for
     -- local/global here as well?
     -- 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 $ bndrToVHDLId var
+    Nothing -> AST.PrimName $ AST.NSimple $ varToVHDLId var

 
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it
 
 -- Turn a alternative constructor into an AST expression. For
 -- dataconstructors, this is only the constructor itself, not any arguments it


@@ -135,12 +149,31 @@ dataconToVHDLExpr dc = AST.PrimLit lit
       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 
       "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
       "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
 

--- 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
+-----------------------------------------------------------------------------
+-- Functions dealing with names, variables and ids
+-----------------------------------------------------------------------------
+
+-- Creates a VHDL Id from a binder
+varToVHDLId ::
+  CoreSyn.CoreBndr
+  -> AST.VHDLId
+varToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
+
+-- Extracts the binder name as a String
+varToString ::
+  CoreSyn.CoreBndr
+  -> String
+varToString = OccName.occNameString . Name.nameOccName . Var.varName
+
+-- Get the string version a Var's unique
+varToStringUniq :: Var.Var -> String
+varToStringUniq = show . Var.varUnique
+
+-- Extracts the string version of the name
+nameToString :: Name.Name -> String
+nameToString = OccName.occNameString . Name.nameOccName

 
 

--- Shortcut for 
+-- Shortcut for Basic VHDL Ids.

 -- Can only contain alphanumerics and underscores. The supplied string must be
 -- a valid basic id, otherwise an error value is returned. This function is
 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
 -- Can only contain alphanumerics and underscores. The supplied string must be
 -- a valid basic id, otherwise an error value is returned. This function is
 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for


@@ -172,65 +205,144 @@ mkVHDLExtId s =
     allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
     strip_invalid = filter (`elem` allowed)
 
     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
+-- 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 

 
 

--- Extracts the binder name as a String
-bndrToString ::
-  CoreSyn.CoreBndr
-  -> String
-bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
+-----------------------------------------------------------------------------
+-- Functions dealing with VHDL types
+-----------------------------------------------------------------------------

 
 

--- Get the string version a Var's unique
-varToStringUniq :: Var.Var -> String
-varToStringUniq = show . Var.varUnique
+-- | Maps the string name (OccName) of a type to the corresponding VHDL type,
+-- for a few builtin types.
+builtin_types = 
+  Map.fromList [
+    ("Bit", std_logicTM),
+    ("Bool", booleanTM) -- TysWiredIn.boolTy
+  ]

 
 

--- Extracts the string version of the name
-nameToString :: Name.Name -> String
-nameToString = OccName.occNameString . Name.nameOccName
+-- Translate a Haskell type to a VHDL type, generating a new type if needed.
+vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
+vhdl_ty ty = do
+  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)
+        Map.lookup name builtin_types
+  -- If not a builtin type, try the custom types
+  let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
+  case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+    -- Found a type, return it
+    Just t -> return t
+    -- No type yet, try to construct it
+    Nothing -> do
+      newty_maybe <- (construct_vhdl_ty ty)
+      case newty_maybe of
+        Just (ty_id, ty_def) -> do
+          -- TODO: Check name uniqueness
+          modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
+          return ty_id
+        Nothing -> error $ "Unsupported Haskell type: " ++ pprString ty

 
 

-recordlabels :: [AST.VHDLId]
-recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
+-- 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 ty = do
+  case Type.splitTyConApp_maybe ty of
+    Just (tycon, args) -> do
+      let name = Name.getOccString (TyCon.tyConName tycon)
+      case name of
+        "TFVec" -> do
+          res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
+          return $ Just $ (Arrow.second Right) res
+        -- "SizedWord" -> do
+        --   res <- mk_vector_ty (sized_word_len ty) ty
+        --   return $ Just $ (Arrow.second Left) res
+        "RangedWord" -> do 
+          res <- mk_natural_ty 0 (ranged_word_bound ty)
+          return $ Just $ (Arrow.second Right) res
+        -- Create a custom type from this tycon
+        otherwise -> mk_tycon_ty tycon args
+    Nothing -> return $ Nothing

 
 

-getVectorLen :: CoreSyn.CoreBndr -> Int
-getVectorLen bndr = len
-  where
-    ty = Var.varType bndr
-    len = tfvec_len ty
-    
-genComponentInst ::
-  String -- ^ The portmap label
-  -> AST.VHDLId -- ^ The entity name
-  -> [AST.AssocElem] -- ^ The port assignments
-  -> AST.ConcSm
-genComponentInst label entity_id portassigns = AST.CSISm compins
+-- | 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 args =
+  case TyCon.tyConDataCons tycon of
+    -- Not an algebraic type
+    [] -> error $ "Only custom algebraic types are supported: " ++ pprString tycon
+    [dc] -> do
+      let arg_tys = DataCon.dataConRepArgTys dc
+      -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
+      -- violation? Or does it only mean not to apply it again to the same
+      -- subject?
+      let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
+      elem_tys <- mapM vhdl_ty real_arg_tys
+      let elems = zipWith AST.ElementDec recordlabels elem_tys
+      -- For a single construct datatype, build a record with one field for
+      -- 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 ty_def = AST.TDR $ AST.RecordTypeDef elems
+      return $ Just (ty_id, Left ty_def)
+    dcs -> error $ "Only single constructor datatypes supported: " ++ pprString tycon

   where
   where

-    compins = AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portassigns)
+    -- Create a subst that instantiates all types passed to the tycon
+    -- TODO: I'm not 100% sure that this is the right way to do this. It seems
+    -- to work so far, though..
+    tyvars = TyCon.tyConTyVars tycon
+    subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
+    -- Generate a bunch of labels for fields of a record
+    recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']

 
 

--- | The VHDL Bit type
-bit_ty :: AST.TypeMark
-bit_ty = AST.unsafeVHDLBasicId "Bit"
+-- | Create a VHDL vector type
+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.

 
 

--- | The VHDL Boolean type
-bool_ty :: AST.TypeMark
-bool_ty = AST.unsafeVHDLBasicId "Boolean"
+mk_vector_ty len el_ty = do
+  elem_types_map <- getA vsElemTypes
+  el_ty_tm <- vhdl_ty el_ty
+  let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
+  let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
+  case existing_elem_ty of
+    Just t -> do
+      let ty_def = AST.SubtypeIn t (Just range)
+      return (ty_id, ty_def)
+    Nothing -> do
+      let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
+      let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
+      modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
+      --modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id)) 
+      let ty_def = AST.SubtypeIn vec_id (Just range)
+      return (ty_id, ty_def)

 
 

--- | The VHDL std_logic
-std_logic_ty :: AST.TypeMark
-std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
-  
-builtin_types = 
-  Map.fromList [
-    ("Bit", std_logic_ty),
-    ("Bool", bool_ty) -- TysWiredIn.boolTy
-  ]
+mk_natural_ty ::
+  Int -- ^ The minimum bound (> 0)
+  -> Int -- ^ The maximum bound (> minimum bound)
+  -> VHDLState (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))
+  let ty_def = AST.SubtypeIn naturalTM (Just range)
+  return (ty_id, ty_def)

 
 

-{- 
--- | Map a port specification of a builtin function to a VHDL Signal to put in
---   a VHDLSignalMap
-toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
-toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)
--}
+-- 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 ty = do
+  -- Ensure that the type is generated (but throw away it's VHDLId)
+  vhdl_ty ty
+  -- Get the types map, lookup and unpack the VHDL TypeDef
+  types <- getA vsTypes
+  case Map.lookup (OrdType ty) types of
+    Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
+    _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)