Changeset 1542 for Deliverables/D2.2/8051/src/languages.ml

Timestamp:

Nov 23, 2011, 5:43:24 PM (9 years ago)

Author:

tranquil

Message:

merge of indexed labels branch

File:

• Deliverables/D2.2/8051/src/languages.ml (modified) (6 diffs)

Deliverables/D2.2/8051/src/languages.ml

@@ -35 +35 @@
   | AstLIN    of LIN.program
   | AstASM    of ASM.program
+
+type transformation = name * (ast -> ast) 
 
 let language_of_ast = function
@@ -136 +138 @@
 ]
 
-let compile debug src tgt = 
-  (* Find the maximal suffix of the chain that starts with the
-     language [src]. *)
-  let rec subchain = function
-    | [] -> 
-      (* The chain is assumed to be well-formed: such a suffix 
-         exists. *)
-      assert false 
-    | ((l, _, _) :: _) as chain when l = src -> chain
-    | _ :: chain -> subchain chain
-  in
+let insert_transformations ts chain =
+  (* turn transformation into elements of the compilation chain *)
+  let trans_to_comp (n, t) = (n, n, t) in
+  let ts = List.map trans_to_comp ts in
+  (* ts and chain are merged, and then sorted so that the resulting list is *)
+  (* still a well formed compilation chain. Stable sort preserves order *)
+  (* between transformations on the same language as appearing in ts *)
+  let compare (n1, n2, s) (m1, m2, t) = compare (n1, n2) (m1, m2) in
+  List.stable_sort compare (ts @ chain)
+
+let compile debug ts src tgt =
+  (* insert intermediate transformations *) 
+  let chain = insert_transformations ts compilation_chain in
+  (* erase transformations whose source is strictly before src *)
+  let chain = List.filter (function (l1, _, _) -> l1 >= src) chain in
+  (* erase transformations whose target is strictly after tgt *)
+  let chain = List.filter (function (_, l2, _) -> l2 <= tgt) chain in
   (* Compose the atomic translations to build a compilation function
      from [src] to [tgt]. Again, we assume that the compilation chain
@@ -153 +161 @@
      translation from [src] to [tgt]. *)
   let rec compose iprogs src tgt chains ast = 
-    if src = tgt then List.rev (ast :: iprogs)
-    else 
-      match chains with
-        | [] -> 
+    match chains with
+        | [] when src = tgt -> List.rev (ast :: iprogs)
+        | [] ->  
           Error.global_error "During compilation configuration"
             (Printf.sprintf "It is not possible to compile from `%s' to `%s'."
@@ -168 +175 @@
           ast :: l2_to_tgt iprog
   in
-  compose [] src tgt (subchain compilation_chain)
+  compose [] src tgt chain
 
 
@@ -210 +217 @@
 
 (* FIXME *)
-let instrument costs_mapping = function
+let instrument cost_tern costs_mapping = function
   | AstClight p ->
     let (p', cost_id, cost_incr, extern_cost_variables) =
-      ClightAnnotator.instrument p costs_mapping in
+      ClightAnnotator.instrument cost_tern p costs_mapping in
     (AstClight p', cost_id, cost_incr, extern_cost_variables)
 (*
@@ -227 +234 @@
     (p, "", "", StringTools.Map.empty)
 
-let annotate input_ast final =
+let annotate cost_tern input_ast final = 
   let costs_mapping = compute_costs final in 
-  instrument costs_mapping input_ast
+  instrument cost_tern costs_mapping input_ast
 
 let string_output asm_pretty = function