Only save normalized tfp integers in the tfp-cache

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

diff --git a/VHDLTools.hs b/VHDLTools.hs
index d560a7472bfada0303841dc0184312446109fe94..e7c598d498d322222821bdaf091422ca778e5f96 100644 (file)
--- a/VHDLTools.hs
+++ b/VHDLTools.hs
@@ -7,6 +7,7 @@ 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
 import qualified Data.Monoid as Monoid
 import Data.Accessor
 import Debug.Trace


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


@@ -121,8 +123,8 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins
 -----------------------------------------------------------------------------
 
 -- Turn a variable reference into a AST expression
 -----------------------------------------------------------------------------
 
 -- Turn a variable reference into a AST expression

-varToVHDLExpr :: Var.Var -> AST.Expr
-varToVHDLExpr var = 
+varToVHDLExpr :: TypeState -> Var.Var -> AST.Expr
+varToVHDLExpr ty_state var =

   case Id.isDataConWorkId_maybe var of
     Just dc -> dataconToVHDLExpr dc
     -- This is a dataconstructor.
   case Id.isDataConWorkId_maybe var of
     Just dc -> dataconToVHDLExpr dc
     -- This is a dataconstructor.


@@ -132,17 +134,18 @@ 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 -> 
+    Nothing ->

         let 
           ty  = Var.varType var
           res = case Type.splitTyConApp_maybe ty of
                   Just (tycon, args) ->
                     case Name.getOccString (TyCon.tyConName tycon) of
         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))
+                      "Dec" -> AST.PrimLit $ (show (fst ( State.runState (tfp_to_int ty) ty_state ) ) )

                       otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
         in
           res
 
                       otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var
         in
           res
 

+

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


@@ -150,7 +153,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 ty_state = (varToVHDLExpr ty_state) . exprToVar

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


@@ -277,28 +280,33 @@ vhdl_ty msg ty = do
 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
 vhdl_ty_either ty = do
   typemap <- getA vsTypes
 vhdl_ty_either :: Type.Type -> TypeSession (Either String AST.TypeMark)
 vhdl_ty_either ty = do
   typemap <- getA vsTypes

-  htype <- mkHType ty
-  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 htype typemap
-  case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
-    -- Found a type, return it
-    Just t -> return (Right t)
-    -- No type yet, try to construct it
-    Nothing -> do
-      newty_maybe <- (construct_vhdl_ty ty)
-      case newty_maybe of
-        Right (ty_id, ty_def) -> do
-          -- TODO: Check name uniqueness
-          modA vsTypes (Map.insert htype (ty_id, ty_def))
-          modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
-          return (Right ty_id)
-        Left err -> return $ Left $
-          "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
-          ++ err
+  htype_either <- mkHType ty
+  case htype_either of
+    -- No errors
+    Right htype -> do
+      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 htype typemap
+      case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
+        -- Found a type, return it
+        Just t -> return (Right t)
+        -- No type yet, try to construct it
+        Nothing -> do
+          newty_maybe <- (construct_vhdl_ty ty)
+          case newty_maybe of
+            Right (ty_id, ty_def) -> do
+              -- TODO: Check name uniqueness
+              modA vsTypes (Map.insert htype (ty_id, ty_def))
+              modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (ty_id, ty_def)]) 
+              return (Right ty_id)
+            Left err -> return $ Left $
+              "VHDLTools.vhdl_ty: Unsupported Haskell type: " ++ pprString ty ++ "\n"
+              ++ err
+    -- Error when constructing htype
+    Left err -> return $ Left err 

 
 -- Construct a new VHDL type for the given Haskell type. Returns an error
 -- message or the resulting typemark and typedef.
 
 -- Construct a new VHDL type for the given Haskell type. Returns an error
 -- message or the resulting typemark and typedef.


@@ -309,10 +317,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")


@@ -364,10 +373,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


@@ -403,6 +413,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]


@@ -412,7 +442,8 @@ getFieldLabels ty = do
   vhdl_ty error_msg ty
   -- Get the types map, lookup and unpack the VHDL TypeDef
   types <- getA vsTypes
   vhdl_ty error_msg ty
   -- Get the types map, lookup and unpack the VHDL TypeDef
   types <- getA vsTypes

-  htype <- mkHType ty
+  -- Assume the type for which we want labels is really translatable
+  Right htype <- mkHType ty

   case Map.lookup htype types of
     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)
   case Map.lookup htype types of
     Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
     _ -> error $ "\nVHDL.getFieldLabels: Type not found or not a record type? This should not happen! Type: " ++ (show ty)


@@ -421,7 +452,7 @@ mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
 
 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
 

-mkHType :: Type.Type -> TypeSession HType
+mkHType :: Type.Type -> TypeSession (Either String HType)

 mkHType ty = do
   -- FIXME: Do we really need to do this here again?
   let builtin_ty = do -- See if this is a tycon and lookup its name
 mkHType ty = do
   -- FIXME: Do we really need to do this here again?
   let builtin_ty = do -- See if this is a tycon and lookup its name


@@ -430,31 +461,77 @@ mkHType ty = do
         Map.lookup name builtin_types
   case builtin_ty of
     Just typ -> 
         Map.lookup name builtin_types
   case builtin_ty of
     Just typ -> 

-      return $ BuiltinType $ prettyShow typ
+      return $ Right $ BuiltinType $ prettyShow typ

     Nothing ->
       case Type.splitTyConApp_maybe ty of
         Just (tycon, args) -> do
           let name = Name.getOccString (TyCon.tyConName tycon)
           case name of
             "TFVec" -> do
     Nothing ->
       case Type.splitTyConApp_maybe ty of
         Just (tycon, args) -> do
           let name = Name.getOccString (TyCon.tyConName tycon)
           case name of
             "TFVec" -> do

-              elem_htype <- mkHType (tfvec_elem ty)
-              return $ VecType (tfvec_len ty) elem_htype
+              let el_ty = tfvec_elem ty
+              elem_htype_either <- mkHType el_ty
+              case elem_htype_either of
+                -- Could create element type
+                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
+            "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
             otherwise -> do
               mkTyConHType tycon args

-        Nothing -> return $ StdType $ OrdType ty
+        Nothing -> return $ Right $ StdType $ OrdType ty

 
 -- FIXME: Do we really need to do this here again?
 
 -- FIXME: Do we really need to do this here again?

-mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession HType
+mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType)

 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type
 mkTyConHType tycon args =
   case TyCon.tyConDataCons tycon of
     -- Not an algebraic type

-    [] -> error $ "\nVHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon
+    [] -> return $ Left $ "VHDLTools.mkHType: Only custom algebraic types are supported: " ++ pprString tycon ++ "\n"

     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
     [dc] -> do
       let arg_tys = DataCon.dataConRepArgTys dc
       let real_arg_tys = map (CoreSubst.substTy subst) arg_tys

-      elem_htys <- mapM mkHType real_arg_tys
-      return $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
-    dcs -> error $ "\nVHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon
+      elem_htys_either <- mapM mkHType real_arg_tys
+      case Either.partitionEithers elem_htys_either of
+        -- No errors in element types
+        ([], elem_htys) -> do
+          return $ Right $ ADTType (nameToString (TyCon.tyConName tycon)) elem_htys
+        -- There were errors in element types
+        (errors, _) -> return $ Left $
+          "VHDLTools.mkHType: Can not construct type for: " ++ pprString tycon ++ "\n because no type can be construced for some of the arguments.\n"
+          ++ (concat errors)
+    dcs -> return $ Left $ "VHDLTools.mkHType: Only single constructor datatypes supported: " ++ pprString tycon ++ "\n"

   where
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
   where
     tyvars = TyCon.tyConTyVars tycon
     subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)

+
+-- Is the given type representable at runtime?
+isReprType :: Type.Type -> TypeSession Bool
+isReprType ty = do
+  ty_either <- vhdl_ty_either ty
+  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