Changeset 1392 for Deliverables/D2.2/8051-indexed-labels-branch/src/clight/clightToCminor.ml

Timestamp:

Oct 17, 2011, 2:08:27 PM (9 years ago)

Author:

tranquil

Message:

fiddling with Cminor: elimination of loops, blocks and exits

File:

• Deliverables/D2.2/8051-indexed-labels-branch/src/clight/clightToCminor.ml (modified) (3 diffs)

Deliverables/D2.2/8051-indexed-labels-branch/src/clight/clightToCminor.ml

@@ -492 +492 @@
 let ind_inc i stmt = match i with
         | None -> stmt
-        | Some x -> Cminor.St_ind_inc(stmt, x)
-
-let f_stmt fresh var_locs stmt sub_exprs_res sub_stmts_res =
-  let (tmps, sub_stmts_res) = List.split sub_stmts_res in
-  let tmps = List.flatten tmps in
-
-  let (added_tmps, stmt) = match stmt, sub_exprs_res, sub_stmts_res with
-
-    | Clight.Sskip, _, _ -> ([], Cminor.St_skip)
-
-    | Clight.Sassign (e1, _), _ :: e2 :: _, _ ->
+        | Some x -> Cminor.St_ind_inc(x, stmt)
+
+let trans_for =
+        let f_expr e _ = e in
+        let f_stmt stmt expr_res stmt_res = match expr_res, stmt_res, stmt with
+                | e::_, s1::s2::s3::_, Clight.Sfor(i,_,_,_,_) ->
+                        Clight.Ssequence(s1,Clight.Swhile(i,e,
+                         Clight.Ssequence(s3, s2)))
+                | exprs, sub_sts, stm -> ClightFold.statement_fill_subs stm exprs sub_sts in
+        ClightFold.statement2 f_expr f_stmt
+
+let rec translate_stmt fresh var_locs cnt_lbl br_lbl = function
+
+    | Clight.Sskip -> ([], Cminor.St_skip)
+
+    | Clight.Sassign (e1, e2) ->
+                        let e2 = translate_expr var_locs e2 in
       ([], assign var_locs e1 e2)
 
-    | Clight.Scall (None, _, _), f :: args, _ ->
+    | Clight.Scall (None, f, args) ->
+                        let f = translate_expr var_locs f in
+                        let args = List.map (translate_expr var_locs) args in
       ([], Cminor.St_call (None, f, args, call_sig AST.Type_void args))
 
-    | Clight.Scall (Some e, _, _), _ :: f :: args, _ ->
+    | Clight.Scall (Some e, f, args) ->
+            let f = translate_expr var_locs f in
+            let args = List.map (translate_expr var_locs) args in
       let t = sig_type_of_ctype (clight_type_of e) in
       let tmp = fresh () in
@@ -517 +527 @@
       ([(tmp, t)], Cminor.St_seq (stmt_call, stmt_assign))
 
-    | Clight.Swhile (i,_,_), e :: _, stmt :: _ ->
+    | Clight.Swhile (i,e,stmt) ->
+                        let loop_lbl = fresh () in
+                        let llbl_opt = Some loop_lbl in
+                        let exit_lbl = fresh () in
+            let elbl_opt = Some exit_lbl in
+            let (tmps, stmt) = translate_stmt fresh var_locs llbl_opt elbl_opt stmt in
+                        let e = translate_expr var_locs e in
+                        let jmp lbl = Cminor.St_goto lbl in
       let econd =                
         Cminor.Expr (Cminor.Op1 (AST.Op_notbool, e), cminor_type_of e) in
       let scond =
-        Cminor.St_ifthenelse (econd, Cminor.St_exit 0, Cminor.St_skip) in
-            let loop_body = Cminor.St_seq (scond, ind_inc i (Cminor.St_block stmt)) in
-                        let loop = ind_0 i (Cminor.St_loop loop_body) in
-      ([], Cminor.St_block loop)
+        Cminor.St_ifthenelse (econd, jmp exit_lbl, Cminor.St_skip) in
+            let loop =
+                                Cminor.St_seq(scond,Cminor.St_seq (stmt, ind_inc i (jmp loop_lbl))) in
+                        let loop = ind_0 i (Cminor.St_label(loop_lbl,loop)) in
+      (tmps, Cminor.St_seq (loop, Cminor.St_label(exit_lbl,Cminor.St_skip)))
                         
-    | Clight.Sdowhile (i,_,_), e :: _, stmt :: _ ->
-      let econd =                
-        Cminor.Expr (Cminor.Op1 (AST.Op_notbool, e), cminor_type_of e) in
+    | Clight.Sdowhile (i,e,stmt) ->
+            let loop_lbl = fresh () in
+            let llbl_opt = Some loop_lbl in
+            let exit_lbl = fresh () in
+            let elbl_opt = Some exit_lbl in
+      let (tmps, stmt) = translate_stmt fresh var_locs llbl_opt elbl_opt stmt in
+      let e = translate_expr var_locs e in
+      let jmp lbl = Cminor.St_goto lbl in
       let scond =
-              Cminor.St_ifthenelse (econd, Cminor.St_exit 0, Cminor.St_skip) in
-                        let loop_body = ind_inc i (Cminor.St_seq (Cminor.St_block stmt, scond)) in
-                        let loop = ind_0 i (Cminor.St_loop loop_body) in
-      ([], Cminor.St_block loop)
-
-    | Clight.Sfor (i,_,_,_,_), e :: _, stmt1 :: stmt2 :: stmt3 :: _ ->
-      let econd =                                
-        Cminor.Expr (Cminor.Op1 (AST.Op_notbool, e), cminor_type_of e) in
-      let scond =
-              Cminor.St_ifthenelse (econd, Cminor.St_exit 0, Cminor.St_skip) in
-      let body = Cminor.St_seq (ind_inc i (Cminor.St_block stmt3), stmt2) in
-                        let body = Cminor.St_seq (scond, body) in
-                        let block = Cminor.St_block (ind_0 i (Cminor.St_loop body)) in  
-      ([], Cminor.St_seq (stmt1, block))
-
-    | Clight.Sifthenelse _, e :: _, stmt1 :: stmt2 :: _ ->
-      ([], Cminor.St_ifthenelse (e, stmt1, stmt2))
-
-    | Clight.Ssequence _, _, stmt1 :: stmt2 :: _ ->
-      ([], Cminor.St_seq (stmt1, stmt2))
-
-    | Clight.Sbreak, _, _ -> ([], Cminor.St_exit 1)
-
-    | Clight.Scontinue, _, _ -> ([], Cminor.St_exit 0)
-
-    | Clight.Sswitch _, _, _ ->
+        Cminor.St_ifthenelse (e, ind_inc i (jmp loop_lbl), Cminor.St_skip) in
+            let loop =
+        Cminor.St_seq (stmt, scond) in
+      let loop = ind_0 i (Cminor.St_label(loop_lbl,loop)) in
+      (tmps, Cminor.St_seq (loop, Cminor.St_label(exit_lbl,Cminor.St_skip)))
+                        
+    | Clight.Sfor _ -> assert false (* transformed *)
+
+    | Clight.Sifthenelse (e, stmt1, stmt2) ->
+      let (tmps1, stmt1) = translate_stmt fresh var_locs cnt_lbl br_lbl stmt1 in
+      let (tmps2, stmt2) = translate_stmt fresh var_locs cnt_lbl br_lbl stmt2 in
+      let e = translate_expr var_locs e in
+      (tmps1 @ tmps2, Cminor.St_ifthenelse (e, stmt1, stmt2))
+
+    | Clight.Ssequence(stmt1,stmt2) ->
+      let (tmps1, stmt1) = translate_stmt fresh var_locs cnt_lbl br_lbl stmt1 in
+      let (tmps2, stmt2) = translate_stmt fresh var_locs cnt_lbl br_lbl stmt2 in
+      (tmps1 @ tmps2, Cminor.St_seq (stmt1, stmt2))
+
+    | Clight.Sbreak -> 
+                        let br_lbl = match br_lbl with
+                                | Some x -> x
+                                | None -> invalid_arg("break without enclosing scope") in
+                        ([], Cminor.St_goto br_lbl)
+
+    | Clight.Scontinue ->
+            let cnt_lbl = match cnt_lbl with
+                | Some x -> x
+                | None -> invalid_arg("continue without enclosing scope") in
+      ([], Cminor.St_goto cnt_lbl)
+    | Clight.Sswitch _ ->
       (* Should not appear because of switch transformation performed
          beforehand. *)
       assert false
 
-    | Clight.Sreturn None, _, _ -> ([], Cminor.St_return None)
-
-    | Clight.Sreturn (Some _), e :: _, _ -> ([], Cminor.St_return (Some e))
-
-    | Clight.Slabel (lbl, _), _, stmt :: _ -> ([], Cminor.St_label (lbl, stmt))
-
-    | Clight.Sgoto lbl, _, _ -> ([], Cminor.St_goto lbl)
-
-    | Clight.Scost (lbl, _), _, stmt :: _ -> ([], Cminor.St_cost (lbl, stmt))
-
-    | _ -> assert false (* type error *) in
-
-  (tmps @ added_tmps, stmt)
-
-let translate_statement fresh var_locs =
-  ClightFold.statement2 (f_expr var_locs) (f_stmt fresh var_locs)
+    | Clight.Sreturn None -> ([], Cminor.St_return None)
+
+    | Clight.Sreturn (Some e) ->
+                        let e = translate_expr var_locs e in
+                        ([], Cminor.St_return (Some e))
+
+    | Clight.Slabel (lbl, stmt) ->
+                        let (tmps, stmt) = translate_stmt fresh var_locs cnt_lbl br_lbl stmt in
+                        (tmps, Cminor.St_label (lbl, stmt))
+
+    | Clight.Sgoto lbl -> ([], Cminor.St_goto lbl)
+
+    | Clight.Scost (lbl, stmt) ->
+                        let (tmps, stmt) = translate_stmt fresh var_locs cnt_lbl br_lbl stmt in
+                        (tmps, Cminor.St_cost (lbl, stmt))
+
+    | _ -> assert false (* type error *)
 
 
@@ -596 +625 @@
   let params =
     List.map (fun (x, t) -> (x, sig_type_of_ctype t)) cfun.Clight.fn_params in
-  let (tmps, body) = translate_statement fresh var_locs cfun.Clight.fn_body in
+        let body = cfun.Clight.fn_body in
+  let (tmps, body) = translate_stmt fresh var_locs None None body in
   let body = add_stack_parameters_initialization var_locs body in
   { Cminor.f_return = type_return_of_ctype cfun.Clight.fn_return ;