Moved to new GHC API (6.11). Also use vhdl package for the VHDL AST

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

diff --git a/VHDLTools.hs b/VHDLTools.hs
index 8bc45f79a43490cb3f45c6e0ac3389d58337e085..6e6a0c42acefa29ba26750443580f98aefdae18a 100644 (file)
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -7,12 +7,13 @@ 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.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Arrow as Arrow

+import qualified Control.Monad.Trans.State as State

 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import Debug.Trace
 
 -- ForSyDe
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import Debug.Trace
 
 -- ForSyDe

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

 
 -- GHC API
 import CoreSyn
 
 -- GHC API
 import CoreSyn


@@ -20,6 +21,7 @@ import qualified Name
 import qualified OccName
 import qualified Var
 import qualified Id
 import qualified OccName
 import qualified Var
 import qualified Id

+import qualified IdInfo

 import qualified TyCon
 import qualified Type
 import qualified DataCon
 import qualified TyCon
 import qualified Type
 import qualified DataCon


@@ -120,11 +122,10 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 -- Functions to generate VHDL Exprs
 -----------------------------------------------------------------------------
 
 -- Functions to generate VHDL Exprs
 -----------------------------------------------------------------------------
 

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

   case Id.isDataConWorkId_maybe var of
   case Id.isDataConWorkId_maybe var of

-    Just dc -> dataconToVHDLExpr dc
+    Just dc -> return $ dataconToVHDLExpr dc

     -- 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?


@@ -132,16 +133,15 @@ varToVHDLExpr var =
     -- 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
     -- 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
+    Nothing -> do
+        let ty  = Var.varType var
+        case Type.splitTyConApp_maybe ty of
+                Just (tycon, args) ->
+                  case Name.getOccString (TyCon.tyConName tycon) of
+                    "Dec" -> do
+                      len <- tfp_to_int ty
+                      return $ AST.PrimLit $ (show len)
+                    otherwise -> return $ AST.PrimName $ AST.NSimple $ varToVHDLId var

 
 -- Turn a VHDLName into an AST expression
 vhdlNameToVHDLExpr = AST.PrimName
 
 -- Turn a VHDLName into an AST expression
 vhdlNameToVHDLExpr = AST.PrimName


@@ -150,7 +150,7 @@ vhdlNameToVHDLExpr = AST.PrimName
 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 
 -- Turn a Core expression into an AST expression
 idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple
 
 -- Turn a Core expression into an AST expression

-exprToVHDLExpr = varToVHDLExpr . exprToVar
+exprToVHDLExpr core = varToVHDLExpr (exprToVar core)

 
 -- 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


@@ -314,10 +314,11 @@ construct_vhdl_ty ty = do
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of
         "TFVec" -> mk_vector_ty ty
       let name = Name.getOccString (TyCon.tyConName tycon)
       case name of
         "TFVec" -> mk_vector_ty ty

-        -- "SizedWord" -> do
-        --   res <- mk_vector_ty (sized_word_len ty) ty
-        --   return $ Just $ (Arrow.second Left) res
-        "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty)
+        "SizedWord" -> mk_unsigned_ty ty
+        "SizedInt"  -> mk_signed_ty ty
+        "RangedWord" -> do 
+          bound <- tfp_to_int (ranged_word_bound_ty ty)
+          mk_natural_ty 0 bound

         -- Create a custom type from this tycon
         otherwise -> mk_tycon_ty tycon args
     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")
         -- Create a custom type from this tycon
         otherwise -> mk_tycon_ty tycon args
     Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n")


@@ -369,10 +370,11 @@ mk_vector_ty ::
 
 mk_vector_ty ty = do
   types_map <- getA vsTypes
 
 mk_vector_ty ty = do
   types_map <- getA vsTypes

+  env <- getA vsHscEnv

   let (nvec_l, nvec_el) = Type.splitAppTy ty
   let (nvec, leng) = Type.splitAppTy nvec_l
   let vec_ty = Type.mkAppTy nvec nvec_el
   let (nvec_l, nvec_el) = Type.splitAppTy ty
   let (nvec, leng) = Type.splitAppTy nvec_l
   let vec_ty = Type.mkAppTy nvec nvec_el

-  let len = tfvec_len ty
+  len <- tfp_to_int (tfvec_len_ty ty)

   let el_ty = tfvec_elem ty
   el_ty_tm_either <- vhdl_ty_either el_ty
   case el_ty_tm_either of
   let el_ty = tfvec_elem ty
   el_ty_tm_either <- vhdl_ty_either el_ty
   case el_ty_tm_either of


@@ -408,6 +410,26 @@ mk_natural_ty min_bound max_bound = do
   let ty_def = AST.SubtypeIn naturalTM (Just range)
   return (Right (ty_id, Right ty_def))
 
   let ty_def = AST.SubtypeIn naturalTM (Just range)
   return (Right (ty_id, Right ty_def))
 

+mk_unsigned_ty ::
+  Type.Type -- ^ Haskell type of the unsigned integer
+  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_unsigned_ty ty = do
+  size <- tfp_to_int (sized_word_len_ty ty)
+  let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1)
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_def = AST.SubtypeIn unsignedTM (Just range)
+  return (Right (ty_id, Right ty_def))
+  
+mk_signed_ty ::
+  Type.Type -- ^ Haskell type of the signed integer
+  -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
+mk_signed_ty ty = do
+  size <- tfp_to_int (sized_int_len_ty ty)
+  let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1)
+  let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))]
+  let ty_def = AST.SubtypeIn signedTM (Just range)
+  return (Right (ty_id, Right ty_def))
+

 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.
 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]
 -- Finds the field labels for VHDL type generated for the given Core type,
 -- which must result in a record type.
 getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId]


@@ -447,12 +469,22 @@ mkHType ty = do
               elem_htype_either <- mkHType el_ty
               case elem_htype_either of
                 -- Could create element type
               elem_htype_either <- mkHType el_ty
               case elem_htype_either of
                 -- Could create element type

-                Right elem_htype ->
-                  return $ Right $ VecType (tfvec_len ty) elem_htype
+                Right elem_htype -> do
+                  len <- tfp_to_int (tfvec_len_ty ty)
+                  return $ Right $ VecType len elem_htype

                 -- Could not create element type
                 Left err -> return $ Left $ 
                   "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
                   ++ err
                 -- Could not create element type
                 Left err -> return $ Left $ 
                   "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty  ++ "\n"
                   ++ err

+            "SizedWord" -> do
+              len <- tfp_to_int (sized_word_len_ty ty)
+              return $ Right $ SizedWType len
+            "SizedInt" -> do
+              len <- tfp_to_int (sized_word_len_ty ty)
+              return $ Right $ SizedIType len
+            "RangedWord" -> do
+              bound <- tfp_to_int (ranged_word_bound_ty ty)
+              return $ Right $ RangedWType bound

             otherwise -> do
               mkTyConHType tycon args
         Nothing -> return $ Right $ StdType $ OrdType ty
             otherwise -> do
               mkTyConHType tycon args
         Nothing -> return $ Right $ StdType $ OrdType ty


@@ -487,3 +519,16 @@ isReprType ty = do
   return $ case ty_either of
     Left _ -> False
     Right _ -> True
   return $ case ty_either of
     Left _ -> False
     Right _ -> True

+
+tfp_to_int :: Type.Type -> TypeSession Int
+tfp_to_int ty = do
+  lens <- getA vsTfpInts
+  hscenv <- getA vsHscEnv
+  let norm_ty = normalise_tfp_int hscenv ty
+  let existing_len = Map.lookup (OrdType norm_ty) lens
+  case existing_len of
+    Just len -> return len
+    Nothing -> do
+      let new_len = eval_tfp_int hscenv ty
+      modA vsTfpInts (Map.insert (OrdType norm_ty) (new_len))
+      return new_len
\ No newline at end of file