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 /* A simple parser for C-- */
17
18 %{
19 open Cmm
20 open Parsecmmaux
21
22 let rec make_letdef def body =
23 match def with
24 [] -> body
25 | (id, def) :: rem ->
26 unbind_ident id;
27 Clet(id, def, make_letdef rem body)
28
29 let make_switch n selector caselist =
30 let index = Array.make n 0 in
31 let casev = Array.of_list caselist in
32 let dbg = Debuginfo.none in
33 let actv = Array.make (Array.length casev) (Cexit(0,[]), dbg) in
34 for i = 0 to Array.length casev - 1 do
35 let (posl, e) = casev.(i) in
36 List.iter (fun pos -> index.(pos) <- i) posl;
37 actv.(i) <- (e, dbg)
38 done;
39 Cswitch(selector, index, actv, dbg)
40
41 let access_array base numelt size =
42 match numelt with
43 Cconst_int (0, _) -> base
44 | Cconst_int (n, _) ->
45 let dbg = Debuginfo.none in
46 Cop(Cadda, [base; Cconst_int(n * size, dbg)], dbg)
47 | _ ->
48 let dbg = Debuginfo.none in
49 Cop(Cadda, [base;
50 Cop(Clsl, [numelt; Cconst_int(Misc.log2 size, dbg)],
51 dbg)],
52 dbg)
53
54 %}
55
56 %token ABSF
57 %token ADDA
58 %token ADDF
59 %token ADDI
60 %token ADDV
61 %token ADDR
62 %token ALIGN
63 %token ALLOC
64 %token AND
65 %token APPLY
66 %token ASR
67 %token ASSIGN
68 %token BYTE
69 %token CASE
70 %token CATCH
71 %token CHECKBOUND
72 %token COLON
73 %token DATA
74 %token DIVF
75 %token DIVI
76 %token EOF
77 %token EQA
78 %token EQF
79 %token EQI
80 %token EXIT
81 %token EXTCALL
82 %token FLOAT
83 %token FLOAT32
84 %token FLOAT64
85 %token <string> FLOATCONST
86 %token FLOATOFINT
87 %token FUNCTION
88 %token GEA
89 %token GEF
90 %token GEI
91 %token GLOBAL
92 %token GTA
93 %token GTF
94 %token GTI
95 %token HALF
96 %token <string> IDENT
97 %token IF
98 %token INT
99 %token INT32
100 %token <int> INTCONST
101 %token INTOFFLOAT
102 %token KSTRING
103 %token LBRACKET
104 %token LEA
105 %token LEF
106 %token LEI
107 %token LET
108 %token LOAD
109 %token <Location.t> LOCATION
110 %token LPAREN
111 %token LSL
112 %token LSR
113 %token LTA
114 %token LTF
115 %token LTI
116 %token MODI
117 %token MULF
118 %token MULH
119 %token MULI
120 %token NEA
121 %token NEF
122 %token NEI
123 %token NGEF
124 %token NGTF
125 %token NLEF
126 %token NLTF
127 %token OR
128 %token <int> POINTER
129 %token PROJ
130 %token <Lambda.raise_kind> RAISE
131 %token RBRACKET
132 %token RPAREN
133 %token SEQ
134 %token SIGNED
135 %token SKIP
136 %token STAR
137 %token STORE
138 %token <string> STRING
139 %token SUBF
140 %token SUBI
141 %token SWITCH
142 %token TRY
143 %token UNIT
144 %token UNSIGNED
145 %token VAL
146 %token WHILE
147 %token WITH
148 %token XOR
149 %token ADDRAREF
150 %token INTAREF
151 %token FLOATAREF
152 %token ADDRASET
153 %token INTASET
154 %token FLOATASET
155
156 %start phrase
157 %type <Cmm.phrase> phrase
158
159 %%
160
161 phrase:
162 fundecl { Cfunction $1 }
163 | datadecl { Cdata $1 }
164 | EOF { raise End_of_file }
165 ;
166 fundecl:
167 LPAREN FUNCTION fun_name LPAREN params RPAREN sequence RPAREN
168 { List.iter (fun (id, ty) -> unbind_ident id) $5;
169 {fun_name = $3; fun_args = $5; fun_body = $7;
170 fun_codegen_options =
171 if Config.flambda then [
172 Reduce_code_size;
173 No_CSE;
174 ]
175 else [ Reduce_code_size ];
176 fun_dbg = debuginfo ()} }
177 ;
178 fun_name:
179 STRING { $1 }
180 | IDENT { $1 }
181 params:
182 oneparam params { $1 :: $2 }
183 | /**/ { [] }
184 ;
185 oneparam:
186 IDENT COLON machtype { (bind_ident $1, $3) }
187 ;
188 machtype:
189 UNIT { [||] }
190 | componentlist { Array.of_list(List.rev $1) }
191 ;
192 component:
193 VAL { Val }
194 | ADDR { Addr }
195 | INT { Int }
196 | FLOAT { Float }
197 ;
198 componentlist:
199 component { [$1] }
200 | componentlist STAR component { $3 :: $1 }
201 ;
202 expr:
203 INTCONST { Cconst_int ($1, debuginfo ()) }
204 | FLOATCONST { Cconst_float (float_of_string $1, debuginfo ()) }
205 | STRING { Cconst_symbol ($1, debuginfo ()) }
206 | POINTER { Cconst_pointer ($1, debuginfo ()) }
207 | IDENT { Cvar(find_ident $1) }
208 | LBRACKET RBRACKET { Ctuple [] }
209 | LPAREN LET letdef sequence RPAREN { make_letdef $3 $4 }
210 | LPAREN ASSIGN IDENT expr RPAREN { Cassign(find_ident $3, $4) }
211 | LPAREN APPLY location expr exprlist machtype RPAREN
212 { Cop(Capply $6, $4 :: List.rev $5, debuginfo ?loc:$3 ()) }
213 | LPAREN EXTCALL STRING exprlist machtype RPAREN
214 {Cop(Cextcall($3, $5, false, None), List.rev $4, debuginfo ())}
215 | LPAREN ALLOC exprlist RPAREN { Cop(Calloc, List.rev $3, debuginfo ()) }
216 | LPAREN SUBF expr RPAREN { Cop(Cnegf, [$3], debuginfo ()) }
217 | LPAREN SUBF expr expr RPAREN { Cop(Csubf, [$3; $4], debuginfo ()) }
218 | LPAREN unaryop expr RPAREN { Cop($2, [$3], debuginfo ()) }
219 | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) }
220 | LPAREN SEQ sequence RPAREN { $3 }
221 | LPAREN IF expr expr expr RPAREN
222 { Cifthenelse($3, debuginfo (), $4, debuginfo (), $5, debuginfo ()) }
223 | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 }
224 | LPAREN WHILE expr sequence RPAREN
225 {
226 let lbl0 = Lambda.next_raise_count () in
227 let lbl1 = Lambda.next_raise_count () in
228 let body =
229 match $3 with
230 Cconst_int (x, _) when x <> 0 -> $4
231 | _ -> Cifthenelse($3, debuginfo (), $4, debuginfo (),
232 (Cexit(lbl0,[])),
233 debuginfo ()) in
234 Ccatch(Nonrecursive, [lbl0, [], Ctuple [], debuginfo ()],
235 Ccatch(Recursive,
236 [lbl1, [], Csequence(body, Cexit(lbl1, [])), debuginfo ()],
237 Cexit(lbl1, []))) }
238 | LPAREN EXIT IDENT exprlist RPAREN
239 { Cexit(find_label $3, List.rev $4) }
240 | LPAREN CATCH sequence WITH catch_handlers RPAREN
241 { let handlers = $5 in
242 List.iter (fun (_, l, _, _) ->
243 List.iter (fun (x, _) -> unbind_ident x) l) handlers;
244 Ccatch(Recursive, handlers, $3) }
245 | EXIT { Cexit(0,[]) }
246 | LPAREN TRY sequence WITH bind_ident sequence RPAREN
247 { unbind_ident $5; Ctrywith($3, $5, $6, debuginfo ()) }
248 | LPAREN VAL expr expr RPAREN
249 { let open Asttypes in
250 Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
251 debuginfo ()) }
252 | LPAREN ADDRAREF expr expr RPAREN
253 { let open Asttypes in
254 Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr],
255 Debuginfo.none) }
256 | LPAREN INTAREF expr expr RPAREN
257 { let open Asttypes in
258 Cop(Cload (Word_int, Mutable), [access_array $3 $4 Arch.size_int],
259 Debuginfo.none) }
260 | LPAREN FLOATAREF expr expr RPAREN
261 { let open Asttypes in
262 Cop(Cload (Double_u, Mutable), [access_array $3 $4 Arch.size_float],
263 Debuginfo.none) }
264 | LPAREN ADDRASET expr expr expr RPAREN
265 { let open Lambda in
266 Cop(Cstore (Word_val, Assignment),
267 [access_array $3 $4 Arch.size_addr; $5], Debuginfo.none) }
268 | LPAREN INTASET expr expr expr RPAREN
269 { let open Lambda in
270 Cop(Cstore (Word_int, Assignment),
271 [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) }
272 | LPAREN FLOATASET expr expr expr RPAREN
273 { let open Lambda in
274 Cop(Cstore (Double_u, Assignment),
275 [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) }
276 ;
277 exprlist:
278 exprlist expr { $2 :: $1 }
279 | /**/ { [] }
280 ;
281 letdef:
282 oneletdef { [$1] }
283 | LPAREN letdefmult RPAREN { $2 }
284 ;
285 letdefmult:
286 /**/ { [] }
287 | oneletdef letdefmult { $1 :: $2 }
288 ;
289 oneletdef:
290 IDENT expr { (bind_ident $1, $2) }
291 ;
292 chunk:
293 UNSIGNED BYTE { Byte_unsigned }
294 | SIGNED BYTE { Byte_signed }
295 | UNSIGNED HALF { Sixteen_unsigned }
296 | SIGNED HALF { Sixteen_signed }
297 | UNSIGNED INT32 { Thirtytwo_unsigned }
298 | SIGNED INT32 { Thirtytwo_signed }
299 | INT { Word_int }
300 | ADDR { Word_val }
301 | FLOAT32 { Single }
302 | FLOAT64 { Double }
303 | FLOAT { Double_u }
304 | VAL { Word_val }
305 ;
306 unaryop:
307 LOAD chunk { Cload ($2, Asttypes.Mutable) }
308 | FLOATOFINT { Cfloatofint }
309 | INTOFFLOAT { Cintoffloat }
310 | RAISE { Craise $1 }
311 | ABSF { Cabsf }
312 ;
313 binaryop:
314 STORE chunk { Cstore ($2, Lambda.Assignment) }
315 | ADDI { Caddi }
316 | SUBI { Csubi }
317 | STAR { Cmuli }
318 | DIVI { Cdivi }
319 | MODI { Cmodi }
320 | AND { Cand }
321 | OR { Cor }
322 | XOR { Cxor }
323 | LSL { Clsl }
324 | LSR { Clsr }
325 | ASR { Casr }
326 | EQI { Ccmpi Ceq }
327 | NEI { Ccmpi Cne }
328 | LTI { Ccmpi Clt }
329 | LEI { Ccmpi Cle }
330 | GTI { Ccmpi Cgt }
331 | GEI { Ccmpi Cge }
332 | ADDA { Cadda }
333 | ADDV { Caddv }
334 | EQA { Ccmpa Ceq }
335 | NEA { Ccmpa Cne }
336 | LTA { Ccmpa Clt }
337 | LEA { Ccmpa Cle }
338 | GTA { Ccmpa Cgt }
339 | GEA { Ccmpa Cge }
340 | ADDF { Caddf }
341 | MULF { Cmulf }
342 | DIVF { Cdivf }
343 | EQF { Ccmpf CFeq }
344 | NEF { Ccmpf CFneq }
345 | LTF { Ccmpf CFlt }
346 | NLTF { Ccmpf CFnlt }
347 | LEF { Ccmpf CFle }
348 | NLEF { Ccmpf CFnle }
349 | GTF { Ccmpf CFgt }
350 | NGTF { Ccmpf CFngt }
351 | GEF { Ccmpf CFge }
352 | NGEF { Ccmpf CFnge }
353 | CHECKBOUND { Ccheckbound }
354 | MULH { Cmulhi }
355 ;
356 sequence:
357 expr sequence { Csequence($1, $2) }
358 | expr { $1 }
359 ;
360 caselist:
361 onecase sequence caselist { ($1, $2) :: $3 }
362 | /**/ { [] }
363 ;
364 onecase:
365 CASE INTCONST COLON onecase { $2 :: $4 }
366 | CASE INTCONST COLON { [$2] }
367 ;
368 bind_ident:
369 IDENT { bind_ident $1 }
370 ;
371 datadecl:
372 LPAREN datalist RPAREN { List.rev $2 }
373 | LPAREN DATA datalist RPAREN { List.rev $3 }
374 ;
375 datalist:
376 datalist dataitem { $2 :: $1 }
377 | /**/ { [] }
378 ;
379 dataitem:
380 STRING COLON { Cdefine_symbol $1 }
381 | BYTE INTCONST { Cint8 $2 }
382 | HALF INTCONST { Cint16 $2 }
383 | INT INTCONST { Cint(Nativeint.of_int $2) }
384 | FLOAT FLOATCONST { Cdouble (float_of_string $2) }
385 | ADDR STRING { Csymbol_address $2 }
386 | VAL STRING { Csymbol_address $2 }
387 | KSTRING STRING { Cstring $2 }
388 | SKIP INTCONST { Cskip $2 }
389 | ALIGN INTCONST { Calign $2 }
390 | GLOBAL STRING { Cglobal_symbol $2 }
391 ;
392 catch_handlers:
393 | catch_handler
394 { [$1] }
395 | catch_handler AND catch_handlers
396 { $1 :: $3 }
397
398 catch_handler:
399 | sequence
400 { 0, [], $1, debuginfo () }
401 | LPAREN IDENT params RPAREN sequence
402 { find_label $2, $3, $5, debuginfo () }
403
404 location:
405 /**/ { None }
406 | LOCATION { Some $1 }
407