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 OccName
import qualified Var
import qualified Id
+import qualified IdInfo
import qualified TyCon
import qualified Type
import qualified DataCon
-----------------------------------------------------------------------------
-- 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.
-- 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
- "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
+
-- Turn a VHDLName into an AST expression
vhdlNameToVHDLExpr = AST.PrimName
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
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.
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")
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 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 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]
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)
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
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
- 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
+ env <- getA vsHscEnv
+ let norm_ty = normalise_tfp_int env (tfvec_len_ty ty)
+ return $ Right $ VecType (OrdType norm_ty) 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
- Nothing -> return $ StdType $ OrdType ty
+ Nothing -> return $ Right $ StdType $ OrdType ty
-- 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
- [] -> 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
- 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)
+
+-- 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
+ let existing_len = Map.lookup (OrdType ty) lens
+ case existing_len of
+ Just len -> return len
+ Nothing -> do
+ let new_len = eval_tfp_int ty
+ modA vsTfpInts (Map.insert (OrdType ty) (new_len))
+ return new_len
\ No newline at end of file