X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=b8fcab1d981e195946ab2485adc687f9ad2e4028;hb=6808406c77307ba110ec5fc7e03fa7359fdf4646;hp=836f06b38c69def7f7263be62f9db2156722535b;hpb=4d203d3d6a58848bfb2e5be4309e8874bc3a5323;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/VHDL.hs b/VHDL.hs
index 836f06b..b8fcab1 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -33,7 +33,7 @@ import FlattenTypes
 import TranslatorTypes
 import HsValueMap
 import Pretty
-import HsTools
+import CoreTools
 
 createDesignFiles ::
   FlatFuncMap
@@ -50,7 +50,8 @@ createDesignFiles flatfuncmap =
     ty_decls = Map.elems (final_session ^. vsTypes)
     ieee_context = [
         AST.Library $ mkVHDLBasicId "IEEE",
-        mkUseAll ["IEEE", "std_logic_1164"]
+        mkUseAll ["IEEE", "std_logic_1164"],
+        mkUseAll ["IEEE", "numeric_std"]
       ]
     full_context =
       mkUseAll ["work", "types"]
@@ -180,7 +181,7 @@ createArchitecture hsfunc flatfunc = do
   sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
   -- Create concurrent statements for all signal definitions
-  let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
+  statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
   return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
   where
     sigs = flat_sigs flatfunc
@@ -240,46 +241,52 @@ getSignalId info =
 
 -- | Transforms a signal definition into a VHDL concurrent statement
 mkConcSm ::
-  SignatureMap             -- ^ The interfaces of functions in the session
-  -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
+  [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
   -> SigDef                -- ^ The signal definition 
   -> Int                   -- ^ A number that will be unique for all
                            --   concurrent statements in the architecture.
-  -> AST.ConcSm            -- ^ The corresponding VHDL component instantiation.
+  -> VHDLState AST.ConcSm  -- ^ The corresponding VHDL component instantiation.
 
-mkConcSm signatures sigs (FApp hsfunc args res) num =
+mkConcSm sigs (FApp hsfunc args res) num = do
+  signatures <- getA vsSignatures
   let 
-    signature = Maybe.fromMaybe
-        (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
-        (Map.lookup hsfunc signatures)
-    entity_id = ent_id signature
-    label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
-    -- 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 [])
-  in
-    AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
-
-mkConcSm _ sigs (UncondDef src dst) _ =
-  let
-    src_expr  = vhdl_expr src
-    src_wform = AST.Wform [AST.WformElem src_expr Nothing]
-    dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
-    assign    = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
-  in
-    AST.CSSASm assign
+      signature = Maybe.fromMaybe
+          (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
+          (Map.lookup hsfunc signatures)
+      entity_id = ent_id signature
+      label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
+      -- 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 [])
+    in
+      return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+
+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) = mkIdExpr sigs id
+    vhdl_expr (Left id) = return $ mkIdExpr sigs id
     vhdl_expr (Right expr) =
       case expr of
         (EqLit id lit) ->
-          (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
-        (Literal lit) ->
-          AST.PrimLit 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 <- MonadState.lift vsTypes (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) ->
-          (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
+         return $  (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
 
-mkConcSm _ sigs (CondDef cond true false dst) _ =
+mkConcSm sigs (CondDef cond true false dst) _ =
   let
     cond_expr  = mkIdExpr sigs cond
     true_expr  = mkIdExpr sigs true
@@ -290,7 +297,7 @@ mkConcSm _ sigs (CondDef cond true false dst) _ =
     dst_name  = AST.NSimple (getSignalId $ signalInfo sigs dst)
     assign    = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
   in
-    AST.CSSASm assign
+    return $ AST.CSSASm assign
 
 -- | Turn a SignalId into a VHDL Expr
 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
@@ -369,26 +376,25 @@ vhdl_ty ty = do
             (tycon, args) <- Type.splitTyConApp_maybe ty
             let name = Name.getOccString (TyCon.tyConName tycon)
             case name of
-              "FSVec" -> Just $ mk_fsvec_ty ty args
+              "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
 
--- | Create a VHDL type belonging to a FSVec Haskell type
-mk_fsvec_ty ::
-  Type.Type -- ^ The Haskell type to create a VHDL type for
-  -> [Type.Type] -- ^ Type arguments to the FSVec type constructor
+-- | 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.
 
-mk_fsvec_ty ty args = do
-  -- Assume there are two type arguments
-  let [len, el_ty] = args 
-  let len_int = eval_type_level_int len
-  let ty_id = mkVHDLExtId $ "vector_" ++ (show len_int)
+mk_vector_ty len ty = do
+  -- Assume there is a single type argument
+  let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
   -- TODO: Use el_ty
-  let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len_int - 1))]
+  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