New support for inserting ais-annotations.

The ais annotations can be inserted via the new ais variants of
the builtin annotation. They mainly differe in that they have an
address format specifier '%addr' which will be replaced by the
adress in the binary.

The implementation simply prints a label for the builtin call
alongside a the text of the annotation as comment and inserts the
annotation together as acii string in a separate section
'ais_annotations' and replaces the usages of the address format
specifiers by the address of the label of the builtin call.

7 files changed, 37 insertions, 9 deletions

diff --git a/backend/CSE.v b/backend/CSE.v
index bc3fdba5..6d3f6f33 100644
--- a/backend/CSE.v
+++ b/backend/CSE.v
@@ -486,7 +486,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb
               | _ =>
                   empty_numbering
               end
-          | EF_vload _ | EF_annot _ _ | EF_annot_val _ _ | EF_debug _ _ _ =>
+          | EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ =>
               set_res_unknown before res
           end
       | Icond cond args ifso ifnot =>
diff --git a/backend/Deadcode.v b/backend/Deadcode.v
index 9cbe5054..2286876e 100644
--- a/backend/Deadcode.v
+++ b/backend/Deadcode.v
@@ -102,7 +102,7 @@ Function transfer_builtin (app: VA.t) (ef: external_function)
             nmem_add (nmem_remove nm (aaddr_arg app dst) sz) (aaddr_arg app src) sz)
            args
       else (ne, nm)
-  | (EF_annot _ _ | EF_annot_val _ _), _ =>
+  | (EF_annot _ _ _ | EF_annot_val _ _ _), _ =>
       transfer_builtin_args (kill_builtin_res res ne, nm) args
   | EF_debug _ _ _, _ =>
       (kill_builtin_res res ne, nm)
diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v
index ca6ad649..12c05cc3 100644
--- a/backend/Deadcodeproof.v
+++ b/backend/Deadcodeproof.v
@@ -994,7 +994,7 @@ Ltac UseTransfer :=
   erewrite Mem.loadbytes_length in H0 by eauto.
   rewrite nat_of_Z_eq in H0 by omega. auto.
 + (* annot *)
-  destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x1) as (ne1, nm1) eqn:TR.
+  destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR.
   InvSoundState.
   exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D).
   inv H1.
@@ -1006,7 +1006,7 @@ Ltac UseTransfer :=
   eapply match_succ_states; eauto. simpl; auto.
   apply eagree_set_res; auto.
 + (* annot val *)
-  destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x1) as (ne1, nm1) eqn:TR.
+  destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR.
   InvSoundState.
   exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D).
   inv H1. inv B. inv H6.
diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml
index 0e9eadcb..465b8791 100644
--- a/backend/PrintAsm.ml
+++ b/backend/PrintAsm.ml
@@ -108,6 +108,23 @@ module Printer(Target:TARGET) =
       | Gfun (External ef) ->   ()
       | Gvar v -> print_var oc name v
 
+    let print_ais_annot oc =
+      let annots = List.rev !ais_annot_list in
+      if annots <> [] then begin
+        Target.section oc Section_ais_annotation;
+        let annot_part oc lbl = function
+          |  Str.Delim _  ->
+            fprintf oc "	.byte 7,%d\n" (if Archi.ptr64 then 8 else 4) ;
+            fprintf oc "	%s %a\n" Target.address Target.label lbl
+          | Str.Text a -> fprintf oc "	.ascii %S\n" a in
+        let annot oc (lbl,str) =
+          List.iter (annot_part oc lbl) str;
+          fprintf oc "	.ascii \"\\n\"\n"
+        in
+        List.iter (annot oc) annots
+      end;
+      ais_annot_list := []
+
     module DwarfTarget: DwarfTypes.DWARF_TARGET =
       struct
         let label = Target.label
@@ -128,6 +145,7 @@ let print_program oc p =
   Target.print_prologue oc;
   List.iter (Printer.print_globdef oc) p.prog_defs;
   Target.print_epilogue oc;
+  Printer.print_ais_annot oc;
   if !Clflags.option_g then
     begin
       let atom_to_s s =
diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml
index df3445ea..07ab4bed 100644
--- a/backend/PrintAsmaux.ml
+++ b/backend/PrintAsmaux.ml
@@ -197,6 +197,16 @@ let annot_text preg_string sp_reg_name txt args =
         sprintf "<bad parameter %s>" s in
   String.concat "" (List.map fragment (Str.full_split re_annot_param txt))
 
+let ais_annot_list: (int * Str.split_result list) list ref = ref []
+
+let re_annot_addr = Str.regexp "%addr"
+
+let ais_annot_text lbl preg_string sp_reg_name txt args =
+  let annot = annot_text preg_string sp_reg_name txt args in
+  let annots = Str.full_split re_annot_addr annot in
+  ais_annot_list := (lbl,annots)::!ais_annot_list;
+  annot
+
 (* Printing of [EF_debug] info.  To be completed. *)
 
 let re_file_line = Str.regexp "#line:\\(.*\\):\\([1-9][0-9]*\\)$"
diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v
index fef74706..8336d1bf 100644
--- a/backend/RTLtyping.v
+++ b/backend/RTLtyping.v
@@ -132,7 +132,7 @@ Inductive wt_instr : instruction -> Prop :=
   | wt_Ibuiltin:
       forall ef args res s,
       match ef with
-      | EF_annot _ _ | EF_debug _ _ _ => True
+      | EF_annot _ _ _ | EF_debug _ _ _ => True
       | _ => map type_of_builtin_arg args = (ef_sig ef).(sig_args)
       end ->
       type_of_builtin_res res = proj_sig_res (ef_sig ef) ->
@@ -308,7 +308,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv :=
       do x <- check_successor s;
       do e1 <-
         match ef with
-        | EF_annot _ _ | EF_debug _ _ _ => OK e
+        | EF_annot _ _ _ | EF_debug _ _ _ => OK e
         | _ => type_builtin_args e args sig.(sig_args)
         end;
       type_builtin_res e1 res (proj_sig_res sig)
@@ -702,7 +702,7 @@ Proof.
   exploit type_builtin_res_complete; eauto. instantiate (1 := res). intros [e2 [C D]].
   exploit type_builtin_res_complete. eexact H. instantiate (1 := res). intros [e3 [E F]].
   rewrite check_successor_complete by auto. simpl.
-  exists (match ef with EF_annot _ _ | EF_debug _ _ _ => e3 | _ => e2 end); split.
+  exists (match ef with EF_annot _ _ _ | EF_debug _ _ _ => e3 | _ => e2 end); split.
   rewrite H1 in C, E.
   destruct ef; try (rewrite <- H0; rewrite A); simpl; auto.
   destruct ef; auto.
diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v
index 8aa4878a..674bc065 100644
--- a/backend/ValueAnalysis.v
+++ b/backend/ValueAnalysis.v
@@ -99,9 +99,9 @@ Definition transfer_builtin
       let p := loadbytes am rm (aptr_of_aval asrc) in
       let am' := storebytes am (aptr_of_aval adst) sz p in
       VA.State (set_builtin_res res ntop ae) am'
-  | (EF_annot _ _ | EF_debug _ _ _), _ =>
+  | (EF_annot _ _ _ | EF_debug _ _ _), _ =>
       VA.State (set_builtin_res res ntop ae) am
-  | EF_annot_val _ _, v :: nil =>
+  | EF_annot_val _ _ _, v :: nil =>
       let av := abuiltin_arg ae am rm v in
       VA.State (set_builtin_res res av ae) am
   | _, _ =>