naml/naml_ir_util.ml

   1 (*
   2  * utilities for IR, such as printing
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (c) Geoffrey Irving, Dylan Symon
   8  *
   9  * This program is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU General Public License
  11  * as published by the Free Software Foundation; either version 2
  12  * of the License, or (at your option) any later version.
  13  *
  14  * This program is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17  * GNU General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU General Public License
  20  * along with this program; if not, write to the Free Software
  21  * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22  * @end[license]
  23  *)
  24
  25 open Format
  26 open Symbol
  27 open Print_util
  28 open Interval_set
  29 open Fir
  30 open Fir_set
  31 open Fir_print
  32 open Naml_ir
  33 open Naml_ir_exn
  34
  35 (*
  36  * BUG: until we fix this module.
  37  *)
  38 (* JW XXX @ 2007-06-22 : what does the above mean??? *)
  39 let print_symbol = pp_print_symbol Format.std_formatter
  40
  41 (*
  42  * This printer is broken, so use these utilities.
  43  *)
  44 let print_atom = pp_print_atom Format.std_formatter
  45 let print_set = pp_print_set  Format.std_formatter
  46 let print_unop = pp_print_unop Format.std_formatter
  47 let print_binop = pp_print_binop Format.std_formatter
  48 let print_ext = pp_print_ext Format.std_formatter
  49 let print_alloc_op = pp_print_alloc_op Format.std_formatter
  50 let print_subscript a b c = pp_print_subscript a b c Format.std_formatter
  51 let print_type = pp_print_type Format.std_formatter
  52 let print_tydef = pp_print_tydef Format.std_formatter
  53
  54 let rec subst_type st t =
  55   let sub = subst_type st in
  56   match t with
  57       TyFun (tl, t) -> TyFun (List.map sub tl, sub t)
  58     | TyUnion (c, tl, i) -> TyUnion (c, List.map sub tl, i)
  59     | TyTuple (tclass, tl) -> TyTuple (tclass, List.map (fun (ty, b) -> sub ty, b) tl)
  60     | TyArray t -> TyArray (sub t)
  61     | TyVar v -> (try SymbolTable.find st v with Not_found -> t)
  62     | TyApply (v, tl) -> TyApply (v, List.map sub tl)
  63     | _ -> t  (* assumes no TyAggr, TyLambda, TyExists, TySubscript, TyProject *)
  64
  65 let apply_type tenv v tl =
  66   match SymbolTable.find tenv v with
  67       TyDefLambda (tvl, t) ->
  68         let substs = List.fold_left2 SymbolTable.add SymbolTable.empty tvl tl in
  69           subst_type substs t
  70     | _ -> raise (IRException "tried to apply a union type")
  71
  72 let type_of_alloc_op ao =
  73    match ao with
  74       AllocTuple (_, ty_vars, ty, _)
  75     | AllocUnion (ty_vars, ty, _, _, _) ->
  76          TyAll (ty_vars, ty)
  77     | AllocArray (ty, _)
  78     | AllocVArray (ty, _, _, _)
  79     | AllocMalloc (ty, _)
  80     | AllocDTuple (ty, _, _, _) ->
  81          ty
  82     | AllocFrame (v, tyl) ->
  83          TyFrame (v, tyl)
  84
  85 let rec polymorphic t =
  86   let pm = polymorphic in
  87   match t with
  88      TyFun (tl, t) -> List.exists pm tl || pm t
  89    | TyUnion (_, tl, _)
  90    | TyApply (_, tl) -> List.exists pm tl
  91    | TyTuple (_, tl) -> List.exists (fun (ty, _) -> pm ty) tl
  92    | TyArray t -> pm t
  93    | TyVar v -> true
  94    | _ -> false
  95
  96 (*
  97  * Default tabstop.
  98  *)
  99 let tabstop = 2
 100
 101 (*
 102  * Separated list of fields.
 103  *)
 104 let print_sep_list sep printer l =
 105    Format.open_hvbox 0;
 106    ignore (List.fold_left (fun first x ->
 107                  if not first then
 108                     begin
 109                        Format.print_string sep;
 110                        Format.print_space ()
 111                     end;
 112                  Format.open_hvbox tabstop;
 113                  printer x;
 114                  Format.close_box ();
 115                  false) true l);
 116    Format.close_box ()
 117
 118 (*
 119  * Separated list of fields.
 120  *)
 121 let print_pre_sep_list sep printer l =
 122    Format.open_hvbox 0;
 123    ignore (List.fold_left (fun first x ->
 124                  if not first then
 125                     begin
 126                        Format.print_space ();
 127                        Format.print_string sep
 128                     end;
 129                  Format.open_hvbox tabstop;
 130                  printer x;
 131                  Format.close_box ();
 132                  false) true l);
 133    Format.close_box ()
 134
 135 (*
 136  * "Let" opener.
 137  *)
 138 let print_let_open v ty =
 139    Format.open_hvbox tabstop;
 140    Format.print_string "let ";
 141    print_symbol v;
 142    Format.print_string " :";
 143    Format.print_space ();
 144    pp_print_type Format.std_formatter ty;
 145    Format.print_string " =";
 146    Format.print_space ()
 147
 148 let print_let_vars_open vars v ty =
 149    Format.open_hvbox tabstop;
 150    Format.print_string "let ";
 151    print_sep_list "," (fun v ->
 152          Format.print_string "'";
 153          print_symbol v) vars;
 154    if vars <> [] then
 155       Format.print_string ", ";
 156    print_symbol v;
 157    Format.print_string " :";
 158    Format.print_space ();
 159    pp_print_type Format.std_formatter ty;
 160    Format.print_string " =";
 161    Format.print_space ()
 162
 163 let rec print_let_close e =
 164    Format.print_string " in";
 165    Format.close_box ();
 166    Format.print_space ();
 167    print_expr e
 168
 169 (*
 170  * Rename all the vars in the expr.
 171  *)
 172 and print_expr e =
 173    match e with
 174       LetAtom (v, ty, a, e) ->
 175          print_let_open v ty;
 176          print_atom a;
 177          print_let_close e
 178     | LetUnop (v, ty, op, a, e) ->
 179          print_let_open v ty;
 180          print_unop op a;
 181          print_let_close e
 182     | LetBinop (v, ty, op, a1, a2, e) ->
 183          print_let_open v ty;
 184          print_binop op a1 a2;
 185          print_let_close e
 186     | LetExt (v, ty, s, ty2, args, e) ->
 187          print_let_open v ty;
 188          print_ext s ty2 [] args;
 189          print_let_close e
 190     | TailCall (f, args) ->
 191          print_symbol f;
 192          Format.print_string "(";
 193          print_sep_list "," print_atom args;
 194          Format.print_string ")"
 195     | Match (a, cases) ->
 196          Format.open_hvbox tabstop;
 197          Format.print_string "match ";
 198          print_atom a;
 199          Format.print_string " with";
 200          List.iter (fun (set, e) ->
 201                Format.print_space ();
 202                Format.open_hvbox tabstop;
 203                Format.print_string "| ";
 204                print_set set;
 205                Format.print_string " ->";
 206                Format.print_space ();
 207                print_expr e;
 208                Format.close_box ()) cases;
 209          Format.close_box ()
 210     | LetAlloc (v, op, e) ->
 211          Format.open_hvbox tabstop;
 212          Format.print_string "let ";
 213          print_symbol v;
 214          Format.printf " =@ ";
 215          Format.open_hvbox tabstop;
 216          print_alloc_op op;
 217          Format.close_box ();
 218          print_let_close e
 219
 220     | LetSubscript (so, v, ty, v2, a, e) ->
 221          print_let_open v ty;
 222          print_subscript so (AtomVar v2) a;
 223          print_let_close e
 224
 225     | SetSubscript (so, v, a1, ty, a2, e) ->
 226          print_subscript so (AtomVar v) a1;
 227          Format.print_string " : ";
 228          pp_print_type Format.std_formatter ty;
 229          Format.print_string " <- ";
 230          print_atom a2;
 231          Format.print_string ";";
 232          Format.print_space ();
 233          print_expr e
 234
 235     | LetFuns (defs, e) ->
 236          Format.open_hvbox tabstop;
 237          Format.print_string "let ";
 238          print_sep_list " and" print_function defs;
 239          print_let_close e
 240
 241     | LetApply (v, ty, a, al, e) ->
 242          print_let_open v ty;
 243          print_symbol a;
 244          Format.print_string "(";
 245          print_sep_list "," print_atom al;
 246          Format.print_string ")";
 247          print_let_close e
 248     | LetClosure (v, ty, a, al, e) ->
 249          print_let_open v ty;
 250          Format.print_string "closure ";
 251          print_symbol a;
 252          Format.print_string "(";
 253          print_sep_list "," print_atom al;
 254          Format.print_string ")";
 255          print_let_close e
 256     | Return (a) ->
 257         Format.open_hvbox tabstop;
 258         Format.print_string "return ";
 259         print_atom a;
 260         Format.close_box ()
 261     | LetExnHandler (v, e) ->
 262         Format.open_hvbox tabstop;
 263         Format.print_string "try ";
 264         print_expr e;
 265         Format.print_string "with ";
 266         print_symbol v;
 267         Format.close_box ()
 268     | Raise (a) ->
 269         Format.open_hvbox tabstop;
 270         Format.print_string "raise ";
 271         print_atom a;
 272         Format.close_box ()
 273
 274 and print_gflag = function
 275     FunGlobalClass ->
 276       Format.print_string "$global ";
 277   | FunContClass ->
 278       Format.print_string "$continuation "
 279   | FunLocalClass ->
 280       Format.print_string "$local "
 281
 282 and print_function (f, _, gflag, f_ty, vars, body) =
 283    Format.print_string "(";
 284    print_gflag gflag;
 285    print_symbol f;
 286    Format.print_string " : ";
 287    print_type f_ty;
 288    Format.print_string ")";
 289    Format.print_string "(";
 290    print_sep_list "," print_symbol vars;
 291    Format.print_string ") =";
 292    Format.print_space ();
 293    print_expr body
 294
 295 (************************************************************************
 296  * GLOBAL FUNCTIONS
 297  ************************************************************************)
 298
 299 let print_prog
 300     { prog_cont = fini;
 301       prog_types = types;
 302       prog_body = expr
 303     } =
 304
 305    Format.open_hvbox tabstop;
 306    Format.print_string "Program cont symbol:";
 307    Format.print_space ();
 308    print_symbol fini;
 309    Format.close_box ();
 310
 311    Format.print_space ();
 312    Format.open_hvbox tabstop;
 313    Format.print_string "Program types:";
 314    SymbolTable.iter (fun v tyd ->
 315          Format.print_space ();
 316          Format.open_hvbox tabstop;
 317          print_symbol v;
 318          Format.print_string " =";
 319          Format.print_space ();
 320          print_tydef tyd;
 321          Format.close_box ()) types;
 322    Format.close_box ();
 323
 324    Format.print_space ();
 325    Format.open_hvbox tabstop;
 326    Format.print_string "Program body:";
 327    Format.print_newline ();
 328    print_expr expr;
 329    Format.close_box ();
 330