Move type registration out of construct_vhdl_ty.

[matthijs/master-project/cλash.git] / VHDL.hs

diff --git a/VHDL.hs b/VHDL.hs
index 561c2790d5537bc56d4f5b12d6d9505b2f2a30fb..dad3aec2623867ec0c958a3810ac9ca5ff35ce34 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -22,12 +22,14 @@ import Debug.Trace
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- GHC API
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- GHC API

+import CoreSyn

 import qualified Type
 import qualified Name
 import qualified OccName
 import qualified Var
 import qualified TyCon
 import qualified Type
 import qualified Name
 import qualified OccName
 import qualified Var
 import qualified TyCon

-import qualified CoreSyn
+import qualified DataCon
+import qualified CoreSubst

 import Outputable ( showSDoc, ppr )
 
 -- Local imports
 import Outputable ( showSDoc, ppr )
 
 -- Local imports


@@ -38,6 +40,9 @@ import TranslatorTypes
 import HsValueMap
 import Pretty
 import CoreTools
 import HsValueMap
 import Pretty
 import CoreTools

+import Constants
+import Generate
+import GlobalNameTable

 
 createDesignFiles ::
   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
 
 createDesignFiles ::
   [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]


@@ -48,10 +53,10 @@ createDesignFiles binds =
   map (Arrow.second $ AST.DesignFile full_context) units
   
   where
   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 binds) init_session
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session

-    ty_decls = Map.elems (final_session ^. vsTypes)
+    ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)

     ieee_context = [
         AST.Library $ mkVHDLBasicId "IEEE",
         mkUseAll ["IEEE", "std_logic_1164"],
     ieee_context = [
         AST.Library $ mkVHDLBasicId "IEEE",
         mkUseAll ["IEEE", "std_logic_1164"],


@@ -60,7 +65,7 @@ createDesignFiles binds =
     full_context =
       mkUseAll ["work", "types"]
       : ieee_context
     full_context =
       mkUseAll ["work", "types"]
       : ieee_context

-    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
+    type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)

 
 -- Create a use foo.bar.all statement. Takes a list of components in the used
 -- name. Must contain at least two components
 
 -- Create a use foo.bar.all statement. Takes a list of components in the used
 -- name. Must contain at least two components


@@ -109,7 +114,7 @@ createEntity (fname, expr) = do
       CoreSyn.CoreBndr 
       -> VHDLState VHDLSignalMapElement
     -- We only need the vsTypes element from the state
       CoreSyn.CoreBndr 
       -> VHDLState VHDLSignalMapElement
     -- We only need the vsTypes element from the state

-    mkMap = MonadState.lift vsTypes . (\bndr ->
+    mkMap = (\bndr ->

       let
         --info = Maybe.fromMaybe
         --  (error $ "Signal not found in the name map? This should not happen!")
       let
         --info = Maybe.fromMaybe
         --  (error $ "Signal not found in the name map? This should not happen!")


@@ -191,7 +196,7 @@ createArchitecture (fname, expr) = do
     procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
     procs' = map AST.CSPSm procs
     -- mkSigDec only uses vsTypes from the state
     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.
 
 -- | Looks up all pairs of old state, new state signals, together with
 --   the state id they represent.


@@ -220,7 +225,7 @@ 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
 
     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 :: 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
 mkSigDec bndr =
   if True then do --isInternalSigUse use || isStateSigUse use then do
     type_mark <- vhdl_ty $ Var.varType bndr


@@ -243,25 +248,82 @@ mkConcSm ::
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   signatures <- getA vsSignatures
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   signatures <- getA vsSignatures

-  let 
-      (CoreSyn.Var f, args) = CoreSyn.collectArgs app
-      signature = Maybe.fromMaybe
-          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
+  funSignatures <- getA vsNameTable
+  let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+  case (Map.lookup (bndrToString f) funSignatures) of
+    Just funSignature ->
+      let
+        sigs = map (bndrToString.varBndr) args
+        sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+        func = (snd funSignature) sigsNames
+        src_wform = AST.Wform [AST.WformElem func Nothing]
+        dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+        assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+      in
+        return $ AST.CSSASm assign
+    Nothing ->
+      let  
+        signature = Maybe.fromMaybe 
+          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 

           (Map.lookup (bndrToString f) signatures)
           (Map.lookup (bndrToString f) signatures)

-      entity_id = ent_id signature
-      label = bndrToString bndr
+        entity_id = ent_id signature
+        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 [])
       -- 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 [])

-      portmaps = mkAssocElems args bndr signature
-    in
-      return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+        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") [] []
 
 
 -- 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") [] []
 

+-- A single alt case must be a selector
+mkConcSm (bndr, (Case (Var scrut) b ty [alt])) = error "Single case alt not supported yet"
+
+-- Multiple case alt are be conditional assignments and have only wild
+-- binders in the alts and only variables in the case values and a variable
+-- for a scrutinee. We check the constructor of the second alt, since the
+-- first is the default case, if there is any.
+mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
+  let
+    cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
+    true_expr  = (varToVHDLExpr true)
+    false_expr  = (varToVHDLExpr 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 (bndrToVHDLId bndr)
+    assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
+  in
+    return $ AST.CSSASm assign
+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"
+
+-- Turn a variable reference into a AST expression
+varToVHDLExpr :: Var.Var -> AST.Expr
+varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
+
+-- Turn a constructor into an AST expression. For dataconstructors, this is
+-- only the constructor itself, not any arguments it has. Should not be called
+-- with a DEFAULT constructor.
+conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
+conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
+  where
+    tycon = DataCon.dataConTyCon dc
+    tyname = TyCon.tyConName tycon
+    dcname = DataCon.dataConName dc
+    lit = case Name.getOccString tyname of
+      -- TODO: Do something more robust than string matching
+      "Bit"      -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
+      "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
+conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
+conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
+
+
+

 {-
 mkConcSm sigs (UncondDef src dst) _ = do
   src_expr <- vhdl_expr src
 {-
 mkConcSm sigs (UncondDef src dst) _ = do
   src_expr <- vhdl_expr src


@@ -281,7 +343,7 @@ mkConcSm sigs (UncondDef src dst) _ = do
           -- Create a cast expression, which is just a function call using the
           -- type name as the function name.
           let litexpr = AST.PrimLit lit
           -- 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
           let ty_name = AST.NSimple ty_id
           let args = [Nothing AST.:=>: (AST.ADExpr litexpr)] 
           return $ AST.PrimFCall $ AST.FCall ty_name args


@@ -361,9 +423,9 @@ std_logic_ty :: AST.TypeMark
 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
 
 -- Translate a Haskell type to a VHDL type
 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
 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)
   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)


@@ -375,24 +437,35 @@ vhdl_ty ty = do
     Just t -> return t
     -- No type yet, try to construct it
     Nothing -> do
     Just t -> return t
     -- No type yet, try to construct it
     Nothing -> do

-      let new_ty = do
-            -- Use the Maybe Monad for failing when one of these fails
-            (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
-              "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
-              otherwise -> Nothing
-      -- Return new_ty when a new type was successfully created
-      Maybe.fromMaybe 
-        (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
-        new_ty
+      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, AST.TypeDef))
+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) ty
+          return $ Just res
+        "SizedWord" -> do
+          res <- mk_vector_ty (sized_word_len ty) ty
+          return $ Just res
+        otherwise -> return Nothing
+    Nothing -> return $ Nothing

 
 -- | Create a VHDL vector type
 mk_vector_ty ::
   Int -- ^ The length of the vector
   -> Type.Type -- ^ The Haskell type to create a VHDL type for
 
 -- | Create a VHDL vector type
 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, AST.TypeDef) -- The typemark created.

 
 mk_vector_ty len ty = do
   -- Assume there is a single type argument
 
 mk_vector_ty len ty = do
   -- Assume there is a single type argument


@@ -400,10 +473,8 @@ mk_vector_ty len ty = do
   -- TODO: Use el_ty
   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
   let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
   -- TODO: Use el_ty
   let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
   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))
-  return ty_id
+  modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
+  return (ty_id, ty_def)

 
 
 builtin_types = 
 
 
 builtin_types =