diff options
Diffstat (limited to 'debug/DebugInformation.ml')
-rw-r--r-- | debug/DebugInformation.ml | 104 |
1 files changed, 99 insertions, 5 deletions
diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml index be47f2a7..e84172e6 100644 --- a/debug/DebugInformation.ml +++ b/debug/DebugInformation.ml @@ -15,6 +15,17 @@ open C (* This implements an interface for the collection of debugging information. *) +(* Simple id generator *) +let id = ref 0 + +let next_id () = + let nid = !id in + incr id; nid + +let reset_id () = + id := 0 + + (* Types for the information of type info *) type composite_field = { @@ -39,6 +50,15 @@ type ptr_type = { pts: int } +type const_type = { + const_type: int + } + +type volatile_type = { + volatile_type: int + } + + type array_type = { arr_type: int; arr_size: int64 option; @@ -90,20 +110,94 @@ type debug_types = | UnionType of composite_type | FunctionType of function_type | Typedef of typedef + | ConstType of const_type + | VolatileType of volatile_type + | Void (* All types encountered *) let all_types: (int,debug_types) Hashtbl.t = Hashtbl.create 7 -(* The basetypes, pointer, typedefs and enums all must have names *) -let name_types: (string,int) Hashtbl.t = Hashtbl.create 7 - -(* Composite types do not need to have a name. We thereore use the stamp for the mapping *) -let composite_types_table: (int, composite_type) Hashtbl.t = Hashtbl.create 7 +(* Lookup table for types *) +let lookup_types: (string, int) Hashtbl.t = Hashtbl.create 7 (* Translate a C.typ to a string needed for hashing *) let typ_to_string (ty: typ) = let buf = Buffer.create 7 in let chan = Format.formatter_of_buffer buf in + let old = !Cprint.print_idents_in_full in + Cprint.print_idents_in_full := true; Cprint.typ chan ty; + Cprint.print_idents_in_full := old; Format.pp_print_flush chan (); Buffer.contents buf + +(* Helper functions for the attributes *) +let strip_attributes typ = + let strip = List.filter (fun a -> a = AConst || a = AVolatile) in + match typ with + | TVoid at -> TVoid (strip at) + | TInt (k,at) -> TInt (k,strip at) + | TFloat (k,at) -> TFloat(k,strip at) + | TPtr (t,at) -> TPtr(t,strip at) + | TArray (t,s,at) -> TArray(t,s,strip at) + | TFun (t,arg,v,at) -> TFun(t,arg,v,strip at) + | TNamed (n,at) -> TNamed(n,strip at) + | TStruct (n,at) -> TStruct(n,strip at) + | TUnion (n,at) -> TUnion(n,strip at) + | TEnum (n,at) -> TEnum(n,strip at) + +let strip_last_attribute typ = + let rec hd_opt l = match l with + [] -> None,[] + | AConst::rest -> Some AConst,rest + | AVolatile::rest -> Some AVolatile,rest + | _::rest -> hd_opt rest in + match typ with + | TVoid at -> let l,r = hd_opt at in + l,TVoid r + | TInt (k,at) -> let l,r = hd_opt at in + l,TInt (k,r) + | TFloat (k,at) -> let l,r = hd_opt at in + l,TFloat (k,r) + | TPtr (t,at) -> let l,r = hd_opt at in + l,TPtr(t,r) + | TArray (t,s,at) -> let l,r = hd_opt at in + l,TArray(t,s,r) + | TFun (t,arg,v,at) -> let l,r = hd_opt at in + l,TFun(t,arg,v,r) + | TNamed (n,at) -> let l,r = hd_opt at in + l,TNamed(n,r) + | TStruct (n,at) -> let l,r = hd_opt at in + l,TStruct(n,r) + | TUnion (n,at) -> let l,r = hd_opt at in + l,TUnion(n,r) + | TEnum (n,at) -> let l,r = hd_opt at in + l,TEnum(n,r) + +(* Does the type already exist? *) +let exist_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + Hashtbl.mem lookup_types (typ_to_string ty) + +(* Find the type id to an type *) +let find_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + Hashtbl.find lookup_types (typ_to_string ty) + +(* Add type and information *) +let insert_type (ty: typ) = + (* We are only interrested in Const and Volatile *) + let ty = strip_attributes ty in + if not (exist_type ty) then + begin + let rec typ_aux ty = () + and attr_aux ty = + match strip_last_attribute ty with + | Some AConst,t -> + () + | None,t -> typ_aux t + in + attr_aux ty + end |