X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDLTools.hs;h=6e6a0c42acefa29ba26750443580f98aefdae18a;hb=b8c1e8554ba8aee73bc9d9a54bb3cb32f7930957;hp=359597f3395485f1ad96b525da9e4b837cbc14ca;hpb=6fcd2ccf28d4b34eca94eb868ecac83cc5a2c144;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDLTools.hs b/VHDLTools.hs index 359597f..6e6a0c4 100644 --- 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 Control.Monad.Trans.State as State 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 @@ -20,6 +21,7 @@ import qualified Name import qualified OccName import qualified Var import qualified Id +import qualified IdInfo 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 ----------------------------------------------------------------------------- --- 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 - 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? @@ -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 - 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 @@ -150,7 +150,7 @@ vhdlNameToVHDLExpr = AST.PrimName 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 @@ -314,10 +314,11 @@ construct_vhdl_ty ty = do 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") @@ -369,10 +370,11 @@ mk_vector_ty :: 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 @@ -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)) +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] @@ -447,12 +469,22 @@ mkHType ty = do 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 + "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 @@ -479,3 +511,24 @@ mkTyConHType tycon 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