compiler/control.ml

   1 (* Js_of_ocaml compiler
   2  * http://www.ocsigen.org/js_of_ocaml/
   3  * Copyright (C) 2010 Jérôme Vouillon
   4  * Laboratoire PPS - CNRS Université Paris Diderot
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU Lesser General Public License as published by
   8  * the Free Software Foundation, with linking exception;
   9  * either version 2.1 of the License, or (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU Lesser General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU Lesser General Public License
  17  * along with this program; if not, write to the Free Software
  18  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  19  *)
  20
  21 (*
  22 FIX: is there a way to merge this with dead code elimination?
  23 *)
  24
  25 open Code
  26
  27 (****)
  28
  29 (* Postorder traversal of the whole program. *)
  30
  31 let traverse blocks pc f accu =
  32   let rec traverse_rec visited pc accu =
  33     if AddrSet.mem pc visited then (visited, accu) else begin
  34       let visited = AddrSet.add pc visited in
  35       let block = AddrMap.find pc blocks in
  36       let (visited, accu) =
  37         List.fold_left
  38           (fun ((visited, accu) as p) i ->
  39              match i with
  40                Let (_, Closure (_, (pc, _))) ->
  41                  traverse_rec visited pc accu
  42              | _ ->
  43                  p)
  44           (visited, accu) block.body
  45       in
  46       let (visited, accu) =
  47         match block.branch with
  48           Return _ | Raise _ | Stop ->
  49             (visited, accu)
  50         | Branch (pc, _) | Poptrap (pc, _) ->
  51             traverse_rec visited pc accu
  52         | Cond (_, _, (pc1, _), (pc2, _)) ->
  53             let (visited, accu) = traverse_rec visited pc1 accu in
  54             traverse_rec visited pc2 accu
  55         | Switch (_, a1, a2) ->
  56             let (visited, accu) =
  57               Array.fold_left
  58                 (fun (visited, accu) (pc, _) -> traverse_rec visited pc accu)
  59                 (visited, accu) a1 in
  60             let (visited, accu) =
  61               Array.fold_left
  62                 (fun (visited, accu) (pc, _) -> traverse_rec visited pc accu)
  63                 (visited, accu) a2 in
  64             (visited, accu)
  65         | Pushtrap ((pc1, _), _, (pc2, _), _) ->
  66             let (visited, accu) = traverse_rec visited pc1 accu in
  67             traverse_rec visited pc2 accu
  68       in
  69       (visited, f pc accu)
  70     end
  71   in
  72   snd (traverse_rec AddrSet.empty pc accu)
  73
  74 (****)
  75
  76 let is_trivial instr last =
  77   instr = []
  78     &&
  79   begin match last with
  80     Return _ | Raise _ | Stop | Branch _       -> true
  81   | Cond _ | Poptrap _ | Switch _ | Pushtrap _ -> false
  82   end
  83
  84 let resolve_branch blocks (pc, args) =
  85   match AddrMap.find pc blocks with
  86     {params = []; body = []; branch = Branch (pc', args')} ->
  87       Some (pc', args')
  88   | _ ->
  89       None
  90
  91 let concat_blocks pc instr params handler args params' instr' last' =
  92   (* This is only valid because we know that the params only occur in
  93      the block *)
  94   let m = Subst.build_mapping params' args in
  95   let s = Subst.from_map m in
  96     { params = params;
  97       handler = handler;
  98       body = instr @ Subst.instrs s instr';
  99       branch = Subst.last s last' }
 100
 101 let rec block_simpl pc (preds, entries, blocks) =
 102 Format.eprintf "VV %d@." pc;
 103 (*
 104 Format.eprintf "RRRRRRRRRRRRRRR %d@." (AddrSet.cardinal (AddrMap.find 12644 preds));
 105 *)
 106   let block = AddrMap.find pc blocks in
 107     match block.branch with
 108         Return _ | Raise _ | Stop | Poptrap _ ->
 109           (preds, entries, blocks)
 110       | Branch (pc', args) ->
 111           let block' = AddrMap.find pc' blocks in
 112           if
 113 false
 114 (*XXX FIX!
 115             not (AddrSet.mem pc' entries)
 116               &&
 117             AddrSet.cardinal (AddrMap.find pc' preds) = 1
 118               &&
 119             block'.params = [] && block'.handler = block.handler
 120 *)
 121           then begin
 122 Format.eprintf "UU %d ==> %d@." pc pc';
 123             (preds,
 124              entries,
 125              AddrMap.add pc
 126                (concat_blocks pc block.body block.params block.handler args
 127                   block'.params block'.body block'.branch)
 128                (AddrMap.remove pc' blocks))
 129           end else if false(*XXX args = [] && is_trivial block'.body block'.branch *)then begin
 130             (AddrMap.add pc' (AddrSet.remove pc (AddrMap.find pc' preds))
 131                preds,
 132              entries,
 133              AddrMap.add
 134                pc (concat_blocks
 135                      pc block.body block.params block.handler args
 136                      block'.params block'.body block'.branch)
 137                blocks)
 138           end else
 139             (preds, entries, blocks)
 140       | Cond (c, x, cont1, cont2) ->
 141           if cont1 = cont2 then begin
 142             let blocks =
 143               AddrMap.add pc {block with branch = Branch cont1 } blocks in
 144             block_simpl pc (preds, entries, blocks)
 145           end else begin
 146             match resolve_branch blocks cont1 with
 147               Some cont1' ->
 148                 let pc1 = fst cont1 in let pc1' = fst cont1' in
 149                 let preds =
 150                   AddrMap.add pc1'
 151                     (AddrSet.add pc
 152                        (AddrSet.remove pc1 (AddrMap.find pc1' preds)))
 153                     preds
 154                 in
 155                 let blocks =
 156                   AddrMap.add pc
 157                     { block with branch = Cond (c, x, cont1', cont2) } blocks
 158                 in
 159                 block_simpl pc (preds, entries, blocks)
 160             | None ->
 161                 match resolve_branch blocks cont2 with
 162                   Some cont2' ->
 163                     let pc2 = fst cont2 in let pc2' = fst cont2' in
 164                     let preds =
 165                       AddrMap.add pc2'
 166                         (AddrSet.add pc
 167                            (AddrSet.remove pc2 (AddrMap.find pc2' preds)))
 168                         preds
 169                     in
 170                     let blocks =
 171                       AddrMap.add pc
 172                         { block with branch = Cond (c, x, cont1, cont2') }
 173                         blocks
 174                     in
 175                     block_simpl pc (preds, entries, blocks)
 176                 | None ->
 177                     (preds, entries, blocks)
 178           end
 179       | Switch (x, a1, a2) ->
 180           let a1 =
 181             Array.map
 182               (fun pc ->
 183                  match resolve_branch blocks pc with Some pc -> pc | None -> pc)
 184               a1 in
 185           let a2 =
 186             Array.map
 187               (fun pc ->
 188                  match resolve_branch blocks pc with Some pc -> pc | None -> pc)
 189               a2 in
 190             (preds, entries,
 191              AddrMap.add pc { block with branch = Switch (x, a1, a2) } blocks)
 192       | Pushtrap _ ->
 193           (preds, entries, blocks)
 194
 195 let simpl (pc, blocks, free_pc) =
 196   let preds = AddrMap.map (fun _ -> AddrSet.empty) blocks in
 197   let entries = AddrSet.empty in
 198   let add_pred pc (pc', _) preds =
 199 Format.eprintf "%d ==> %d@." pc pc';
 200     AddrMap.add pc' (AddrSet.add pc (AddrMap.find pc' preds)) preds in
 201   let (preds, entries) =
 202     AddrMap.fold
 203       (fun pc block (preds, entries) ->
 204          let entries =
 205            List.fold_left
 206              (fun entries i ->
 207                 match i with
 208                   Let (_, Closure (_, (pc, _))) ->
 209                     AddrSet.add pc entries
 210                 | _ ->
 211                     entries)
 212              entries block.body
 213          in
 214          let preds =
 215            match block.branch with
 216              Return _ | Raise _ | Stop ->
 217                preds
 218            | Branch cont | Poptrap cont ->
 219                add_pred pc cont preds
 220            | Cond (_, _, cont1, cont2)
 221            | Pushtrap (cont1, _, cont2, _) ->
 222                add_pred pc cont1 (add_pred pc cont2 preds)
 223            | Switch (_, a1, a2) ->
 224                let preds =
 225                  Array.fold_left
 226                    (fun preds cont -> add_pred pc cont preds) preds a1 in
 227                let preds =
 228                  Array.fold_left
 229                    (fun preds cont -> add_pred pc cont preds) preds a2 in
 230                preds
 231          in
 232          (preds, entries))
 233       blocks (preds, entries)
 234   in
 235 (*
 236 Format.eprintf "RRRRRRRRRRRRRRR %d@." (AddrSet.cardinal (AddrMap.find 12644 preds));*)
 237   let (_, _, blocks) =
 238     traverse blocks pc block_simpl (preds, entries, blocks) in
 239   (pc, blocks, free_pc)