1 (***********************************************************************)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
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. *)
11 (***********************************************************************)
15 (* Generation of bytecode + relocation information *)
25 (* Buffering of bytecode *)
27 let out_buffer = ref(String.create
1024)
28 and out_position
= ref 0
30 let out_word b1 b2 b3 b4
=
31 let p = !out_position
in
32 if p >= String.length
!out_buffer then begin
33 let len = String.length
!out_buffer in
34 let new_buffer = String.create
(2 * len) in
35 String.blit
!out_buffer 0 new_buffer 0 len;
36 out_buffer := new_buffer
38 String.unsafe_set
!out_buffer p (Char.unsafe_chr b1
);
39 String.unsafe_set
!out_buffer (p+1) (Char.unsafe_chr b2
);
40 String.unsafe_set
!out_buffer (p+2) (Char.unsafe_chr b3
);
41 String.unsafe_set
!out_buffer (p+3) (Char.unsafe_chr b4
);
50 let const_as_int = function
51 | Const_base
(Const_int i
) -> i
52 | Const_base
(Const_char c
) -> Char.code c
53 | Const_pointer i
-> i
56 let is_immed i
= immed_min
<= i
&& i
<= immed_max
57 let is_immed_const k
=
59 is_immed (const_as_int k
)
65 out_word n
(n
asr 8) (n
asr 16) (n
asr 24)
69 out_int (const_as_int c
)
71 | AsInt
-> Misc.fatal_error
"Emitcode.const_as_int"
74 (* Handling of local labels and backpatching *)
76 type label_definition
=
78 | Label_undefined
of (int * int) list
80 let label_table = ref ([| |] : label_definition array
)
82 let extend_label_table needed
=
83 let new_size = ref(Array.length
!label_table) in
84 while needed
>= !new_size do new_size := 2 * !new_size done;
85 let new_table = Array.create
!new_size (Label_undefined
[]) in
86 Array.blit
!label_table 0 new_table 0 (Array.length
!label_table);
87 label_table := new_table
89 let backpatch (pos
, orig
) =
90 let displ = (!out_position
- orig
) asr 2 in
91 !out_buffer.[pos
] <- Char.unsafe_chr
displ;
92 !out_buffer.[pos
+1] <- Char.unsafe_chr
(displ asr 8);
93 !out_buffer.[pos
+2] <- Char.unsafe_chr
(displ asr 16);
94 !out_buffer.[pos
+3] <- Char.unsafe_chr
(displ asr 24)
96 let define_label lbl
=
97 if lbl
>= Array.length
!label_table then extend_label_table lbl
;
98 match (!label_table).(lbl
) with
100 fatal_error
"Emitcode.define_label"
101 | Label_undefined patchlist
->
102 List.iter
backpatch patchlist
;
103 (!label_table).(lbl
) <- Label_defined
!out_position
105 let out_label_with_orig orig lbl
=
106 if lbl
>= Array.length
!label_table then extend_label_table lbl
;
107 match (!label_table).(lbl
) with
109 out_int((def
- orig
) asr 2)
110 | Label_undefined patchlist
->
111 (!label_table).(lbl
) <-
112 Label_undefined
((!out_position
, orig
) :: patchlist
);
115 let out_label l
= out_label_with_orig !out_position l
117 (* Relocation information *)
119 let reloc_info = ref ([] : (reloc_info * int) list
)
122 reloc_info := (info
, !out_position
) :: !reloc_info
124 let slot_for_literal sc
=
125 enter (Reloc_literal sc
);
127 and slot_for_getglobal id
=
128 enter (Reloc_getglobal id
);
130 and slot_for_setglobal id
=
131 enter (Reloc_setglobal id
);
133 and slot_for_c_prim name
=
134 enter (Reloc_primitive name
);
137 (* Debugging events *)
139 let events = ref ([] : debug_event list
)
141 let record_event ev
=
142 ev
.ev_pos
<- !out_position
;
143 events := ev
:: !events
149 label_table := Array.create
16 (Label_undefined
[]);
153 (* Emission of one instruction *)
155 let emit_comp = function
156 | Ceq
-> out opEQ
| Cneq
-> out opNEQ
157 | Clt
-> out opLTINT
| Cle
-> out opLEINT
158 | Cgt
-> out opGTINT
| Cge
-> out opGEINT
160 and emit_branch_comp
= function
161 | Ceq
-> out opBEQ
| Cneq
-> out opBNEQ
162 | Clt
-> out opBLTINT
| Cle
-> out opBLEINT
163 | Cgt
-> out opBGTINT
| Cge
-> out opBGEINT
165 let emit_instr = function
166 Klabel lbl
-> define_label lbl
168 if n
< 8 then out(opACC0
+ n
) else (out opACC
; out_int n
)
171 then out(opENVACC1
+ n
- 1)
172 else (out opENVACC
; out_int n
)
178 out opASSIGN
; out_int n
179 | Kpush_retaddr lbl
-> out opPUSH_RETADDR
; out_label lbl
181 if n
< 4 then out(opAPPLY1
+ n
- 1) else (out opAPPLY
; out_int n
)
183 if n
< 4 then (out(opAPPTERM1
+ n
- 1); out_int sz
)
184 else (out opAPPTERM
; out_int n
; out_int sz
)
185 | Kreturn n
-> out opRETURN
; out_int n
186 | Krestart
-> out opRESTART
187 | Kgrab n
-> out opGRAB
; out_int n
188 | Kclosure
(lbl
, n
) -> out opCLOSURE
; out_int n
; out_label lbl
189 | Kclosurerec
(lbls
, n
) ->
190 out opCLOSUREREC
; out_int (List.length lbls
); out_int n
;
191 let org = !out_position
in
192 List.iter
(out_label_with_orig org) lbls
193 | Koffsetclosure ofs
->
194 if ofs
= -2 || ofs
= 0 || ofs
= 2
195 then out (opOFFSETCLOSURE0
+ ofs
/ 2)
196 else (out opOFFSETCLOSURE
; out_int ofs
)
197 | Kgetglobal q
-> out opGETGLOBAL
; slot_for_getglobal q
198 | Ksetglobal q
-> out opSETGLOBAL
; slot_for_setglobal q
201 Const_base
(Const_int i
) when is_immed i
->
203 then out (opCONST0
+ i
)
204 else (out opCONSTINT
; out_int i
)
205 | Const_base
(Const_char c
) ->
206 out opCONSTINT
; out_int (Char.code c
)
209 then out (opCONST0
+ i
)
210 else (out opCONSTINT
; out_int i
)
211 | Const_block
(t
, []) ->
212 if t
= 0 then out opATOM0
else (out opATOM
; out_int t
)
214 out opGETGLOBAL
; slot_for_literal sc
216 | Kmakeblock
(n
, t
) ->
218 if t
= 0 then out opATOM0
else (out opATOM
; out_int t
)
219 else if n
< 4 then (out(opMAKEBLOCK1
+ n
- 1); out_int t
)
220 else (out opMAKEBLOCK
; out_int n
; out_int t
)
222 if n
< 4 then out(opGETFIELD0
+ n
) else (out opGETFIELD
; out_int n
)
224 if n
< 4 then out(opSETFIELD0
+ n
) else (out opSETFIELD
; out_int n
)
225 | Kmakefloatblock
(n
) ->
226 if n
= 0 then out opATOM0
else (out opMAKEFLOATBLOCK
; out_int n
)
227 | Kgetfloatfield n
-> out opGETFLOATFIELD
; out_int n
228 | Ksetfloatfield n
-> out opSETFLOATFIELD
; out_int n
229 | Kvectlength
-> out opVECTLENGTH
230 | Kgetvectitem
-> out opGETVECTITEM
231 | Ksetvectitem
-> out opSETVECTITEM
232 | Kgetstringchar
-> out opGETSTRINGCHAR
233 | Ksetstringchar
-> out opSETSTRINGCHAR
234 | Kbranch lbl
-> out opBRANCH
; out_label lbl
235 | Kbranchif lbl
-> out opBRANCHIF
; out_label lbl
236 | Kbranchifnot lbl
-> out opBRANCHIFNOT
; out_label lbl
237 | Kstrictbranchif lbl
-> out opBRANCHIF
; out_label lbl
238 | Kstrictbranchifnot lbl
-> out opBRANCHIFNOT
; out_label lbl
239 | Kswitch
(tbl_const
, tbl_block
) ->
241 out_int (Array.length tbl_const
+ (Array.length tbl_block
lsl 16));
242 let org = !out_position
in
243 Array.iter
(out_label_with_orig org) tbl_const
;
244 Array.iter
(out_label_with_orig org) tbl_block
245 | Kboolnot
-> out opBOOLNOT
246 | Kpushtrap lbl
-> out opPUSHTRAP
; out_label lbl
247 | Kpoptrap
-> out opPOPTRAP
248 | Kraise
-> out opRAISE
249 | Kcheck_signals
-> out opCHECK_SIGNALS
252 then (out (opC_CALL1
+ n
- 1); slot_for_c_prim name
)
253 else (out opC_CALLN
; out_int n
; slot_for_c_prim name
)
254 | Knegint
-> out opNEGINT
| Kaddint
-> out opADDINT
255 | Ksubint
-> out opSUBINT
| Kmulint
-> out opMULINT
256 | Kdivint
-> out opDIVINT
| Kmodint
-> out opMODINT
257 | Kandint
-> out opANDINT
| Korint
-> out opORINT
258 | Kxorint
-> out opXORINT
| Klslint
-> out opLSLINT
259 | Klsrint
-> out opLSRINT
| Kasrint
-> out opASRINT
260 | Kintcomp c
-> emit_comp c
261 | Koffsetint n
-> out opOFFSETINT
; out_int n
262 | Koffsetref n
-> out opOFFSETREF
; out_int n
263 | Kisint
-> out opISINT
264 | Kisout
-> out opULTINT
265 | Kgetmethod
-> out opGETMETHOD
266 | Kgetpubmet tag
-> out opGETPUBMET
; out_int tag
; out_int 0
267 | Kgetdynmet
-> out opGETDYNMET
268 | Kevent ev
-> record_event ev
269 | Kstop
-> out opSTOP
271 (* Emission of a list of instructions. Include some peephole optimization. *)
273 let rec emit = function
275 (* Peephole optimizations *)
276 (* optimization of integer tests *)
277 | Kpush
::Kconst k
::Kintcomp c
::Kbranchif lbl
::rem
278 when is_immed_const k
->
283 | Kpush
::Kconst k
::Kintcomp c
::Kbranchifnot lbl
::rem
284 when is_immed_const k
->
285 emit_branch_comp
(negate_comparison c
) ;
289 (* same for range tests *)
290 | Kpush
::Kconst k
::Kisout
::Kbranchif lbl
::rem
291 when is_immed_const k
->
296 | Kpush
::Kconst k
::Kisout
::Kbranchifnot lbl
::rem
297 when is_immed_const k
->
302 (* Some special case of push ; i ; ret generated by the match compiler *)
303 | Kpush
:: Kacc
0 :: Kreturn m
:: c
->
304 emit (Kreturn
(m
-1) :: c
)
305 (* General push then access scheme *)
306 | Kpush
:: Kacc n
:: c
->
307 if n
< 8 then out(opPUSHACC0
+ n
) else (out opPUSHACC
; out_int n
);
309 | Kpush
:: Kenvacc n
:: c
->
311 then out(opPUSHENVACC1
+ n
- 1)
312 else (out opPUSHENVACC
; out_int n
);
314 | Kpush
:: Koffsetclosure ofs
:: c
->
315 if ofs
= -2 || ofs
= 0 || ofs
= 2
316 then out(opPUSHOFFSETCLOSURE0
+ ofs
/ 2)
317 else (out opPUSHOFFSETCLOSURE
; out_int ofs
);
319 | Kpush
:: Kgetglobal id
:: Kgetfield n
:: c
->
320 out opPUSHGETGLOBALFIELD
; slot_for_getglobal id
; out_int n
; emit c
321 | Kpush
:: Kgetglobal id
:: c
->
322 out opPUSHGETGLOBAL
; slot_for_getglobal id
; emit c
323 | Kpush
:: Kconst sc
:: c
->
325 Const_base
(Const_int i
) when is_immed i
->
327 then out (opPUSHCONST0
+ i
)
328 else (out opPUSHCONSTINT
; out_int i
)
329 | Const_base
(Const_char c
) ->
330 out opPUSHCONSTINT
; out_int(Char.code c
)
333 then out (opPUSHCONST0
+ i
)
334 else (out opPUSHCONSTINT
; out_int i
)
335 | Const_block
(t
, []) ->
336 if t
= 0 then out opPUSHATOM0
else (out opPUSHATOM
; out_int t
)
338 out opPUSHGETGLOBAL
; slot_for_literal sc
341 | Kpush
:: (Kevent
{ev_kind
= Event_before
} as ev
) ::
342 (Kgetglobal _
as instr1
) :: (Kgetfield _
as instr2
) :: c
->
343 emit (Kpush
:: instr1
:: instr2
:: ev
:: c
)
344 | Kpush
:: (Kevent
{ev_kind
= Event_before
} as ev
) ::
345 (Kacc _
| Kenvacc _
| Koffsetclosure _
| Kgetglobal _
| Kconst _
as instr
) :: c
->
346 emit (Kpush
:: instr
:: ev
:: c
)
347 | Kgetglobal id
:: Kgetfield n
:: c
->
348 out opGETGLOBALFIELD
; slot_for_getglobal id
; out_int n
; emit c
351 emit_instr instr
; emit c
353 (* Emission to a file *)
355 let to_file outchan unit_name code
=
357 output_string outchan cmo_magic_number
;
358 let pos_depl = pos_out outchan
in
359 output_binary_int outchan
0;
360 let pos_code = pos_out outchan
in
362 output outchan
!out_buffer 0 !out_position
;
363 let (pos_debug
, size_debug
) =
364 if !Clflags.debug
then begin
365 let p = pos_out outchan
in
366 output_value outchan
!events;
367 (p, pos_out outchan
- p)
371 { cu_name
= unit_name
;
373 cu_codesize
= !out_position
;
374 cu_reloc
= List.rev
!reloc_info;
375 cu_imports
= Env.imported_units
();
376 cu_primitives
= !Translmod.primitive_declarations
;
377 cu_force_link
= false;
378 cu_debug
= pos_debug
;
379 cu_debugsize
= size_debug
} in
380 init(); (* Free out_buffer and reloc_info *)
381 Btype.cleanup_abbrev
(); (* Remove any cached abbreviation
382 expansion before saving *)
383 let pos_compunit = pos_out outchan
in
384 output_value outchan
compunit;
385 seek_out outchan
pos_depl;
386 output_binary_int outchan
pos_compunit
388 (* Emission to a memory block *)
390 let to_memory init_code fun_code
=
394 let code = Meta.static_alloc
!out_position
in
395 String.unsafe_blit
!out_buffer 0 code 0 !out_position
;
396 let reloc = List.rev
!reloc_info
397 and code_size
= !out_position
in
399 (code, code_size
, reloc)
401 (* Emission to a file for a packed library *)
403 let to_packed_file outchan
code =
406 output outchan
!out_buffer 0 !out_position
;
407 let reloc = !reloc_info in