bytecomp/printlambda.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 open Format
  16 open Asttypes
  17 open Primitive
  18 open Types
  19 open Lambda
  20
  21
  22 let rec struct_const ppf = function
  23   | Const_base(Const_int n) -> fprintf ppf "%i" n
  24   | Const_base(Const_char c) -> fprintf ppf "%C" c
  25   | Const_base(Const_string s) -> fprintf ppf "%S" s
  26   | Const_immstring s -> fprintf ppf "#%S" s
  27   | Const_base(Const_float f) -> fprintf ppf "%s" f
  28   | Const_base(Const_int32 n) -> fprintf ppf "%lil" n
  29   | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
  30   | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n
  31   | Const_pointer n -> fprintf ppf "%ia" n
  32   | Const_block(tag, []) ->
  33       fprintf ppf "[%i]" tag
  34   | Const_block(tag, sc1::scl) ->
  35       let sconsts ppf scl =
  36         List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in
  37       fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl
  38   | Const_float_array [] ->
  39       fprintf ppf "[| |]"
  40   | Const_float_array (f1 :: fl) ->
  41       let floats ppf fl =
  42         List.iter (fun f -> fprintf ppf "@ %s" f) fl in
  43       fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl
  44
  45 let boxed_integer_name = function
  46   | Pnativeint -> "nativeint"
  47   | Pint32 -> "int32"
  48   | Pint64 -> "int64"
  49
  50 let print_boxed_integer name ppf bi =
  51   fprintf ppf "%s_%s" (boxed_integer_name bi) name
  52
  53 let print_boxed_integer_conversion ppf bi1 bi2 =
  54   fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)
  55
  56 let boxed_integer_mark name = function
  57   | Pnativeint -> Printf.sprintf "Nativeint.%s" name
  58   | Pint32 -> Printf.sprintf "Int32.%s" name
  59   | Pint64 -> Printf.sprintf "Int64.%s" name
  60
  61 let print_boxed_integer name ppf bi =
  62   fprintf ppf "%s" (boxed_integer_mark name bi);;
  63
  64 let print_bigarray name kind ppf layout =
  65   fprintf ppf "Bigarray.%s[%s,%s]"
  66     name
  67     (match kind with
  68      | Pbigarray_unknown -> "generic"
  69      | Pbigarray_float32 -> "float32"
  70      | Pbigarray_float64 -> "float64"
  71      | Pbigarray_sint8 -> "sint8"
  72      | Pbigarray_uint8 -> "uint8"
  73      | Pbigarray_sint16 -> "sint16"
  74      | Pbigarray_uint16 -> "uint16"
  75      | Pbigarray_int32 -> "int32"
  76      | Pbigarray_int64 -> "int64"
  77      | Pbigarray_caml_int -> "camlint"
  78      | Pbigarray_native_int -> "nativeint"
  79      | Pbigarray_complex32 -> "complex32"
  80      | Pbigarray_complex64 -> "complex64")
  81     (match layout with
  82     |  Pbigarray_unknown_layout -> "unknown"
  83      | Pbigarray_c_layout -> "C"
  84      | Pbigarray_fortran_layout -> "Fortran")
  85
  86 let record_rep ppf r =
  87   match r with
  88   | Record_regular -> fprintf ppf "regular"
  89   | Record_float -> fprintf ppf "float"
  90 ;;
  91
  92 let primitive ppf = function
  93   | Pidentity -> fprintf ppf "id"
  94   | Pignore -> fprintf ppf "ignore"
  95   | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
  96   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
  97   | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag
  98   | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag
  99   | Pfield n -> fprintf ppf "field %i" n
 100   | Psetfield(n, ptr) ->
 101       let instr = if ptr then "setfield_ptr " else "setfield_imm " in
 102       fprintf ppf "%s%i" instr n
 103   | Pfloatfield n -> fprintf ppf "floatfield %i" n
 104   | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n
 105   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size
 106   | Pccall p -> fprintf ppf "%s" p.prim_name
 107   | Praise -> fprintf ppf "raise"
 108   | Psequand -> fprintf ppf "&&"
 109   | Psequor -> fprintf ppf "||"
 110   | Pnot -> fprintf ppf "not"
 111   | Pnegint -> fprintf ppf "~"
 112   | Paddint -> fprintf ppf "+"
 113   | Psubint -> fprintf ppf "-"
 114   | Pmulint -> fprintf ppf "*"
 115   | Pdivint -> fprintf ppf "/"
 116   | Pmodint -> fprintf ppf "mod"
 117   | Pandint -> fprintf ppf "and"
 118   | Porint -> fprintf ppf "or"
 119   | Pxorint -> fprintf ppf "xor"
 120   | Plslint -> fprintf ppf "lsl"
 121   | Plsrint -> fprintf ppf "lsr"
 122   | Pasrint -> fprintf ppf "asr"
 123   | Pintcomp(Ceq) -> fprintf ppf "=="
 124   | Pintcomp(Cneq) -> fprintf ppf "!="
 125   | Pintcomp(Clt) -> fprintf ppf "<"
 126   | Pintcomp(Cle) -> fprintf ppf "<="
 127   | Pintcomp(Cgt) -> fprintf ppf ">"
 128   | Pintcomp(Cge) -> fprintf ppf ">="
 129   | Poffsetint n -> fprintf ppf "%i+" n
 130   | Poffsetref n -> fprintf ppf "+:=%i"n
 131   | Pintoffloat -> fprintf ppf "int_of_float"
 132   | Pfloatofint -> fprintf ppf "float_of_int"
 133   | Pnegfloat -> fprintf ppf "~."
 134   | Pabsfloat -> fprintf ppf "abs."
 135   | Paddfloat -> fprintf ppf "+."
 136   | Psubfloat -> fprintf ppf "-."
 137   | Pmulfloat -> fprintf ppf "*."
 138   | Pdivfloat -> fprintf ppf "/."
 139   | Pfloatcomp(Ceq) -> fprintf ppf "==."
 140   | Pfloatcomp(Cneq) -> fprintf ppf "!=."
 141   | Pfloatcomp(Clt) -> fprintf ppf "<."
 142   | Pfloatcomp(Cle) -> fprintf ppf "<=."
 143   | Pfloatcomp(Cgt) -> fprintf ppf ">."
 144   | Pfloatcomp(Cge) -> fprintf ppf ">=."
 145   | Pstringlength -> fprintf ppf "string.length"
 146   | Pstringrefu -> fprintf ppf "string.unsafe_get"
 147   | Pstringsetu -> fprintf ppf "string.unsafe_set"
 148   | Pstringrefs -> fprintf ppf "string.get"
 149   | Pstringsets -> fprintf ppf "string.set"
 150   | Parraylength _ -> fprintf ppf "array.length"
 151   | Pmakearray _ -> fprintf ppf "makearray "
 152   | Parrayrefu _ -> fprintf ppf "array.unsafe_get"
 153   | Parraysetu _ -> fprintf ppf "array.unsafe_set"
 154   | Parrayrefs _ -> fprintf ppf "array.get"
 155   | Parraysets _ -> fprintf ppf "array.set"
 156   | Pisint -> fprintf ppf "isint"
 157   | Pisout -> fprintf ppf "isout"
 158   | Pbittest -> fprintf ppf "testbit"
 159   | Pbintofint bi -> print_boxed_integer "of_int" ppf bi
 160   | Pintofbint bi -> print_boxed_integer "to_int" ppf bi
 161   | Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2
 162   | Pnegbint bi -> print_boxed_integer "neg" ppf bi
 163   | Paddbint bi -> print_boxed_integer "add" ppf bi
 164   | Psubbint bi -> print_boxed_integer "sub" ppf bi
 165   | Pmulbint bi -> print_boxed_integer "mul" ppf bi
 166   | Pdivbint bi -> print_boxed_integer "div" ppf bi
 167   | Pmodbint bi -> print_boxed_integer "mod" ppf bi
 168   | Pandbint bi -> print_boxed_integer "and" ppf bi
 169   | Porbint bi -> print_boxed_integer "or" ppf bi
 170   | Pxorbint bi -> print_boxed_integer "xor" ppf bi
 171   | Plslbint bi -> print_boxed_integer "lsl" ppf bi
 172   | Plsrbint bi -> print_boxed_integer "lsr" ppf bi
 173   | Pasrbint bi -> print_boxed_integer "asr" ppf bi
 174   | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi
 175   | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi
 176   | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi
 177   | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
 178   | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
 179   | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
 180   | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout
 181   | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout
 182
 183 let rec lam ppf = function
 184   | Lvar id ->
 185       Ident.print ppf id
 186   | Lconst cst ->
 187       struct_const ppf cst
 188   | Lapply(lfun, largs) ->
 189       let lams ppf largs =
 190         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
 191       fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
 192   | Lfunction(kind, params, body) ->
 193       let pr_params ppf params =
 194         match kind with
 195         | Curried ->
 196             List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params
 197         | Tupled ->
 198             fprintf ppf " (";
 199             let first = ref true in
 200             List.iter
 201               (fun param ->
 202                 if !first then first := false else fprintf ppf ",@ ";
 203                 Ident.print ppf param)
 204               params;
 205             fprintf ppf ")" in
 206       fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
 207   | Llet(str, id, arg, body) ->
 208       let rec letbody = function
 209         | Llet(str, id, arg, body) ->
 210             fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
 211             letbody body
 212         | expr -> expr in
 213       fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
 214       let expr = letbody body in
 215       fprintf ppf ")@]@ %a)@]" lam expr
 216   | Lletrec(id_arg_list, body) ->
 217       let bindings ppf id_arg_list =
 218         let spc = ref false in
 219         List.iter
 220           (fun (id, l) ->
 221             if !spc then fprintf ppf "@ " else spc := true;
 222             fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l)
 223           id_arg_list in
 224       fprintf ppf
 225         "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
 226   | Lprim(prim, largs) ->
 227       let lams ppf largs =
 228         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
 229       fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
 230   | Lswitch(larg, sw) ->
 231       let switch ppf sw =
 232         let spc = ref false in
 233         List.iter
 234          (fun (n, l) ->
 235            if !spc then fprintf ppf "@ " else spc := true;
 236            fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l)
 237          sw.sw_consts;
 238         List.iter
 239           (fun (n, l) ->
 240             if !spc then fprintf ppf "@ " else spc := true;
 241             fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
 242           sw.sw_blocks ;
 243         begin match sw.sw_failaction with
 244         | None  -> ()
 245         | Some l ->
 246             if !spc then fprintf ppf "@ " else spc := true;
 247             fprintf ppf "@[<hv 1>default:@ %a@]" lam l
 248         end in
 249
 250       fprintf ppf
 251        "@[<1>(%s %a@ @[<v 0>%a@])@]"
 252        (match sw.sw_failaction with None -> "switch*" | _ -> "switch")
 253        lam larg switch sw
 254   | Lstaticraise (i, ls)  ->
 255       let lams ppf largs =
 256         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
 257       fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
 258   | Lstaticcatch(lbody, (i, vars), lhandler) ->
 259       fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
 260         lam lbody i
 261         (fun ppf vars -> match vars with
 262           | [] -> ()
 263           | _ ->
 264               List.iter
 265                 (fun x -> fprintf ppf " %a" Ident.print x)
 266                 vars)
 267         vars
 268         lam lhandler
 269   | Ltrywith(lbody, param, lhandler) ->
 270       fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
 271         lam lbody Ident.print param lam lhandler
 272   | Lifthenelse(lcond, lif, lelse) ->
 273       fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
 274   | Lsequence(l1, l2) ->
 275       fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
 276   | Lwhile(lcond, lbody) ->
 277       fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
 278   | Lfor(param, lo, hi, dir, body) ->
 279       fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
 280        Ident.print param lam lo
 281        (match dir with Upto -> "to" | Downto -> "downto")
 282        lam hi lam body
 283   | Lassign(id, expr) ->
 284       fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
 285   | Lsend (k, met, obj, largs) ->
 286       let args ppf largs =
 287         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
 288       let kind =
 289         if k = Self then "self" else if k = Cached then "cache" else "" in
 290       fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
 291   | Levent(expr, ev) ->
 292       let kind =
 293        match ev.lev_kind with
 294        | Lev_before -> "before"
 295        | Lev_after _  -> "after"
 296        | Lev_function -> "funct-body" in
 297       fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind
 298               ev.lev_loc.Location.loc_start.Lexing.pos_cnum
 299               ev.lev_loc.Location.loc_end.Lexing.pos_cnum
 300               lam expr
 301   | Lifused(id, expr) ->
 302       fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr
 303
 304 and sequence ppf = function
 305   | Lsequence(l1, l2) ->
 306       fprintf ppf "%a@ %a" sequence l1 sequence l2
 307   | l ->
 308       lam ppf l
 309
 310 let structured_constant = struct_const
 311
 312 let lambda = lam