package / ocaml-base-compiler.4.10.0 / middle_end / printclambda_primitives.ml
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
17 open Format
18 open Asttypes
19
20 let boxed_integer_name = function
21 | Lambda.Pnativeint -> "nativeint"
22 | Lambda.Pint32 -> "int32"
23 | Lambda.Pint64 -> "int64"
24
25 let boxed_integer_mark name = function
26 | Lambda.Pnativeint -> Printf.sprintf "Nativeint.%s" name
27 | Lambda.Pint32 -> Printf.sprintf "Int32.%s" name
28 | Lambda.Pint64 -> Printf.sprintf "Int64.%s" name
29
30 let print_boxed_integer name ppf bi =
31 fprintf ppf "%s" (boxed_integer_mark name bi);;
32
33 let array_kind array_kind =
34 let open Lambda in
35 match array_kind with
36 | Pgenarray -> "gen"
37 | Paddrarray -> "addr"
38 | Pintarray -> "int"
39 | Pfloatarray -> "float"
40
41 let access_size size =
42 let open Clambda_primitives in
43 match size with
44 | Sixteen -> "16"
45 | Thirty_two -> "32"
46 | Sixty_four -> "64"
47
48 let access_safety safety =
49 let open Lambda in
50 match safety with
51 | Safe -> ""
52 | Unsafe -> "unsafe_"
53
54 let primitive ppf (prim:Clambda_primitives.primitive) =
55 let open Lambda in
56 let open Clambda_primitives in
57 match prim with
58 | Pread_symbol sym ->
59 fprintf ppf "read_symbol %s" sym
60 | Pmakeblock(tag, Immutable, shape) ->
61 fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape
62 | Pmakeblock(tag, Mutable, shape) ->
63 fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape
64 | Pfield n -> fprintf ppf "field %i" n
65 | Pfield_computed -> fprintf ppf "field_computed"
66 | Psetfield(n, ptr, init) ->
67 let instr =
68 match ptr with
69 | Pointer -> "ptr"
70 | Immediate -> "imm"
71 in
72 let init =
73 match init with
74 | Heap_initialization -> "(heap-init)"
75 | Root_initialization -> "(root-init)"
76 | Assignment -> ""
77 in
78 fprintf ppf "setfield_%s%s %i" instr init n
79 | Psetfield_computed (ptr, init) ->
80 let instr =
81 match ptr with
82 | Pointer -> "ptr"
83 | Immediate -> "imm"
84 in
85 let init =
86 match init with
87 | Heap_initialization -> "(heap-init)"
88 | Root_initialization -> "(root-init)"
89 | Assignment -> ""
90 in
91 fprintf ppf "setfield_%s%s_computed" instr init
92 | Pfloatfield n -> fprintf ppf "floatfield %i" n
93 | Psetfloatfield (n, init) ->
94 let init =
95 match init with
96 | Heap_initialization -> "(heap-init)"
97 | Root_initialization -> "(root-init)"
98 | Assignment -> ""
99 in
100 fprintf ppf "setfloatfield%s %i" init n
101 | Pduprecord (rep, size) ->
102 fprintf ppf "duprecord %a %i" Printlambda.record_rep rep size
103 | Pccall p -> fprintf ppf "%s" p.Primitive.prim_name
104 | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
105 | Psequand -> fprintf ppf "&&"
106 | Psequor -> fprintf ppf "||"
107 | Pnot -> fprintf ppf "not"
108 | Pnegint -> fprintf ppf "~"
109 | Paddint -> fprintf ppf "+"
110 | Psubint -> fprintf ppf "-"
111 | Pmulint -> fprintf ppf "*"
112 | Pdivint Safe -> fprintf ppf "/"
113 | Pdivint Unsafe -> fprintf ppf "/u"
114 | Pmodint Safe -> fprintf ppf "mod"
115 | Pmodint Unsafe -> fprintf ppf "mod_unsafe"
116 | Pandint -> fprintf ppf "and"
117 | Porint -> fprintf ppf "or"
118 | Pxorint -> fprintf ppf "xor"
119 | Plslint -> fprintf ppf "lsl"
120 | Plsrint -> fprintf ppf "lsr"
121 | Pasrint -> fprintf ppf "asr"
122 | Pintcomp(cmp) -> Printlambda.integer_comparison ppf cmp
123 | Poffsetint n -> fprintf ppf "%i+" n
124 | Poffsetref n -> fprintf ppf "+:=%i"n
125 | Pintoffloat -> fprintf ppf "int_of_float"
126 | Pfloatofint -> fprintf ppf "float_of_int"
127 | Pnegfloat -> fprintf ppf "~."
128 | Pabsfloat -> fprintf ppf "abs."
129 | Paddfloat -> fprintf ppf "+."
130 | Psubfloat -> fprintf ppf "-."
131 | Pmulfloat -> fprintf ppf "*."
132 | Pdivfloat -> fprintf ppf "/."
133 | Pfloatcomp(cmp) -> Printlambda.float_comparison ppf cmp
134 | Pstringlength -> fprintf ppf "string.length"
135 | Pstringrefu -> fprintf ppf "string.unsafe_get"
136 | Pstringrefs -> fprintf ppf "string.get"
137 | Pbyteslength -> fprintf ppf "bytes.length"
138 | Pbytesrefu -> fprintf ppf "bytes.unsafe_get"
139 | Pbytessetu -> fprintf ppf "bytes.unsafe_set"
140 | Pbytesrefs -> fprintf ppf "bytes.get"
141 | Pbytessets -> fprintf ppf "bytes.set"
142
143 | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k)
144 | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k)
145 | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k)
146 | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k)
147 | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
148 | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k)
149 | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k)
150 | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k)
151 | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k)
152 | Pisint -> fprintf ppf "isint"
153 | Pisout -> fprintf ppf "isout"
154 | Pbintofint bi -> print_boxed_integer "of_int" ppf bi
155 | Pintofbint bi -> print_boxed_integer "to_int" ppf bi
156 | Pcvtbint (bi1, bi2) ->
157 fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)
158 | Pnegbint bi -> print_boxed_integer "neg" ppf bi
159 | Paddbint bi -> print_boxed_integer "add" ppf bi
160 | Psubbint bi -> print_boxed_integer "sub" ppf bi
161 | Pmulbint bi -> print_boxed_integer "mul" ppf bi
162 | Pdivbint { size = bi; is_safe = Safe } ->
163 print_boxed_integer "div" ppf bi
164 | Pdivbint { size = bi; is_safe = Unsafe } ->
165 print_boxed_integer "div_unsafe" ppf bi
166 | Pmodbint { size = bi; is_safe = Safe } ->
167 print_boxed_integer "mod" ppf bi
168 | Pmodbint { size = bi; is_safe = Unsafe } ->
169 print_boxed_integer "mod_unsafe" ppf bi
170 | Pandbint bi -> print_boxed_integer "and" ppf bi
171 | Porbint bi -> print_boxed_integer "or" ppf bi
172 | Pxorbint bi -> print_boxed_integer "xor" ppf bi
173 | Plslbint bi -> print_boxed_integer "lsl" ppf bi
174 | Plsrbint bi -> print_boxed_integer "lsr" ppf bi
175 | Pasrbint bi -> print_boxed_integer "asr" ppf bi
176 | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi
177 | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi
178 | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi
179 | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
180 | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
181 | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
182 | Pbigarrayref(unsafe, _n, kind, layout) ->
183 Printlambda.print_bigarray "get" unsafe kind ppf layout
184 | Pbigarrayset(unsafe, _n, kind, layout) ->
185 Printlambda.print_bigarray "set" unsafe kind ppf layout
186 | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
187 | Pstring_load(size, safety) ->
188 fprintf ppf "string.%sget%s" (access_safety safety) (access_size size)
189 | Pbytes_load(size, safety) ->
190 fprintf ppf "bytes.%sget%s" (access_safety safety) (access_size size)
191 | Pbytes_set(size, safety) ->
192 fprintf ppf "bytes.%sset%s" (access_safety safety) (access_size size)
193 | Pbigstring_load(size, safety) ->
194 fprintf ppf "bigarray.array1.%sget%s"
195 (access_safety safety) (access_size size)
196 | Pbigstring_set(size, safety) ->
197 fprintf ppf "bigarray.array1.%sset%s"
198 (access_safety safety) (access_size size)
199 | Pbswap16 -> fprintf ppf "bswap16"
200 | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
201 | Pint_as_pointer -> fprintf ppf "int_as_pointer"
202 | Popaque -> fprintf ppf "opaque"
203