X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDLTools.hs;h=e7c598d498d322222821bdaf091422ca778e5f96;hb=aa23b0116eaf65b01499cd1eba93a92f7c8c36e8;hp=5deaf45effbf579d6b5ce03f782c93e8b1c16712;hpb=afd269e5653952394495a7a14ad1bfc0c0146b39;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDLTools.hs b/VHDLTools.hs index 5deaf45..e7c598d 100644 --- 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 Control.Monad.Trans.State as State 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 IdInfo 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 -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. @@ -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 - 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 @@ -150,7 +153,7 @@ 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 @@ -277,27 +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 - 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 (OrdType ty) 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 (OrdType ty) (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. @@ -308,10 +317,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") @@ -363,10 +373,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 @@ -374,7 +385,7 @@ mk_vector_ty ty = do Right el_ty_tm -> do let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] - let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType vec_ty) types_map + let existing_elem_ty = (fmap fst) $ Map.lookup (StdType $ OrdType vec_ty) types_map case existing_elem_ty of Just t -> do let ty_def = AST.SubtypeIn t (Just range) @@ -382,7 +393,7 @@ mk_vector_ty ty = do Nothing -> do let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm) let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm - modA vsTypes (Map.insert (OrdType vec_ty) (vec_id, (Left vec_def))) + modA vsTypes (Map.insert (StdType $ OrdType vec_ty) (vec_id, (Left vec_def))) modA vsTypeDecls (\typedefs -> typedefs ++ [mktydecl (vec_id, (Left vec_def))]) let ty_def = AST.SubtypeIn vec_id (Just range) return (Right (ty_id, Right ty_def)) @@ -402,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)) +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] @@ -411,10 +442,96 @@ getFieldLabels ty = do vhdl_ty error_msg ty -- Get the types map, lookup and unpack the VHDL TypeDef types <- getA vsTypes - case Map.lookup (OrdType ty) types of + -- 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 :: (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 + +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 + (tycon, args) <- Type.splitTyConApp_maybe ty + let name = Name.getOccString (TyCon.tyConName tycon) + Map.lookup name builtin_types + case builtin_ty of + Just 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 + 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 + Nothing -> return $ Right $ StdType $ OrdType ty + +-- FIXME: Do we really need to do this here again? +mkTyConHType :: TyCon.TyCon -> [Type.Type] -> TypeSession (Either String HType) +mkTyConHType tycon args = + case TyCon.tyConDataCons tycon of + -- Not an algebraic type + [] -> 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_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 + 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