1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* Pretty-print lists of instructions *)
17
18 open Format
19 open Lambda
20 open Instruct
21
22 let instruction ppf = function
23 | Klabel lbl -> fprintf ppf "L%i:" lbl
24 | Kacc n -> fprintf ppf "\tacc %i" n
25 | Kenvacc n -> fprintf ppf "\tenvacc %i" n
26 | Kpush -> fprintf ppf "\tpush"
27 | Kpop n -> fprintf ppf "\tpop %i" n
28 | Kassign n -> fprintf ppf "\tassign %i" n
29 | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl
30 | Kapply n -> fprintf ppf "\tapply %i" n
31 | Kappterm(n, m) ->
32 fprintf ppf "\tappterm %i, %i" n m
33 | Kreturn n -> fprintf ppf "\treturn %i" n
34 | Krestart -> fprintf ppf "\trestart"
35 | Kgrab n -> fprintf ppf "\tgrab %i" n
36 | Kclosure(lbl, n) ->
37 fprintf ppf "\tclosure L%i, %i" lbl n
38 | Kclosurerec(lbls, n) ->
39 fprintf ppf "\tclosurerec";
40 List.iter (fun lbl -> fprintf ppf " %i" lbl) lbls;
41 fprintf ppf ", %i" n
42 | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n
43 | Kgetglobal id -> fprintf ppf "\tgetglobal %a" Ident.print id
44 | Ksetglobal id -> fprintf ppf "\tsetglobal %a" Ident.print id
45 | Kconst cst ->
46 fprintf ppf "@[<10>\tconst@ %a@]" Printlambda.structured_constant cst
47 | Kmakeblock(n, m) ->
48 fprintf ppf "\tmakeblock %i, %i" n m
49 | Kmakefloatblock(n) ->
50 fprintf ppf "\tmakefloatblock %i" n
51 | Kgetfield n -> fprintf ppf "\tgetfield %i" n
52 | Ksetfield n -> fprintf ppf "\tsetfield %i" n
53 | Kgetfloatfield n -> fprintf ppf "\tgetfloatfield %i" n
54 | Ksetfloatfield n -> fprintf ppf "\tsetfloatfield %i" n
55 | Kvectlength -> fprintf ppf "\tvectlength"
56 | Kgetvectitem -> fprintf ppf "\tgetvectitem"
57 | Ksetvectitem -> fprintf ppf "\tsetvectitem"
58 | Kgetstringchar -> fprintf ppf "\tgetstringchar"
59 | Kgetbyteschar -> fprintf ppf "\tgetbyteschar"
60 | Ksetbyteschar -> fprintf ppf "\tsetbyteschar"
61 | Kbranch lbl -> fprintf ppf "\tbranch L%i" lbl
62 | Kbranchif lbl -> fprintf ppf "\tbranchif L%i" lbl
63 | Kbranchifnot lbl -> fprintf ppf "\tbranchifnot L%i" lbl
64 | Kstrictbranchif lbl -> fprintf ppf "\tstrictbranchif L%i" lbl
65 | Kstrictbranchifnot lbl ->
66 fprintf ppf "\tstrictbranchifnot L%i" lbl
67 | Kswitch(consts, blocks) ->
68 let labels ppf labs =
69 Array.iter (fun lbl -> fprintf ppf "@ %i" lbl) labs in
70 fprintf ppf "@[<10>\tswitch%a/%a@]" labels consts labels blocks
71 | Kboolnot -> fprintf ppf "\tboolnot"
72 | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl
73 | Kpoptrap -> fprintf ppf "\tpoptrap"
74 | Kraise k-> fprintf ppf "\t%s" (Lambda.raise_kind k)
75 | Kcheck_signals -> fprintf ppf "\tcheck_signals"
76 | Kccall(s, n) ->
77 fprintf ppf "\tccall %s, %i" s n
78 | Knegint -> fprintf ppf "\tnegint"
79 | Kaddint -> fprintf ppf "\taddint"
80 | Ksubint -> fprintf ppf "\tsubint"
81 | Kmulint -> fprintf ppf "\tmulint"
82 | Kdivint -> fprintf ppf "\tdivint"
83 | Kmodint -> fprintf ppf "\tmodint"
84 | Kandint -> fprintf ppf "\tandint"
85 | Korint -> fprintf ppf "\torint"
86 | Kxorint -> fprintf ppf "\txorint"
87 | Klslint -> fprintf ppf "\tlslint"
88 | Klsrint -> fprintf ppf "\tlsrint"
89 | Kasrint -> fprintf ppf "\tasrint"
90 | Kintcomp Ceq -> fprintf ppf "\teqint"
91 | Kintcomp Cne -> fprintf ppf "\tneqint"
92 | Kintcomp Clt -> fprintf ppf "\tltint"
93 | Kintcomp Cgt -> fprintf ppf "\tgtint"
94 | Kintcomp Cle -> fprintf ppf "\tleint"
95 | Kintcomp Cge -> fprintf ppf "\tgeint"
96 | Koffsetint n -> fprintf ppf "\toffsetint %i" n
97 | Koffsetref n -> fprintf ppf "\toffsetref %i" n
98 | Kisint -> fprintf ppf "\tisint"
99 | Kisout -> fprintf ppf "\tisout"
100 | Kgetmethod -> fprintf ppf "\tgetmethod"
101 | Kgetpubmet n -> fprintf ppf "\tgetpubmet %i" n
102 | Kgetdynmet -> fprintf ppf "\tgetdynmet"
103 | Kstop -> fprintf ppf "\tstop"
104 | Kevent ev -> fprintf ppf "\tevent \"%s\" %i-%i"
105 ev.ev_loc.Location.loc_start.Lexing.pos_fname
106 ev.ev_loc.Location.loc_start.Lexing.pos_cnum
107 ev.ev_loc.Location.loc_end.Lexing.pos_cnum
108
109 let rec instruction_list ppf = function
110 [] -> ()
111 | Klabel lbl :: il ->
112 fprintf ppf "L%i:%a" lbl instruction_list il
113 | instr :: il ->
114 fprintf ppf "%a@ %a" instruction instr instruction_list il
115
116 let instrlist ppf il =
117 fprintf ppf "@[<v 0>%a@]" instruction_list il
118