diff options
Diffstat (limited to 'bytecomp/printlambda.ml')
| -rw-r--r-- | bytecomp/printlambda.ml | 318 |
1 files changed, 163 insertions, 155 deletions
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 78ded6184..6e70043cc 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -12,7 +12,7 @@ (* $Id$ *) -open Formatmsg +open Format open Asttypes open Primitive open Types @@ -20,254 +20,262 @@ open Lambda let rec struct_const ppf = function - Const_base(Const_int n) -> print_int n + | Const_base(Const_int n) -> fprintf ppf "%i" n | Const_base(Const_char c) -> - printf "'%s'" (Char.escaped c) + fprintf ppf "'%s'" (Char.escaped c) | Const_base(Const_string s) -> - printf "\"%s\"" (String.escaped s) + fprintf ppf "\"%s\"" (String.escaped s) | Const_base(Const_float s) -> - print_string s - | Const_pointer n -> printf "%ia" n + fprintf ppf "%s" s + | Const_pointer n -> fprintf ppf "%ia" n | Const_block(tag, []) -> - printf "[%i]" tag + fprintf ppf "[%i]" tag | Const_block(tag, sc1::scl) -> let sconsts ppf scl = - List.iter (fun sc -> printf "@ %a" struct_const sc) scl in - printf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in + fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl | Const_float_array [] -> - print_string "[| |]" + fprintf ppf "[| |]" | Const_float_array (f1 :: fl) -> let floats ppf fl = - List.iter (fun f -> print_space(); print_string f) fl in - printf "@[<1[|@[%s%a@]|]@]" f1 floats fl + List.iter (fun f -> fprintf ppf "@ %s" f) fl in + fprintf ppf "@[<1[|@[%s%a@]|]@]" f1 floats fl let print_id ppf id = Ident.print id let boxed_integer_name = function - Pnativeint -> "nativeint" + | Pnativeint -> "nativeint" | Pint32 -> "int32" | Pint64 -> "int64" -let print_boxed_integer name bi = - printf "%s_%s" (boxed_integer_name bi) name +let print_boxed_integer name ppf bi = + fprintf ppf "%s_%s" (boxed_integer_name bi) name let print_boxed_integer_conversion bi1 bi2 = printf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) -let print_bigarray name kind layout = - printf "Bigarray.%s[%s,%s]" - name - (match kind with - Pbigarray_unknown -> "generic" - | Pbigarray_float32 -> "float32" - | Pbigarray_float64 -> "float64" - | Pbigarray_sint8 -> "sint8" - | Pbigarray_uint8 -> "uint8" - | Pbigarray_sint16 -> "sint16" - | Pbigarray_uint16 -> "uint16" - | Pbigarray_int32 -> "int32" - | Pbigarray_int64 -> "int64" - | Pbigarray_caml_int -> "camlint" - | Pbigarray_native_int -> "nativeint") - (match layout with - Pbigarray_unknown_layout -> "unknown" - | Pbigarray_c_layout -> "C" - | Pbigarray_fortran_layout -> "Fortran") +let boxed_integer_mark name = function + | Pnativeint -> Printf.sprintf "Nativeint.%s" name + | Pint32 -> Printf.sprintf "Int32.%s" name + | Pint64 -> Printf.sprintf "Int64.%s" name + +let print_boxed_integer name ppf bi = + fprintf ppf "%s" (boxed_integer_mark name bi);; + +let print_bigarray name kind ppf layout = + fprintf ppf "Bigarray.%s[%s,%s]" + name + (match kind with + | Pbigarray_unknown -> "generic" + | Pbigarray_float32 -> "float32" + | Pbigarray_float64 -> "float64" + | Pbigarray_sint8 -> "sint8" + | Pbigarray_uint8 -> "uint8" + | Pbigarray_sint16 -> "sint16" + | Pbigarray_uint16 -> "uint16" + | Pbigarray_int32 -> "int32" + | Pbigarray_int64 -> "int64" + | Pbigarray_caml_int -> "camlint" + | Pbigarray_native_int -> "nativeint") + (match layout with + | Pbigarray_unknown_layout -> "unknown" + | Pbigarray_c_layout -> "C" + | Pbigarray_fortran_layout -> "Fortran") let primitive ppf = function - Pidentity -> print_string "id" - | Pignore -> print_string "ignore" - | Pgetglobal id -> printf "global %a" print_id id - | Psetglobal id -> printf "setglobal %a" print_id id - | Pmakeblock(tag, Immutable) -> printf "makeblock %i" tag - | Pmakeblock(tag, Mutable) -> printf "makemutable %i" tag - | Pfield n -> printf "field %i" n + | Pidentity -> fprintf ppf "id" + | Pignore -> fprintf ppf "ignore" + | Pgetglobal id -> fprintf ppf "global %a" print_id id + | Psetglobal id -> fprintf ppf "setglobal %a" print_id id + | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag + | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag + | Pfield n -> fprintf ppf "field %i" n | Psetfield(n, ptr) -> - print_string (if ptr then "setfield_ptr " else "setfield_imm "); - print_int n - | Pfloatfield n -> printf "floatfield %i" n - | Psetfloatfield n -> printf "setfloatfield %i" n - | Pccall p -> print_string p.prim_name - | Praise -> print_string "raise" - | Psequand -> print_string "&&" - | Psequor -> print_string "||" - | Pnot -> print_string "not" - | Pnegint -> print_string "~" - | Paddint -> print_string "+" - | Psubint -> print_string "-" - | Pmulint -> print_string "*" - | Pdivint -> print_string "/" - | Pmodint -> print_string "mod" - | Pandint -> print_string "and" - | Porint -> print_string "or" - | Pxorint -> print_string "xor" - | Plslint -> print_string "lsl" - | Plsrint -> print_string "lsr" - | Pasrint -> print_string "asr" - | Pintcomp(Ceq) -> print_string "==" - | Pintcomp(Cneq) -> print_string "!=" - | Pintcomp(Clt) -> print_string "<" - | Pintcomp(Cle) -> print_string "<=" - | Pintcomp(Cgt) -> print_string ">" - | Pintcomp(Cge) -> print_string ">=" - | Poffsetint n -> print_int n; print_string "+" - | Poffsetref n -> print_int n; print_string "+:=" - | Pintoffloat -> print_string "int_of_float" - | Pfloatofint -> print_string "float_of_int" - | Pnegfloat -> print_string "~." - | Pabsfloat -> print_string "abs." - | Paddfloat -> print_string "+." - | Psubfloat -> print_string "-." - | Pmulfloat -> print_string "*." - | Pdivfloat -> print_string "/." - | Pfloatcomp(Ceq) -> print_string "==." - | Pfloatcomp(Cneq) -> print_string "!=." - | Pfloatcomp(Clt) -> print_string "<." - | Pfloatcomp(Cle) -> print_string "<=." - | Pfloatcomp(Cgt) -> print_string ">." - | Pfloatcomp(Cge) -> print_string ">=." - | Pstringlength -> print_string "string.length" - | Pstringrefu -> print_string "string.unsafe_get" - | Pstringsetu -> print_string "string.unsafe_set" - | Pstringrefs -> print_string "string.get" - | Pstringsets -> print_string "string.set" - | Parraylength _ -> print_string "array.length" - | Pmakearray _ -> print_string "makearray " - | Parrayrefu _ -> print_string "array.unsafe_get" - | Parraysetu _ -> print_string "array.unsafe_set" - | Parrayrefs _ -> print_string "array.get" - | Parraysets _ -> print_string "array.set" - | Pisint -> print_string "isint" - | Pbittest -> print_string "testbit" - | Pbintofint bi -> print_boxed_integer "of_int" bi - | Pintofbint bi -> print_boxed_integer "to_int" bi - | Pcvtbint(bi1, bi2) -> print_boxed_integer_conversion bi1 bi2 - | Pnegbint bi -> print_boxed_integer "neg" bi - | Paddbint bi -> print_boxed_integer "add" bi - | Psubbint bi -> print_boxed_integer "sub" bi - | Pmulbint bi -> print_boxed_integer "mul" bi - | Pdivbint bi -> print_boxed_integer "div" bi - | Pmodbint bi -> print_boxed_integer "mod" bi - | Pandbint bi -> print_boxed_integer "and" bi - | Porbint bi -> print_boxed_integer "or" bi - | Pxorbint bi -> print_boxed_integer "xor" bi - | Plslbint bi -> print_boxed_integer "lsl" bi - | Plsrbint bi -> print_boxed_integer "lsr" bi - | Pasrbint bi -> print_boxed_integer "asr" bi - | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" bi - | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" bi - | Pbintcomp(bi, Clt) -> print_boxed_integer "<" bi - | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" bi - | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" bi - | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" bi - | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind layout - | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind layout + let instr = if ptr then "setfield_ptr " else "setfield_imm " in + fprintf ppf "%s%i" instr n + | Pfloatfield n -> fprintf ppf "floatfield %i" n + | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n + | Pccall p -> fprintf ppf "%s" p.prim_name + | Praise -> fprintf ppf "raise" + | Psequand -> fprintf ppf "&&" + | Psequor -> fprintf ppf "||" + | Pnot -> fprintf ppf "not" + | Pnegint -> fprintf ppf "~" + | Paddint -> fprintf ppf "+" + | Psubint -> fprintf ppf "-" + | Pmulint -> fprintf ppf "*" + | Pdivint -> fprintf ppf "/" + | Pmodint -> fprintf ppf "mod" + | Pandint -> fprintf ppf "and" + | Porint -> fprintf ppf "or" + | Pxorint -> fprintf ppf "xor" + | Plslint -> fprintf ppf "lsl" + | Plsrint -> fprintf ppf "lsr" + | Pasrint -> fprintf ppf "asr" + | Pintcomp(Ceq) -> fprintf ppf "==" + | Pintcomp(Cneq) -> fprintf ppf "!=" + | Pintcomp(Clt) -> fprintf ppf "<" + | Pintcomp(Cle) -> fprintf ppf "<=" + | Pintcomp(Cgt) -> fprintf ppf ">" + | Pintcomp(Cge) -> fprintf ppf ">=" + | Poffsetint n -> fprintf ppf "%i+" n + | Poffsetref n -> fprintf ppf "+:=%i"n + | Pintoffloat -> fprintf ppf "int_of_float" + | Pfloatofint -> fprintf ppf "float_of_int" + | Pnegfloat -> fprintf ppf "~." + | Pabsfloat -> fprintf ppf "abs." + | Paddfloat -> fprintf ppf "+." + | Psubfloat -> fprintf ppf "-." + | Pmulfloat -> fprintf ppf "*." + | Pdivfloat -> fprintf ppf "/." + | Pfloatcomp(Ceq) -> fprintf ppf "==." + | Pfloatcomp(Cneq) -> fprintf ppf "!=." + | Pfloatcomp(Clt) -> fprintf ppf "<." + | Pfloatcomp(Cle) -> fprintf ppf "<=." + | Pfloatcomp(Cgt) -> fprintf ppf ">." + | Pfloatcomp(Cge) -> fprintf ppf ">=." + | Pstringlength -> fprintf ppf "string.length" + | Pstringrefu -> fprintf ppf "string.unsafe_get" + | Pstringsetu -> fprintf ppf "string.unsafe_set" + | Pstringrefs -> fprintf ppf "string.get" + | Pstringsets -> fprintf ppf "string.set" + | Parraylength _ -> fprintf ppf "array.length" + | Pmakearray _ -> fprintf ppf "makearray " + | Parrayrefu _ -> fprintf ppf "array.unsafe_get" + | Parraysetu _ -> fprintf ppf "array.unsafe_set" + | Parrayrefs _ -> fprintf ppf "array.get" + | Parraysets _ -> fprintf ppf "array.set" + | Pisint -> fprintf ppf "isint" + | Pbittest -> fprintf ppf "testbit" + | Pbintofint bi -> print_boxed_integer "of_int" ppf bi + | Pintofbint bi -> print_boxed_integer "to_int" ppf bi + | Pnegbint bi -> print_boxed_integer "neg" ppf bi + | Paddbint bi -> print_boxed_integer "add" ppf bi + | Psubbint bi -> print_boxed_integer "sub" ppf bi + | Pmulbint bi -> print_boxed_integer "mul" ppf bi + | Pdivbint bi -> print_boxed_integer "div" ppf bi + | Pmodbint bi -> print_boxed_integer "mod" ppf bi + | Pandbint bi -> print_boxed_integer "and" ppf bi + | Porbint bi -> print_boxed_integer "or" ppf bi + | Pxorbint bi -> print_boxed_integer "xor" ppf bi + | Plslbint bi -> print_boxed_integer "lsl" ppf bi + | Plsrbint bi -> print_boxed_integer "lsr" ppf bi + | Pasrbint bi -> print_boxed_integer "asr" ppf bi + | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi + | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi + | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi + | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi + | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi + | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi + | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout + | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout let rec lam ppf = function - Lvar id -> + | Lvar id -> print_id ppf id | Lconst cst -> struct_const ppf cst | Lapply(lfun, largs) -> let lams ppf largs = - List.iter (fun l -> printf "@ %a" lam l) largs in - printf "@[<2>(apply@ %a%a)@]" lam lfun lams largs + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs | Lfunction(kind, params, body) -> let pr_params ppf params = match kind with | Curried -> - List.iter (fun param -> printf "@ %a" print_id param) params + List.iter (fun param -> fprintf ppf "@ %a" print_id param) params | Tupled -> - print_string " ("; + fprintf ppf " ("; let first = ref true in List.iter (fun param -> - if !first then first := false else printf ",@ "; + if !first then first := false else fprintf ppf ",@ "; print_id ppf param) params; - print_string ")" in - printf "@[<2>(function%a@ %a)@]" pr_params params lam body + fprintf ppf ")" in + fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body | Llet(str, id, arg, body) -> let rec letbody = function | Llet(str, id, arg, body) -> - printf "@ @[<2>%a@ %a@]" print_id id lam arg; + fprintf ppf "@ @[<2>%a@ %a@]" print_id id lam arg; letbody body | expr -> expr in - printf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" print_id id lam arg; + fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" print_id id lam arg; let expr = letbody body in - printf ")@]@ %a)@]" lam expr + fprintf ppf ")@]@ %a)@]" lam expr | Lletrec(id_arg_list, body) -> let bindings ppf id_arg_list = let spc = ref false in List.iter (fun (id, l) -> if !spc then print_space() else spc := true; - printf "@[<2>%a@ %a@]" print_id id lam l) + fprintf ppf "@[<2>%a@ %a@]" print_id id lam l) id_arg_list in - printf "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body + fprintf ppf + "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body | Lprim(prim, largs) -> let lams ppf largs = - List.iter (fun l -> printf "@ %a" lam l) largs in - printf "@[<2>(%a%a)@]" primitive prim lams largs + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs | Lswitch(larg, sw) -> let switch ppf sw = let spc = ref false in List.iter (fun (n, l) -> if !spc then print_space() else spc := true; - printf "@[<hv 1>case int %i:@ %a@]" n lam l) + fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l) sw.sw_consts; List.iter (fun (n, l) -> if !spc then print_space() else spc := true; - printf "@[<hv 1>case tag %i:@ %a@]" n lam l) + fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l) sw.sw_blocks in - printf + fprintf ppf "@[<1>(%s%a@ @[<v 0>%a@])@]" (if sw.sw_checked then "switch-checked " else "switch ") lam larg switch sw | Lstaticfail -> - print_string "exit" + fprintf ppf "exit" | Lcatch(lbody, lhandler) -> - printf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler | Ltrywith(lbody, param, lhandler) -> - printf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody print_id param lam lhandler | Lifthenelse(lcond, lif, lelse) -> - printf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse | Lsequence(l1, l2) -> - printf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 | Lwhile(lcond, lbody) -> - printf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody | Lfor(param, lo, hi, dir, body) -> - printf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" print_id param lam lo (match dir with Upto -> "to" | Downto -> "downto") lam hi lam body | Lassign(id, expr) -> - printf "@[<2>(assign@ %a@ %a)@]" print_id id lam expr + fprintf ppf "@[<2>(assign@ %a@ %a)@]" print_id id lam expr | Lsend (met, obj, largs) -> let args ppf largs = - List.iter (fun l -> printf "@ %a" lam l) largs in - printf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs | Levent(expr, ev) -> let kind = match ev.lev_kind with | Lev_before -> "before" | Lev_after _ -> "after" | Lev_function -> "funct-body" in - printf "@[<2>(%s %i@ %a)@]" kind ev.lev_loc lam expr + fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_loc lam expr | Lifused(id, expr) -> - printf "@[<2>(ifused@ %a@ %a)@]" print_id id lam expr + fprintf ppf "@[<2>(ifused@ %a@ %a)@]" print_id id lam expr and sequence ppf = function - Lsequence(l1, l2) -> - printf "%a@ %a" sequence l1 sequence l2 + | Lsequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 | Llet(str, id, arg, body) -> - printf "@[<2>let@ %a@ %a@]@ %a" print_id id lam arg sequence body + fprintf ppf "@[<2>let@ %a@ %a@]@ %a" print_id id lam arg sequence body | l -> lam ppf l -let structured_constant cst = printf "%a" struct_const cst +let structured_constant = struct_const -let lambda l = printf "%a" lam l +let lambda = lam |