diff options
Diffstat (limited to 'cparser')
-rw-r--r-- | cparser/Bitfields.ml | 48 | ||||
-rw-r--r-- | cparser/Elab.ml | 2 | ||||
-rw-r--r-- | cparser/Unblock.ml | 164 |
3 files changed, 175 insertions, 39 deletions
diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml index cae56f00..d064f4b1 100644 --- a/cparser/Bitfields.ml +++ b/cparser/Bitfields.ml @@ -111,16 +111,16 @@ let pack_bitfields env sid ml = end in pack [] 0 ml -let rec transf_members env id count = function +let rec transf_struct_members env id count = function | [] -> [] | m :: ms as ml -> if m.fld_bitfield = None then - m :: transf_members env id count ms + m :: transf_struct_members env id count ms else begin let (nbits, bitfields, ml') = pack_bitfields env id ml in if nbits = 0 then (* Lone zero-size bitfield: just ignore *) - transf_members env id count ml' + transf_struct_members env id count ml' else begin (* Create integer field of sufficient size for this bitfield group *) let carrier = sprintf "__bf%d" count in @@ -144,14 +144,49 @@ let rec transf_members env id count = function end) bitfields; { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None} - :: transf_members env id (count + 1) ml' + :: transf_struct_members env id (count + 1) ml' end end +let rec transf_union_members env id count = function + [] -> [] + | m :: ms -> + (match m.fld_bitfield with + | None -> m::transf_union_members env id count ms + | Some nbits -> + let carrier = sprintf "__bf%d" count in + let carrier_ikind = unsigned_ikind_for_carrier nbits in + let carrier_typ = TInt(carrier_ikind, []) in + let signed = + match unroll env m.fld_typ with + | TInt(ik, _) -> is_signed_ikind ik + | TEnum(eid, _) -> is_signed_enum_bitfield env id m.fld_name eid nbits + | _ -> assert false (* should never happen, checked in Elab *) in + let signed2 = + match unroll env (type_of_member env m) with + | TInt(ik, _) -> is_signed_ikind ik + | _ -> assert false (* should never happen, checked in Elab *) in + let pos' = + if !config.bitfields_msb_first + then sizeof_ikind carrier_ikind * 8 - nbits + else 0 in + let is_bool = + match unroll env m.fld_typ with + | TInt(IBool, _) -> true + | _ -> false in + Hashtbl.add bitfield_table + (id, m.fld_name) + {bf_carrier = carrier; bf_carrier_typ = carrier_typ; + bf_pos = pos'; bf_size = nbits; + bf_signed = signed; bf_signed_res = signed2; + bf_bool = is_bool}; + { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None} + :: transf_struct_members env id (count + 1) ms) + let transf_composite env su id attr ml = match su with - | Struct -> (attr, transf_members env id 1 ml) - | Union -> (attr, ml) + | Struct -> (attr, transf_struct_members env id 1 ml) + | Union -> (attr, transf_union_members env id 1 ml) (* Bitfield manipulation expressions *) @@ -318,6 +353,7 @@ let rec is_bitfield_access env e = match e.edesc with | EUnop(Odot fieldname, e1) -> begin match unroll env e1.etyp with + | TUnion (id,_) | TStruct(id, _) -> (try Some(e1, Hashtbl.find bitfield_table (id, fieldname)) with Not_found -> None) diff --git a/cparser/Elab.ml b/cparser/Elab.ml index e802085d..021dc512 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -1839,7 +1839,7 @@ let enter_or_refine_ident local loc env s sto ty = let enter_decdefs local loc env sto dl = (* Sanity checks on storage class *) if sto = Storage_register && not local then - error loc "'register' on global declaration"; + fatal_error loc "'register' on global declaration"; if sto <> Storage_default && dl = [] then warning loc "Storage class specifier on empty declaration"; let rec enter_decdef (decls, env) (s, ty, init) = diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml index 91f50552..b5f945d4 100644 --- a/cparser/Unblock.ml +++ b/cparser/Unblock.ml @@ -177,74 +177,173 @@ and expand_init islocal env i = in expand i +(* Insertion of debug annotation, for -g mode *) + +let debug_id = Env.fresh_ident "__builtin_debug" +let debug_ty = + TFun(TVoid [], Some [Env.fresh_ident "kind", TInt(IInt, [])], true, []) + +let debug_annot kind args = + { sloc = no_loc; + sdesc = Sdo { + etyp = TVoid []; + edesc = ECall({edesc = EVar debug_id; etyp = debug_ty}, + intconst kind IInt :: args) + } + } + +let string_const str = + let c = CStr str in { edesc = EConst c; etyp = type_of_constant c } + +let integer_const n = + intconst (Int64.of_int n) IInt + +(* Line number annotation: + __builtin_debug(1, "#line:filename:lineno", scope1, ..., scopeN) *) +(* TODO: consider + __builtin_debug(1, "filename", lineno, scope1, ..., scopeN) + instead. *) + +let debug_lineno ctx (filename, lineno) = + debug_annot 1L + (string_const (Printf.sprintf "#line:%s:%d" filename lineno) :: + List.rev_map integer_const ctx) + +let add_lineno ctx prev_loc this_loc s = + if !Clflags.option_g && this_loc <> prev_loc && this_loc <> no_loc + then sseq no_loc (debug_lineno ctx this_loc) s + else s + +(* Variable declaration annotation: + __builtin_debug(6, var, scope) *) + +let debug_var_decl ctx id ty = + let scope = match ctx with [] -> 0 | sc :: _ -> sc in + debug_annot 6L + [ {edesc = EVar id; etyp = ty}; integer_const scope ] + +let add_var_decl ctx id ty s = + if !Clflags.option_g + then sseq no_loc (debug_var_decl ctx id ty) s + else s + +let add_param_decls params body = + if !Clflags.option_g then + List.fold_right + (fun (id, ty) s -> sseq no_loc (debug_var_decl [] id ty) s) + params body + else body + +(* Generate fresh scope identifiers, for blocks that contain at least + one declaration *) + +let block_contains_decl sl = + List.exists + (function {sdesc = Sdecl _} -> true | _ -> false) + sl + +let next_scope_id = ref 0 + +let new_scope_id () = + incr next_scope_id; !next_scope_id + (* Process a block-scoped variable declaration. The variable is entered in [local_variables]. The initializer, if any, is converted into assignments and prepended to [k]. *) -let process_decl loc env (sto, id, ty, optinit) k = +let process_decl loc env ctx (sto, id, ty, optinit) k = let ty' = remove_const env ty in local_variables := (sto, id, ty', None) :: !local_variables; - match optinit with - | None -> k - | Some init -> - let init' = expand_init true env init in - let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in - add_inits_stmt loc l k + add_var_decl ctx id ty + (match optinit with + | None -> + k + | Some init -> + let init' = expand_init true env init in + let l = local_initializer env { edesc = EVar id; etyp = ty' } init' [] in + add_inits_stmt loc l k) (* Simplification of blocks within a statement *) -let rec unblock_stmt env s = +let rec unblock_stmt env ctx ploc s = match s.sdesc with | Sskip -> s | Sdo e -> - {s with sdesc = Sdo(expand_expr true env e)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sdo(expand_expr true env e)} | Sseq(s1, s2) -> - {s with sdesc = Sseq(unblock_stmt env s1, unblock_stmt env s2)} + {s with sdesc = Sseq(unblock_stmt env ctx ploc s1, + unblock_stmt env ctx s1.sloc s2)} | Sif(e, s1, s2) -> - {s with sdesc = Sif(expand_expr true env e, - unblock_stmt env s1, unblock_stmt env s2)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sif(expand_expr true env e, + unblock_stmt env ctx s.sloc s1, + unblock_stmt env ctx s.sloc s2)} | Swhile(e, s1) -> - {s with sdesc = Swhile(expand_expr true env e, unblock_stmt env s1)} + add_lineno ctx ploc s.sloc + {s with sdesc = Swhile(expand_expr true env e, + unblock_stmt env ctx s.sloc s1)} | Sdowhile(s1, e) -> - {s with sdesc = Sdowhile(unblock_stmt env s1, expand_expr true env e)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sdowhile(unblock_stmt env ctx s.sloc s1, + expand_expr true env e)} | Sfor(s1, e, s2, s3) -> - {s with sdesc = Sfor(unblock_stmt env s1, - expand_expr true env e, - unblock_stmt env s2, - unblock_stmt env s3)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sfor(unblock_stmt env ctx s.sloc s1, + expand_expr true env e, + unblock_stmt env ctx s.sloc s2, + unblock_stmt env ctx s.sloc s3)} | Sbreak -> s | Scontinue -> s | Sswitch(e, s1) -> - {s with sdesc = Sswitch(expand_expr true env e, unblock_stmt env s1)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sswitch(expand_expr true env e, + unblock_stmt env ctx s.sloc s1)} | Slabeled(lbl, s1) -> - {s with sdesc = Slabeled(lbl, unblock_stmt env s1)} - | Sgoto lbl -> s - | Sreturn None -> s + add_lineno ctx ploc s.sloc + {s with sdesc = Slabeled(lbl, unblock_stmt env ctx s.sloc s1)} + | Sgoto lbl -> + add_lineno ctx ploc s.sloc s + | Sreturn None -> + add_lineno ctx ploc s.sloc s | Sreturn (Some e) -> - {s with sdesc = Sreturn(Some (expand_expr true env e))} - | Sblock sl -> unblock_block env sl - | Sdecl d -> assert false + add_lineno ctx ploc s.sloc + {s with sdesc = Sreturn(Some (expand_expr true env e))} + | Sblock sl -> + let ctx' = + if block_contains_decl sl + then new_scope_id () :: ctx + else ctx in + unblock_block env ctx' ploc sl + | Sdecl d -> + assert false | Sasm(attr, template, outputs, inputs, clob) -> let expand_asm_operand (lbl, cstr, e) = (lbl, cstr, expand_expr true env e) in - {s with sdesc = Sasm(attr, template, - List.map expand_asm_operand outputs, - List.map expand_asm_operand inputs, clob)} + add_lineno ctx ploc s.sloc + {s with sdesc = Sasm(attr, template, + List.map expand_asm_operand outputs, + List.map expand_asm_operand inputs, clob)} -and unblock_block env = function +and unblock_block env ctx ploc = function | [] -> sskip | {sdesc = Sdecl d; sloc = loc} :: sl -> - process_decl loc env d (unblock_block env sl) + add_lineno ctx ploc loc + (process_decl loc env ctx d + (unblock_block env ctx loc sl)) | s :: sl -> - sseq s.sloc (unblock_stmt env s) (unblock_block env sl) + sseq s.sloc (unblock_stmt env ctx ploc s) + (unblock_block env ctx s.sloc sl) (* Simplification of blocks and compound literals within a function *) let unblock_fundef env f = local_variables := []; - let body = unblock_stmt env f.fd_body in + next_scope_id := 0; + let body = + add_param_decls f.fd_params (unblock_stmt env [] no_loc f.fd_body) in let decls = !local_variables in local_variables := []; { f with fd_locals = f.fd_locals @ decls; fd_body = body } @@ -299,4 +398,5 @@ let rec unblock_glob env accu = function (* Entry point *) let program p = + {gloc = no_loc; gdesc = Gdecl(Storage_extern, debug_id, debug_ty, None)} :: unblock_glob (Builtins.environment()) [] p |