]> git.lizzy.rs Git - rust.git/blob - src/boot/me/trans.ml
6a14a1cec26511c537c260b67e88fdeb47590a0c
[rust.git] / src / boot / me / trans.ml
1 (* Translation *)
2
3 open Semant;;
4 open Common;;
5 open Transutil;;
6
7 let log cx = Session.log "trans"
8   cx.ctxt_sess.Session.sess_log_trans
9   cx.ctxt_sess.Session.sess_log_out
10 ;;
11
12 let arr_max a = (Array.length a) - 1;;
13
14 type quad_idx = int
15 ;;
16
17 type call =
18     {
19       call_ctrl: call_ctrl;
20       call_callee_ptr: Il.operand;
21       call_callee_ty: Ast.ty;
22       call_callee_ty_params: Ast.ty array;
23       call_output: Il.cell;
24       call_args: Ast.atom array;
25       call_iterator_args: Il.operand array;
26       call_indirect_args: Il.operand array;
27     }
28 ;;
29
30 let need_ty_fn ty =
31   match simplified_ty ty with
32       Ast.TY_fn tfn -> tfn
33     | _ -> bug () "need fn"
34 ;;
35
36 let call_output_slot call =
37   (fst (need_ty_fn call.call_callee_ty)).Ast.sig_output_slot
38 ;;
39
40 let trans_visitor
41     (cx:ctxt)
42     (path:Ast.name_component Stack.t)
43     (inner:Walk.visitor)
44     : Walk.visitor =
45
46   let iflog thunk =
47     if cx.ctxt_sess.Session.sess_log_trans
48     then thunk ()
49     else ()
50   in
51
52   let curr_file = Stack.create () in
53   let curr_stmt = Stack.create () in
54
55   let (abi:Abi.abi) = cx.ctxt_abi in
56   let (word_sz:int64) = word_sz abi in
57   let (word_slot:Ast.slot) = word_slot abi in
58   let (word_ty:Ast.ty) = Ast.TY_mach abi.Abi.abi_word_ty in
59
60   let oper_str = Il.string_of_operand abi.Abi.abi_str_of_hardreg in
61   let cell_str = Il.string_of_cell abi.Abi.abi_str_of_hardreg in
62
63   let (word_bits:Il.bits) = abi.Abi.abi_word_bits in
64   let (word_sty:Il.scalar_ty) = Il.ValTy word_bits in
65   let (word_rty:Il.referent_ty) = Il.ScalarTy word_sty in
66   let (word_ty_mach:ty_mach) =
67     match word_bits with
68         Il.Bits8 -> TY_u8
69       | Il.Bits16 -> TY_u16
70       | Il.Bits32 -> TY_u32
71       | Il.Bits64 -> TY_u64
72   in
73   let (word_ty_signed_mach:ty_mach) =
74     match word_bits with
75         Il.Bits8 -> TY_i8
76       | Il.Bits16 -> TY_i16
77       | Il.Bits32 -> TY_i32
78       | Il.Bits64 -> TY_i64
79   in
80   let word_n = word_n abi in
81   let imm_of_ty (i:int64) (tm:ty_mach) : Il.operand =
82     Il.Imm (Asm.IMM i, tm)
83   in
84
85   let imm (i:int64) : Il.operand = imm_of_ty i word_ty_mach in
86   let simm (i:int64) : Il.operand = imm_of_ty i word_ty_signed_mach in
87   let one = imm 1L in
88   let zero = imm 0L in
89   let imm_true = imm_of_ty 1L TY_u8 in
90   let imm_false = imm_of_ty 0L TY_u8 in
91   let nil_ptr = Il.Mem ((Il.Abs (Asm.IMM 0L)), Il.NilTy) in
92   let wordptr_ty = Il.AddrTy (Il.ScalarTy word_sty) in
93
94   let crate_rel fix =
95     Asm.SUB (Asm.M_POS fix, Asm.M_POS cx.ctxt_crate_fixup)
96   in
97
98   let crate_rel_word fix =
99     Asm.WORD (word_ty_signed_mach, crate_rel fix)
100   in
101
102   let crate_rel_imm (fix:fixup) : Il.operand =
103     Il.Imm (crate_rel fix, word_ty_signed_mach)
104   in
105
106   let table_of_crate_rel_fixups (fixups:fixup array) : Asm.frag =
107     Asm.SEQ (Array.map crate_rel_word fixups)
108   in
109
110   let fixup_rel_word (base:fixup) (fix:fixup) =
111     Asm.WORD (word_ty_signed_mach,
112               Asm.SUB (Asm.M_POS fix, Asm.M_POS base))
113   in
114
115   let table_of_fixup_rel_fixups
116       (fixup:fixup)
117       (fixups:fixup array)
118       : Asm.frag =
119     Asm.SEQ (Array.map (fixup_rel_word fixup) fixups)
120   in
121
122   let table_of_table_rel_fixups (fixups:fixup array) : Asm.frag =
123     let table_fix = new_fixup "vtbl" in
124       Asm.DEF (table_fix, table_of_fixup_rel_fixups table_fix fixups)
125   in
126
127   let nabi_indirect =
128       match cx.ctxt_sess.Session.sess_targ with
129           Linux_x86_elf -> false
130         | _ -> true
131   in
132
133   let nabi_rust =
134     { nabi_indirect = nabi_indirect;
135       nabi_convention = CONV_rust }
136   in
137
138   let out_mem_disp = abi.Abi.abi_frame_base_sz in
139   let arg0_disp =
140     Int64.add abi.Abi.abi_frame_base_sz abi.Abi.abi_implicit_args_sz
141   in
142   let frame_crate_ptr = word_n (-1) in
143   let frame_fns_disp = word_n (-2) in
144
145   let fn_ty (id:node_id) : Ast.ty =
146     Hashtbl.find cx.ctxt_all_item_types id
147   in
148   let fn_args_rty
149       (id:node_id)
150       (closure:Il.referent_ty option)
151       : Il.referent_ty =
152     let n_params =
153       if item_is_obj_fn cx id
154       then 0
155       else n_item_ty_params cx id
156     in
157       call_args_referent_type cx n_params (fn_ty id) closure
158   in
159
160   let emitters = Stack.create () in
161   let push_new_emitter (vregs_ok:bool) (fnid:node_id option) =
162     let e = Il.new_emitter
163          abi.Abi.abi_prealloc_quad
164          abi.Abi.abi_is_2addr_machine
165          vregs_ok fnid
166     in
167       Stack.push (Hashtbl.create 0) e.Il.emit_size_cache;
168       Stack.push e emitters;
169   in
170
171   let push_new_emitter_with_vregs fnid = push_new_emitter true fnid in
172   let push_new_emitter_without_vregs fnid = push_new_emitter false fnid in
173
174   let pop_emitter _ = ignore (Stack.pop emitters) in
175   let emitter _ = Stack.top emitters in
176   let emitter_size_cache _ = Stack.top (emitter()).Il.emit_size_cache in
177   let push_emitter_size_cache _ =
178     Stack.push
179       (Hashtbl.copy (emitter_size_cache()))
180       (emitter()).Il.emit_size_cache
181   in
182   let pop_emitter_size_cache _ =
183     ignore (Stack.pop (emitter()).Il.emit_size_cache)
184   in
185   let emit q = Il.emit (emitter()) q in
186   let next_vreg _ = Il.next_vreg (emitter()) in
187   let next_vreg_cell t = Il.next_vreg_cell (emitter()) t in
188   let next_spill_cell t =
189     let s = Il.next_spill (emitter()) in
190     let spill_mem = Il.Spill s in
191     let spill_ta = (spill_mem, Il.ScalarTy t) in
192       Il.Mem spill_ta
193   in
194   let mark _ : quad_idx = (emitter()).Il.emit_pc in
195   let patch_existing (jmp:quad_idx) (targ:quad_idx) : unit =
196     Il.patch_jump (emitter()) jmp targ
197   in
198   let patch (i:quad_idx) : unit =
199     Il.patch_jump (emitter()) i (mark());
200     (* Insert a dead quad to ensure there's an otherwise-unused
201      * jump-target here.
202      *)
203     emit Il.Dead
204   in
205
206   let current_fn () =
207     match (emitter()).Il.emit_node with
208         None -> bug () "current_fn without associated node"
209       | Some id -> id
210   in
211   let current_fn_args_rty (closure:Il.referent_ty option) : Il.referent_ty =
212     fn_args_rty (current_fn()) closure
213   in
214   let current_fn_callsz () = get_callsz cx (current_fn()) in
215
216   let annotations _ =
217     (emitter()).Il.emit_annotations
218   in
219
220   let annotate (str:string) =
221     let e = emitter() in
222       Hashtbl.add e.Il.emit_annotations e.Il.emit_pc str
223   in
224
225   let epilogue_jumps = Stack.create() in
226
227   let path_name (_:unit) : string =
228     string_of_name (Walk.path_to_name path)
229   in
230
231   let based (reg:Il.reg) : Il.mem =
232     Il.RegIn (reg, None)
233   in
234
235   let based_off (reg:Il.reg) (off:Asm.expr64) : Il.mem =
236     Il.RegIn (reg, Some off)
237   in
238
239   let based_imm (reg:Il.reg) (imm:int64) : Il.mem =
240     based_off reg (Asm.IMM imm)
241   in
242
243   let fp_imm (imm:int64) : Il.mem =
244     based_imm abi.Abi.abi_fp_reg imm
245   in
246
247   let sp_imm (imm:int64) : Il.mem =
248     based_imm abi.Abi.abi_sp_reg imm
249   in
250
251   let word_at (mem:Il.mem) : Il.cell =
252     Il.Mem (mem, Il.ScalarTy (Il.ValTy word_bits))
253   in
254
255   let mov (dst:Il.cell) (src:Il.operand) : unit =
256     emit (Il.umov dst src)
257   in
258
259   let umul (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
260     emit (Il.binary Il.UMUL dst a b);
261   in
262
263   let add (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
264     emit (Il.binary Il.ADD dst a b);
265   in
266
267   let add_to (dst:Il.cell) (src:Il.operand) : unit =
268     add dst (Il.Cell dst) src;
269   in
270
271   let sub (dst:Il.cell) (a:Il.operand) (b:Il.operand) : unit =
272     emit (Il.binary Il.SUB dst a b);
273   in
274
275   let sub_from (dst:Il.cell) (src:Il.operand) : unit =
276     sub dst (Il.Cell dst) src;
277   in
278
279   let lea (dst:Il.cell) (src:Il.mem) : unit =
280     emit (Il.lea dst (Il.Cell (Il.Mem (src, Il.OpaqueTy))))
281   in
282
283   let rty_ptr_at (mem:Il.mem) (pointee_rty:Il.referent_ty) : Il.cell =
284     Il.Mem (mem, Il.ScalarTy (Il.AddrTy pointee_rty))
285   in
286
287   let ptr_at (mem:Il.mem) (pointee_ty:Ast.ty) : Il.cell =
288     rty_ptr_at mem (referent_type abi pointee_ty)
289   in
290
291   let need_scalar_ty (rty:Il.referent_ty) : Il.scalar_ty =
292     match rty with
293         Il.ScalarTy s -> s
294       | _ -> bug () "expected ScalarTy"
295   in
296
297   let need_mem_cell (cell:Il.cell) : Il.typed_mem =
298     match cell with
299         Il.Mem a -> a
300       | Il.Reg _ -> bug ()
301           "expected address cell, got non-address register cell"
302   in
303
304   let need_cell (operand:Il.operand) : Il.cell =
305     match operand with
306         Il.Cell c -> c
307       | _ -> bug () "expected cell, got operand %s"
308           (Il.string_of_operand  abi.Abi.abi_str_of_hardreg operand)
309   in
310
311   let get_element_ptr =
312     Il.get_element_ptr word_bits abi.Abi.abi_str_of_hardreg
313   in
314
315   let get_variant_ptr (mem_cell:Il.cell) (i:int) : Il.cell =
316     match mem_cell with
317         Il.Mem (mem, Il.UnionTy elts)
318           when i >= 0 && i < (Array.length elts) ->
319             assert ((Array.length elts) != 0);
320             Il.Mem (mem, elts.(i))
321
322       | _ -> bug () "get_variant_ptr %d on cell %s" i
323           (cell_str mem_cell)
324   in
325
326   let rec ptr_cast (cell:Il.cell) (rty:Il.referent_ty) : Il.cell =
327     match cell with
328         Il.Mem (mem, _) -> Il.Mem (mem, rty)
329       | Il.Reg (reg, Il.AddrTy _) -> Il.Reg (reg, Il.AddrTy rty)
330       | _ -> bug () "expected address cell in Trans.ptr_cast"
331
332   and curr_crate_ptr _ : Il.cell =
333     word_at (fp_imm frame_crate_ptr)
334
335   and crate_rel_to_ptr (rel:Il.operand) (rty:Il.referent_ty) : Il.cell =
336     let cell = next_vreg_cell (Il.AddrTy rty) in
337       mov cell (Il.Cell (curr_crate_ptr()));
338       add_to cell rel;
339       cell
340
341   (* 
342    * Note: alias *requires* its cell to be in memory already, and should
343    * only be used on slots you know to be memory-resident. Use 'aliasing' or 
344    * 'via_memory' if you have a cell or operand you want in memory for a very
345    * short period of time (the time spent by the code generated by the thunk).
346    *)
347
348   and alias (cell:Il.cell) : Il.cell =
349     let mem, ty = need_mem_cell cell in
350     let vreg_cell = next_vreg_cell (Il.AddrTy ty) in
351       begin
352         match ty with
353             Il.NilTy -> ()
354           | _ -> lea vreg_cell mem
355       end;
356       vreg_cell
357
358   and force_to_mem (src:Il.operand) : Il.typed_mem =
359     let do_spill op (t:Il.scalar_ty) =
360       let spill = next_spill_cell t in
361         mov spill op;
362         need_mem_cell spill
363     in
364     match src with
365         Il.Cell (Il.Mem ta) -> ta
366       | Il.Cell (Il.Reg (_, t)) -> do_spill src t
367       | Il.Imm (_,tm) -> do_spill src (Il.ValTy (Il.bits_of_ty_mach tm))
368       | Il.ImmPtr (f, rty) ->
369           do_spill
370             (Il.Cell (crate_rel_to_ptr (crate_rel_imm f) rty))
371             (Il.AddrTy rty)
372
373   and force_to_reg (op:Il.operand) : Il.typed_reg =
374     let do_mov op st =
375       let tmp = next_vreg () in
376       let regty = (tmp, st) in
377         mov (Il.Reg regty) op;
378         regty
379     in
380       match op with
381           Il.Imm  (_, tm) -> do_mov op (Il.ValTy (Il.bits_of_ty_mach tm))
382         | Il.ImmPtr (f, rty) ->
383             do_mov
384               (Il.Cell (crate_rel_to_ptr (crate_rel_imm f) rty))
385               (Il.AddrTy rty)
386         | Il.Cell (Il.Reg rt) -> rt
387         | Il.Cell (Il.Mem (_, Il.ScalarTy st)) -> do_mov op st
388         | Il.Cell (Il.Mem (_, rt)) ->
389             bug () "forcing non-scalar referent of type %s to register"
390               (Il.string_of_referent_ty rt)
391
392   and via_memory (writeback:bool) (c:Il.cell) (thunk:Il.cell -> unit) : unit =
393     match c with
394         Il.Mem _ -> thunk c
395       | Il.Reg _ ->
396           let mem_c = Il.Mem (force_to_mem (Il.Cell c)) in
397             thunk mem_c;
398             if writeback
399             then
400               mov c (Il.Cell mem_c)
401
402   and aliasing (writeback:bool) (c:Il.cell) (thunk:Il.cell -> unit) : unit =
403     via_memory writeback c (fun c -> thunk (alias c))
404
405   and pointee_type (ptr:Il.cell) : Il.referent_ty =
406     match ptr with
407         Il.Reg (_, (Il.AddrTy rt)) -> rt
408       | Il.Mem (_, Il.ScalarTy (Il.AddrTy rt)) -> rt
409       | _ ->
410           bug () "taking pointee-type of non-address cell %s "
411             (cell_str ptr)
412
413   and deref (ptr:Il.cell) : Il.cell =
414     let (r, st) = force_to_reg (Il.Cell ptr) in
415       match st with
416           Il.AddrTy rt -> Il.Mem (based r, rt)
417         | _ -> bug () "dereferencing non-address cell of type %s "
418             (Il.string_of_scalar_ty st)
419
420   and deref_off (ptr:Il.cell) (off:Asm.expr64) : Il.cell =
421     let (r, st) = force_to_reg (Il.Cell ptr) in
422       match st with
423           Il.AddrTy rt -> Il.Mem (based_off r off, rt)
424         | _ -> bug () "offset-dereferencing non-address cell of type %s "
425             (Il.string_of_scalar_ty st)
426
427   and deref_imm (ptr:Il.cell) (imm:int64) : Il.cell =
428     deref_off ptr (Asm.IMM imm)
429
430   and tp_imm (imm:int64) : Il.cell =
431     deref_imm abi.Abi.abi_tp_cell imm
432   in
433
434
435   let make_tydesc_tys n =
436     Array.init n (fun _ -> Ast.TY_type)
437   in
438
439   let cell_vreg_num (vr:(int option) ref) : int =
440     match !vr with
441         None ->
442           let v = (Il.next_vreg_num (emitter())) in
443             vr := Some v;
444             v
445       | Some v -> v
446   in
447
448   let slot_id_referent_type (slot_id:node_id) : Il.referent_ty =
449     slot_referent_type abi (get_slot cx slot_id)
450   in
451
452   let caller_args_cell (args_rty:Il.referent_ty) : Il.cell =
453     Il.Mem (fp_imm out_mem_disp, args_rty)
454   in
455
456   let get_ty_param (ty_params:Il.cell) (param_idx:int) : Il.cell =
457       get_element_ptr ty_params param_idx
458   in
459
460   let get_ty_params_of_frame (fp:Il.reg) (n_params:int) : Il.cell =
461     let fn_ty = mk_simple_ty_fn [| |] in
462     let fn_rty = call_args_referent_type cx n_params fn_ty None in
463     let args_cell = Il.Mem (based_imm fp out_mem_disp, fn_rty) in
464       get_element_ptr args_cell Abi.calltup_elt_ty_params
465   in
466
467   let get_args_for_current_frame _ =
468     let curr_args_rty =
469       current_fn_args_rty (Some Il.OpaqueTy)
470     in
471       caller_args_cell curr_args_rty
472   in
473
474   let get_indirect_args_for_current_frame _ =
475     get_element_ptr (get_args_for_current_frame ())
476       Abi.calltup_elt_indirect_args
477   in
478
479   let get_iterator_args_for_current_frame _ =
480     get_element_ptr (get_args_for_current_frame ())
481       Abi.calltup_elt_iterator_args
482   in
483
484   let get_closure_for_current_frame _ =
485     let self_indirect_args =
486       get_indirect_args_for_current_frame ()
487     in
488       get_element_ptr self_indirect_args
489         Abi.indirect_args_elt_closure
490   in
491
492   let get_iter_block_fn_for_current_frame _ =
493     let self_iterator_args =
494       get_iterator_args_for_current_frame ()
495     in
496     let blk_fn = get_element_ptr self_iterator_args
497       Abi.iterator_args_elt_block_fn
498     in
499       ptr_cast blk_fn
500         (Il.ScalarTy (Il.AddrTy Il.CodeTy))
501   in
502
503   let get_iter_outer_frame_ptr_for_current_frame _ =
504     let self_iterator_args =
505       get_iterator_args_for_current_frame ()
506     in
507       get_element_ptr self_iterator_args
508         Abi.iterator_args_elt_outer_frame_ptr
509   in
510
511   let get_obj_for_current_frame _ =
512     deref (ptr_cast
513              (get_closure_for_current_frame ())
514              (Il.ScalarTy (Il.AddrTy (obj_closure_rty abi))))
515   in
516
517   let get_ty_params_of_current_frame _ : Il.cell =
518     let id = current_fn() in
519     let n_ty_params = n_item_ty_params cx id in
520       if item_is_obj_fn cx id
521       then
522         begin
523           let obj = get_obj_for_current_frame() in
524           let tydesc = get_element_ptr obj 1 in
525           let ty_params_ty = Ast.TY_tup (make_tydesc_tys n_ty_params) in
526           let ty_params_rty = referent_type abi ty_params_ty in
527           let ty_params =
528             get_element_ptr (deref tydesc) Abi.tydesc_field_first_param
529           in
530           let ty_params =
531             ptr_cast ty_params (Il.ScalarTy (Il.AddrTy ty_params_rty))
532           in
533             deref ty_params
534         end
535
536       else
537         get_ty_params_of_frame abi.Abi.abi_fp_reg n_ty_params
538   in
539
540   let get_ty_param_in_current_frame (param_idx:int) : Il.cell =
541     get_ty_param (get_ty_params_of_current_frame()) param_idx
542   in
543
544   let linearize_ty_params (ty:Ast.ty) : (Ast.ty * Il.operand array) =
545     let htab = Hashtbl.create 0 in
546     let q = Queue.create () in
547     let base = ty_fold_rebuild (fun t -> t) in
548     let ty_fold_param (i, mut) =
549       let param = Ast.TY_param (i, mut) in
550         match htab_search htab param with
551             Some p -> p
552           | None ->
553               let p = Ast.TY_param (Hashtbl.length htab, mut) in
554                 htab_put htab param p;
555                 Queue.add (Il.Cell (get_ty_param_in_current_frame i)) q;
556                 p
557     in
558       let fold =
559         { base with
560             ty_fold_param = ty_fold_param; }
561       in
562       let ty = fold_ty fold ty in
563         (ty, queue_to_arr q)
564   in
565
566   let has_parametric_types (t:Ast.ty) : bool =
567     let base = ty_fold_bool_or false in
568     let ty_fold_param _ =
569       true
570     in
571     let fold = { base with ty_fold_param = ty_fold_param } in
572       fold_ty fold t
573   in
574
575   let rec calculate_sz (ty_params:Il.cell) (size:size) : Il.operand =
576     iflog (fun _ -> annotate
577              (Printf.sprintf "calculating size %s"
578                 (string_of_size size)));
579     let sub_sz = calculate_sz ty_params in
580     match htab_search (emitter_size_cache()) size with
581         Some op -> op
582       | _ ->
583           let res =
584             match size with
585                 SIZE_fixed i -> imm i
586               | SIZE_fixup_mem_pos f -> Il.Imm (Asm.M_POS f, word_ty_mach)
587               | SIZE_fixup_mem_sz f -> Il.Imm (Asm.M_SZ f, word_ty_mach)
588
589               | SIZE_param_size i ->
590                   let tydesc = deref (get_ty_param ty_params i) in
591                     Il.Cell (get_element_ptr tydesc Abi.tydesc_field_size)
592
593               | SIZE_param_align i ->
594                   let tydesc = deref (get_ty_param ty_params i) in
595                     Il.Cell (get_element_ptr tydesc Abi.tydesc_field_align)
596
597               | SIZE_rt_neg a ->
598                   let op_a = sub_sz a in
599                   let tmp = next_vreg_cell word_sty in
600                     emit (Il.unary Il.NEG tmp op_a);
601                     Il.Cell tmp
602
603               | SIZE_rt_add (a, b) ->
604                   let op_a = sub_sz a in
605                   let op_b = sub_sz b in
606                   let tmp = next_vreg_cell word_sty in
607                     add tmp op_a op_b;
608                     Il.Cell tmp
609
610               | SIZE_rt_mul (a, b) ->
611                   let op_a = sub_sz a in
612                   let op_b = sub_sz b in
613                   let tmp = next_vreg_cell word_sty in
614                     emit (Il.binary Il.UMUL tmp op_a op_b);
615                     Il.Cell tmp
616
617               | SIZE_rt_max (a, b) ->
618                   let op_a = sub_sz a in
619                   let op_b = sub_sz b in
620                   let tmp = next_vreg_cell word_sty in
621                     mov tmp op_a;
622                     emit (Il.cmp op_a op_b);
623                     let jmp = mark () in
624                       emit (Il.jmp Il.JAE Il.CodeNone);
625                       mov tmp op_b;
626                       patch jmp;
627                       Il.Cell tmp
628
629               | SIZE_rt_align (align, off) ->
630                   (*
631                    * calculate off + pad where:
632                    *
633                    * pad = (align - (off mod align)) mod align
634                    * 
635                    * In our case it's always a power of two, 
636                    * so we can just do:
637                    * 
638                    * mask = align-1
639                    * off += mask
640                    * off &= ~mask
641                    *
642                    *)
643                   annotate "fetch alignment";
644                   let op_align = sub_sz align in
645                     annotate "fetch offset";
646                     let op_off = sub_sz off in
647                     let mask = next_vreg_cell word_sty in
648                     let off = next_vreg_cell word_sty in
649                       mov mask op_align;
650                       sub_from mask one;
651                       mov off op_off;
652                       add_to off (Il.Cell mask);
653                       emit (Il.unary Il.NOT mask (Il.Cell mask));
654                       emit (Il.binary Il.AND
655                               off (Il.Cell off) (Il.Cell mask));
656                       Il.Cell off
657           in
658             iflog (fun _ -> annotate
659                      (Printf.sprintf "calculated size %s is %s"
660                         (string_of_size size)
661                         (oper_str res)));
662             htab_put (emitter_size_cache()) size res;
663             res
664
665
666   and calculate_sz_in_current_frame (size:size) : Il.operand =
667     calculate_sz (get_ty_params_of_current_frame()) size
668
669   and callee_args_cell (tail_area:bool) (args_rty:Il.referent_ty) : Il.cell =
670     if tail_area
671     then
672       Il.Mem (sp_off_sz (current_fn_callsz ()), args_rty)
673     else
674       Il.Mem (sp_imm 0L, args_rty)
675
676   and based_sz (ty_params:Il.cell) (reg:Il.reg) (size:size) : Il.mem =
677     match Il.size_to_expr64 size with
678         Some e -> based_off reg e
679       | None ->
680              let runtime_size = calculate_sz ty_params size in
681              let v = next_vreg () in
682              let c = (Il.Reg (v, word_sty)) in
683                mov c (Il.Cell (Il.Reg (reg, word_sty)));
684                add_to c runtime_size;
685                based v
686
687   and fp_off_sz (size:size) : Il.mem =
688     based_sz (get_ty_params_of_current_frame()) abi.Abi.abi_fp_reg size
689
690   and sp_off_sz (size:size) : Il.mem =
691     based_sz (get_ty_params_of_current_frame()) abi.Abi.abi_sp_reg size
692   in
693
694   let ty_sz_in_current_frame (ty:Ast.ty) : Il.operand =
695     let rty = referent_type abi ty in
696     let sz = Il.referent_ty_size word_bits rty in
697       calculate_sz_in_current_frame sz
698   in
699
700   let ty_sz_with_ty_params
701       (ty_params:Il.cell)
702       (ty:Ast.ty)
703       : Il.operand =
704     let rty = referent_type abi ty in
705     let sz = Il.referent_ty_size word_bits rty in
706       calculate_sz ty_params sz
707   in
708
709   let get_element_ptr_dyn
710       (ty_params:Il.cell)
711       (mem_cell:Il.cell)
712       (i:int)
713       : Il.cell =
714     match mem_cell with
715         Il.Mem (mem, Il.StructTy elts)
716           when i >= 0 && i < (Array.length elts) ->
717             assert ((Array.length elts) != 0);
718             begin
719               let elt_rty = elts.(i) in
720               let elt_off = Il.get_element_offset word_bits elts i in
721                 match elt_off with
722                     SIZE_fixed fixed_off ->
723                       Il.Mem (Il.mem_off_imm mem fixed_off, elt_rty)
724                   | sz ->
725                       let sz = calculate_sz ty_params sz in
726                       let v = next_vreg word_sty in
727                       let vc = Il.Reg (v, word_sty) in
728                         lea vc mem;
729                         add_to vc sz;
730                         Il.Mem (based v, elt_rty)
731             end
732       | _ -> bug () "get_element_ptr_dyn %d on cell %s" i
733           (cell_str mem_cell)
734   in
735
736   let get_element_ptr_dyn_in_current_frame
737       (mem_cell:Il.cell)
738       (i:int)
739       : Il.cell =
740     get_element_ptr_dyn (get_ty_params_of_current_frame()) mem_cell i
741   in
742
743   let deref_off_sz
744       (ty_params:Il.cell)
745       (ptr:Il.cell)
746       (size:size)
747       : Il.cell =
748     match Il.size_to_expr64 size with
749         Some e -> deref_off ptr e
750       | None ->
751           let (r,_) = force_to_reg (Il.Cell ptr) in
752           let mem = based_sz ty_params r size in
753             Il.Mem (mem, (pointee_type ptr))
754   in
755
756   let cell_of_block_slot
757       (slot_id:node_id)
758       : Il.cell =
759     let referent_type = slot_id_referent_type slot_id in
760       match htab_search cx.ctxt_slot_vregs slot_id with
761           Some vr ->
762             begin
763               match referent_type with
764                   Il.ScalarTy st -> Il.Reg (Il.Vreg (cell_vreg_num vr), st)
765                 | Il.NilTy -> nil_ptr
766                 | Il.StructTy _ -> bugi cx slot_id
767                     "cannot treat structured referent as single operand"
768                 | Il.UnionTy _ -> bugi cx slot_id
769                     "cannot treat union referent as single operand"
770                 | Il.ParamTy _ -> bugi cx slot_id
771                     "cannot treat parametric referent as single operand"
772                 | Il.OpaqueTy -> bugi cx slot_id
773                     "cannot treat opaque referent as single operand"
774                 | Il.CodeTy ->  bugi cx slot_id
775                     "cannot treat code referent as single operand"
776             end
777         | None ->
778             begin
779               match htab_search cx.ctxt_slot_offsets slot_id with
780                   None -> bugi cx slot_id
781                     "slot assigned to neither vreg nor offset"
782                 | Some off ->
783                     if slot_is_obj_state cx slot_id
784                     then
785                       begin
786                         let state_arg = get_closure_for_current_frame () in
787                         let (slot_mem, _) =
788                           need_mem_cell (deref_off_sz
789                                            (get_ty_params_of_current_frame())
790                                            state_arg off)
791                         in
792                           Il.Mem (slot_mem, referent_type)
793                       end
794                     else
795                       if (Stack.is_empty curr_stmt)
796                       then
797                         Il.Mem (fp_off_sz off, referent_type)
798                       else
799                         let slot_depth = get_slot_depth cx slot_id in
800                         let stmt_depth =
801                           get_stmt_depth cx (Stack.top curr_stmt)
802                         in
803                           if slot_depth <> stmt_depth
804                           then
805                             let _ = assert (slot_depth < stmt_depth) in
806                             let _ =
807                               iflog
808                                 begin
809                                   fun _ ->
810                                     let k =
811                                       Hashtbl.find cx.ctxt_slot_keys slot_id
812                                     in
813                                       annotate
814                                         (Printf.sprintf
815                                            "access outer frame slot #%d = %s"
816                                            (int_of_node slot_id)
817                                            (Fmt.fmt_to_str
818                                               Ast.fmt_slot_key k))
819                                 end
820                             in
821                             let diff = stmt_depth - slot_depth in
822                             let _ = annotate "get outer frame pointer" in
823                             let fp =
824                               get_iter_outer_frame_ptr_for_current_frame ()
825                             in
826                               if diff > 1
827                               then
828                                 bug () "unsupported nested for each loop";
829                               for i = 2 to diff do
830                                 (* FIXME (issue #79): access outer
831                                  * caller-block fps, given nearest
832                                  * caller-block fp. 
833                                  *)
834                                 let _ =
835                                   annotate "step to outer-outer frame"
836                                 in
837                                   mov fp (Il.Cell fp)
838                               done;
839                               let _ = annotate "calculate size" in
840                               let p =
841                                 based_sz (get_ty_params_of_current_frame())
842                                   (fst (force_to_reg (Il.Cell fp))) off
843                               in
844                                 Il.Mem (p, referent_type)
845                           else
846                             Il.Mem (fp_off_sz off, referent_type)
847             end
848   in
849
850   let binop_to_jmpop (binop:Ast.binop) : Il.jmpop =
851     match binop with
852         Ast.BINOP_eq -> Il.JE
853       | Ast.BINOP_ne -> Il.JNE
854       | Ast.BINOP_lt -> Il.JL
855       | Ast.BINOP_le -> Il.JLE
856       | Ast.BINOP_ge -> Il.JGE
857       | Ast.BINOP_gt -> Il.JG
858       | _ -> bug () "Unhandled binop in binop_to_jmpop"
859   in
860
861   let get_vtbl_entry_idx (table_ptr:Il.cell) (i:int) : Il.cell =
862     (* Vtbls are encoded as tables of table-relative displacements. *)
863     let (table_mem, _) = need_mem_cell (deref table_ptr) in
864     let disp = Il.Cell (word_at (Il.mem_off_imm table_mem (word_n i))) in
865     let ptr_cell = next_vreg_cell (Il.AddrTy Il.CodeTy) in
866       mov ptr_cell (Il.Cell table_ptr);
867       add_to ptr_cell disp;
868       ptr_cell
869   in
870
871   let get_vtbl_entry
872       (obj_cell:Il.cell)
873       (obj_ty:Ast.ty_obj)
874       (id:Ast.ident)
875       : (Il.cell * Ast.ty_fn) =
876     let (_, fns) = obj_ty in
877     let sorted_idents = sorted_htab_keys fns in
878     let i = arr_idx sorted_idents id in
879     let fn_ty = Hashtbl.find fns id in
880     let table_ptr = get_element_ptr obj_cell Abi.binding_field_item in
881       (get_vtbl_entry_idx table_ptr i, fn_ty)
882   in
883
884   let rec trans_slot_lval_ext
885       (initializing:bool)
886       (base_ty:Ast.ty)
887       (cell:Il.cell)
888       (comp:Ast.lval_component)
889       : (Il.cell * Ast.ty) =
890
891     let bounds_checked_access at ty =
892       let atop = trans_atom at in
893       let unit_sz = ty_sz_in_current_frame ty in
894       let idx = next_vreg_cell word_sty in
895         emit (Il.binary Il.UMUL idx atop unit_sz);
896         let elt_mem = trans_bounds_check (deref cell) (Il.Cell idx) in
897           (Il.Mem (elt_mem, referent_type abi ty), ty)
898     in
899       (* 
900        * All lval components aside from explicit-deref just auto-deref
901        * through all boxes to find their indexable referent.
902        *)
903     let base_ty = strip_mutable_or_constrained_ty base_ty in
904     let (cell, base_ty) =
905       if comp = Ast.COMP_deref
906       then (cell, base_ty)
907       else deref_ty DEREF_all_boxes initializing cell base_ty
908     in
909
910     match (base_ty, comp) with
911         (Ast.TY_rec entries,
912          Ast.COMP_named (Ast.COMP_ident id)) ->
913           let i = arr_idx (Array.map fst entries) id in
914             (get_element_ptr_dyn_in_current_frame cell i, snd entries.(i))
915
916       | (Ast.TY_tup entries,
917          Ast.COMP_named (Ast.COMP_idx i)) ->
918           (get_element_ptr_dyn_in_current_frame cell i, entries.(i))
919
920       | (Ast.TY_vec ty,
921          Ast.COMP_atom at) ->
922           bounds_checked_access at ty
923
924       | (Ast.TY_str,
925          Ast.COMP_atom at) ->
926           bounds_checked_access at (Ast.TY_mach TY_u8)
927
928       | (Ast.TY_obj obj_ty,
929          Ast.COMP_named (Ast.COMP_ident id)) ->
930           let (cell, fn_ty) = get_vtbl_entry cell obj_ty id in
931             (cell, (Ast.TY_fn fn_ty))
932
933       | (Ast.TY_box _, Ast.COMP_deref) ->
934           deref_ty DEREF_one_box initializing cell base_ty
935
936       | _ -> bug () "unhandled form of lval_ext in trans_slot_lval_ext"
937
938   (* 
939    * vec: operand holding ptr to vec.
940    * mul_idx: index value * unit size.
941    * return: ptr to element.
942    *)
943   and trans_bounds_check (vec:Il.cell) (mul_idx:Il.operand) : Il.mem =
944     let (len:Il.cell) = get_element_ptr vec Abi.vec_elt_fill in
945     let (data:Il.cell) = get_element_ptr vec Abi.vec_elt_data in
946     let (base:Il.cell) = next_vreg_cell Il.voidptr_t in
947     let (elt_reg:Il.reg) = next_vreg () in
948     let (elt:Il.cell) = Il.Reg (elt_reg, Il.voidptr_t) in
949     let (diff:Il.cell) = next_vreg_cell word_sty in
950       annotate "bounds check";
951       lea base (fst (need_mem_cell data));
952       add elt (Il.Cell base) mul_idx;
953       emit (Il.binary Il.SUB diff (Il.Cell elt) (Il.Cell base));
954       let jmp = trans_compare Il.JB (Il.Cell diff) (Il.Cell len) in
955         trans_cond_fail "bounds check" jmp;
956         based elt_reg
957
958   and trans_lval_full
959       (initializing:bool)
960       (lv:Ast.lval)
961       : (Il.cell * Ast.ty) =
962
963     let rec trans_slot_lval_full (initializing:bool) lv =
964       let (cell, ty) =
965         match lv with
966             Ast.LVAL_ext (base, comp) ->
967               let (base_cell, base_ty) =
968                 trans_slot_lval_full initializing base
969               in
970                 trans_slot_lval_ext initializing base_ty base_cell comp
971
972           | Ast.LVAL_base nbi ->
973               let sloti = lval_base_to_slot cx lv in
974               let cell = cell_of_block_slot sloti.id in
975               let ty = slot_ty sloti.node in
976               let cell = deref_slot initializing cell sloti.node in
977               let dctrl =
978                 (* If this fails, type didn't visit the lval, and we
979                  * don't know whether to auto-deref its base. Crashing
980                  * here is best. Compiler bug.
981                  *)
982                 match htab_search cx.ctxt_auto_deref_lval nbi.id with
983                     None ->
984                       bugi cx nbi.id
985                         "Lval without auto-deref info; bad typecheck?"
986                   | Some true -> DEREF_all_boxes
987                   | Some false -> DEREF_none
988               in
989                 deref_ty dctrl initializing cell ty
990       in
991         iflog
992           begin
993             fun _ ->
994               annotate
995                 (Printf.sprintf "lval %a = %s"
996                    Ast.sprintf_lval lv
997                    (cell_str cell))
998           end;
999         (cell, ty)
1000
1001     in
1002       if lval_is_slot cx lv
1003       then trans_slot_lval_full initializing lv
1004       else
1005         if initializing
1006         then err None "init item"
1007         else
1008           begin
1009             assert (lval_is_item cx lv);
1010             bug ()
1011               "trans_lval_full called on item lval '%a'" Ast.sprintf_lval lv
1012           end
1013
1014   and trans_lval_maybe_init
1015       (initializing:bool)
1016       (lv:Ast.lval)
1017       : (Il.cell * Ast.ty) =
1018     trans_lval_full initializing lv
1019
1020   and trans_lval_init (lv:Ast.lval) : (Il.cell * Ast.ty) =
1021     trans_lval_maybe_init true lv
1022
1023   and trans_lval (lv:Ast.lval) : (Il.cell * Ast.ty) =
1024     trans_lval_maybe_init false lv
1025
1026   and trans_callee
1027       (flv:Ast.lval)
1028       : (Il.operand * Ast.ty) =
1029     (* direct call to item *)
1030     let fty = Hashtbl.find cx.ctxt_all_lval_types (lval_base_id flv) in
1031       if lval_is_item cx flv then
1032         let fn_item = lval_item cx flv in
1033         let fn_ptr = code_fixup_to_ptr_operand (get_fn_fixup cx fn_item.id) in
1034           (fn_ptr, fty)
1035       else
1036         (* indirect call to computed slot *)
1037         let (cell, _) = trans_lval flv in
1038           (Il.Cell cell, fty)
1039
1040   and align x =
1041     Asm.ALIGN_FILE (16, Asm.ALIGN_MEM(16, x))
1042
1043   and trans_crate_rel_data_operand
1044       (d:data)
1045       (thunk:unit -> Asm.frag)
1046       : Il.operand =
1047     let (fix, _) =
1048       htab_search_or_add cx.ctxt_data d
1049         begin
1050           fun _ ->
1051             let fix = new_fixup "data item" in
1052             let frag = align (Asm.DEF (fix, thunk())) in
1053               (fix, frag)
1054         end
1055     in
1056       crate_rel_imm fix
1057
1058   and trans_crate_rel_data_frag (d:data) (thunk:unit -> Asm.frag) : Asm.frag =
1059     let (fix, _) =
1060       htab_search_or_add cx.ctxt_data d
1061         begin
1062           fun _ ->
1063             let fix = new_fixup "data item" in
1064             let frag = align (Asm.DEF (fix, thunk())) in
1065               (fix, frag)
1066         end
1067     in
1068       crate_rel_word fix
1069
1070   and trans_crate_rel_static_string_operand (s:string) : Il.operand =
1071     trans_crate_rel_data_operand (DATA_str s) (fun _ -> Asm.ZSTRING s)
1072
1073   and trans_crate_rel_static_string_frag (s:string) : Asm.frag =
1074     trans_crate_rel_data_frag (DATA_str s) (fun _ -> Asm.ZSTRING s)
1075
1076   and trans_static_string (s:string) : Il.operand =
1077     Il.Cell (crate_rel_to_ptr
1078                (trans_crate_rel_static_string_operand s)
1079                (referent_type abi Ast.TY_str))
1080
1081   and get_static_tydesc
1082       (idopt:node_id option)
1083       (t:Ast.ty)
1084       (sz:int64)
1085       (align:int64)
1086       : Il.operand =
1087     trans_crate_rel_data_operand
1088       (DATA_tydesc t)
1089       begin
1090         fun _ ->
1091           let tydesc_fixup = new_fixup "tydesc" in
1092           let fix fixup =
1093             fixup_rel_word tydesc_fixup fixup
1094           in
1095           log cx "tydesc for %a has sz=%Ld, align=%Ld"
1096             Ast.sprintf_ty t sz align;
1097             Asm.DEF
1098               (tydesc_fixup,
1099                Asm.SEQ
1100                  [|
1101                    Asm.WORD (word_ty_mach, Asm.IMM 0L);
1102                    Asm.WORD (word_ty_mach, Asm.IMM sz);
1103                    Asm.WORD (word_ty_mach, Asm.IMM align);
1104                    fix (get_copy_glue t None);
1105                    fix (get_drop_glue t None);
1106                    begin
1107                      match ty_mem_ctrl t with
1108                          MEM_interior ->
1109                            Asm.WORD (word_ty_mach, Asm.IMM 0L);
1110                        | _ ->
1111                            fix (get_free_glue t (type_has_state t) None);
1112                    end;
1113                    fix (get_sever_glue t None);
1114                    fix (get_mark_glue t None);
1115                    (* Include any obj-dtor, if this is an obj and has one. *)
1116                    begin
1117                      match idopt with
1118                          None -> Asm.WORD (word_ty_mach, Asm.IMM 0L);
1119                        | Some oid ->
1120                            begin
1121                              let g = GLUE_obj_drop oid in
1122                                match htab_search cx.ctxt_glue_code g with
1123                                    Some code -> fix code.code_fixup
1124                                  | None ->
1125                                      Asm.WORD (word_ty_mach, Asm.IMM 0L);
1126                            end
1127                    end;
1128                  |])
1129       end
1130
1131   and get_obj_vtbl (id:node_id) : Il.operand =
1132     let obj =
1133       match Hashtbl.find cx.ctxt_all_defns id with
1134           DEFN_item { Ast.decl_item=Ast.MOD_ITEM_obj obj} -> obj
1135         | _ -> bug () "Trans.get_obj_vtbl on non-obj referent"
1136     in
1137       trans_crate_rel_data_operand (DATA_obj_vtbl id)
1138         begin
1139           fun _ ->
1140             iflog (fun _ -> log cx "emitting %d-entry obj vtbl for %s"
1141                      (Hashtbl.length obj.Ast.obj_fns) (path_name()));
1142             table_of_table_rel_fixups
1143               (Array.map
1144                  begin
1145                    fun k ->
1146                      let fn = Hashtbl.find obj.Ast.obj_fns k in
1147                        get_fn_fixup cx fn.id
1148                  end
1149                  (sorted_htab_keys obj.Ast.obj_fns))
1150         end
1151
1152
1153   and trans_copy_forward_args (args_rty:Il.referent_ty) : unit =
1154     let caller_args_cell = caller_args_cell args_rty in
1155     let callee_args_cell = callee_args_cell false args_rty in
1156     let (dst_reg, _) = force_to_reg (Il.Cell (alias callee_args_cell)) in
1157     let (src_reg, _) = force_to_reg (Il.Cell (alias caller_args_cell)) in
1158     let tmp_reg = next_vreg () in
1159     let nbytes = force_sz (Il.referent_ty_size word_bits args_rty) in
1160       abi.Abi.abi_emit_inline_memcpy (emitter())
1161         nbytes dst_reg src_reg tmp_reg false;
1162
1163
1164   and get_forwarding_obj_fn
1165       (ident:Ast.ident)
1166       (caller:Ast.ty_obj)
1167       (callee:Ast.ty_obj)
1168       : fixup =
1169     (* Forwarding "glue" is not glue in the normal sense of being called with
1170      * only Abi.worst_case_glue_call_args args; the functions are full-fleged
1171      * obj fns like any other, and they perform a full call to the target
1172      * obj. We just use the glue facility here to store the forwarding
1173      * operators somewhere.
1174      *)
1175     let g = GLUE_forward (ident, caller, callee) in
1176     let fix = new_fixup (glue_str cx g) in
1177     let fty = Hashtbl.find (snd caller) ident in
1178     let self_args_rty =
1179       call_args_referent_type cx 0
1180         (Ast.TY_fn fty) (Some (obj_closure_rty abi))
1181     in
1182     let callsz = Il.referent_ty_size word_bits self_args_rty in
1183     let spill = new_fixup "forwarding fn spill" in
1184       trans_glue_frame_entry callsz spill;
1185       let all_self_args_cell = caller_args_cell self_args_rty in
1186       let self_indirect_args_cell =
1187         get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
1188       in
1189         (*
1190          * Note: this is wrong. This assumes our closure is a vtbl,
1191          * when in fact it is a pointer to a refcounted malloc slab
1192          * containing an obj.
1193          *)
1194       let closure_cell =
1195         deref (get_element_ptr self_indirect_args_cell
1196                  Abi.indirect_args_elt_closure)
1197       in
1198
1199       let (callee_fn_cell, _) =
1200         get_vtbl_entry closure_cell callee ident
1201       in
1202         iflog (fun _ -> annotate "copy args forward to callee");
1203         trans_copy_forward_args self_args_rty;
1204
1205         iflog (fun _ -> annotate "call through to callee");
1206         (* FIXME (issue #80): use a tail-call here. *)
1207         call_code (code_of_cell callee_fn_cell);
1208         trans_glue_frame_exit fix spill g;
1209         fix
1210
1211
1212   and get_forwarding_vtbl
1213       (caller:Ast.ty_obj)
1214       (callee:Ast.ty_obj)
1215       : Il.operand =
1216     trans_crate_rel_data_operand (DATA_forwarding_vtbl (caller,callee))
1217       begin
1218         fun _ ->
1219           let (_,fns) = caller in
1220           iflog (fun _ -> log cx "emitting %d-entry obj forwarding vtbl"
1221                    (Hashtbl.length fns));
1222             table_of_table_rel_fixups
1223               (Array.map
1224                  begin
1225                    fun k ->
1226                      get_forwarding_obj_fn k caller callee
1227                  end
1228                  (sorted_htab_keys fns))
1229         end
1230
1231     and trans_init_str (dst:Ast.lval) (s:string) : unit =
1232       (* Include null byte. *)
1233     let init_sz = Int64.of_int ((String.length s) + 1) in
1234     let static = trans_static_string s in
1235     let (dst, _) = trans_lval_init dst in
1236       trans_upcall "upcall_new_str" dst [| static; imm init_sz |]
1237
1238   and trans_lit (lit:Ast.lit) : Il.operand =
1239     match lit with
1240         Ast.LIT_nil -> Il.Cell (nil_ptr)
1241       | Ast.LIT_bool false -> imm_false
1242       | Ast.LIT_bool true -> imm_true
1243       | Ast.LIT_char c -> imm_of_ty (Int64.of_int c) TY_u32
1244       | Ast.LIT_int (i, _) -> simm i
1245       | Ast.LIT_uint (i, _) -> imm i
1246       | Ast.LIT_mach (m, n, _) -> imm_of_ty n m
1247
1248   and trans_atom (atom:Ast.atom) : Il.operand =
1249     iflog
1250       begin
1251         fun _ ->
1252           annotate (Fmt.fmt_to_str Ast.fmt_atom atom)
1253       end;
1254     match atom with
1255         Ast.ATOM_lval lv ->
1256           let (cell, ty) = trans_lval lv in
1257             Il.Cell (fst (deref_ty DEREF_none false cell ty))
1258
1259       | Ast.ATOM_literal lit -> trans_lit lit.node
1260
1261   and fixup_to_ptr_operand
1262       (imm_ok:bool)
1263       (fix:fixup)
1264       (referent_ty:Il.referent_ty)
1265       : Il.operand =
1266     if imm_ok
1267     then Il.ImmPtr (fix, referent_ty)
1268     else Il.Cell (crate_rel_to_ptr (crate_rel_imm fix) referent_ty)
1269
1270   and code_fixup_to_ptr_operand (fix:fixup) : Il.operand =
1271     fixup_to_ptr_operand abi.Abi.abi_has_pcrel_code fix Il.CodeTy
1272
1273   (* A pointer-valued op may be of the form ImmPtr, which carries its
1274    * target fixup, "constant-propagated" through trans so that
1275    * pc-relative addressing can make use of it whenever
1276    * appropriate. Reify_ptr exists for cases when you are about to
1277    * store an ImmPtr into a memory cell or other place beyond which the
1278    * compiler will cease to know about its identity; at this point you
1279    * should decay it to a crate-relative displacement and
1280    * (computationally) add it to the crate base value, before working
1281    * with it.
1282    * 
1283    * This helps you obey the IL type-system prohibition against
1284    * 'mov'-ing an ImmPtr to a cell. If you forget to call this
1285    * in the right places, you will get code-generation failures.
1286    *)
1287   and reify_ptr (op:Il.operand) : Il.operand =
1288     match op with
1289         Il.ImmPtr (fix, rty) ->
1290           Il.Cell (crate_rel_to_ptr (crate_rel_imm fix) rty)
1291       | _ -> op
1292
1293   and annotate_quads (name:string) : unit =
1294     let e = emitter() in
1295     let quads = emitted_quads e in
1296     let annotations = annotations() in
1297       log cx "emitted quads for %s:" name;
1298       for i = 0 to arr_max quads
1299       do
1300         if Hashtbl.mem annotations i
1301         then
1302           List.iter
1303             (fun a -> log cx "// %s" a)
1304             (List.rev (Hashtbl.find_all annotations i));
1305         log cx "[%6d]\t%s" i
1306           (Il.string_of_quad
1307              abi.Abi.abi_str_of_hardreg quads.(i));
1308       done
1309
1310
1311   and write_frame_info_ptrs (fnid:node_id option) =
1312     let frame_fns =
1313       match fnid with
1314           None -> zero
1315         | Some fnid -> get_frame_glue_fns fnid
1316     in
1317     let crate_ptr_reg = next_vreg () in
1318     let crate_ptr_cell = Il.Reg (crate_ptr_reg, (Il.AddrTy Il.OpaqueTy)) in
1319       iflog (fun _ -> annotate "write frame-info pointers");
1320       Abi.load_fixup_addr (emitter())
1321         crate_ptr_reg cx.ctxt_crate_fixup Il.OpaqueTy;
1322       mov (word_at (fp_imm frame_crate_ptr)) (Il.Cell (crate_ptr_cell));
1323       mov (word_at (fp_imm frame_fns_disp)) frame_fns
1324
1325   and check_interrupt_flag _ =
1326     let dom = next_vreg_cell wordptr_ty in
1327     let flag = next_vreg_cell word_sty in
1328       mov dom (Il.Cell (tp_imm (word_n Abi.task_field_dom)));
1329       mov flag (Il.Cell (deref_imm dom
1330                            (word_n Abi.dom_field_interrupt_flag)));
1331       let null_jmp = null_check flag in
1332         trans_yield ();
1333         patch null_jmp
1334
1335   and trans_glue_frame_entry
1336       (callsz:size)
1337       (spill:fixup)
1338       : unit =
1339     let framesz = SIZE_fixup_mem_sz spill in
1340       push_new_emitter_with_vregs None;
1341       iflog (fun _ -> annotate "prologue");
1342       abi.Abi.abi_emit_fn_prologue (emitter())
1343         framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
1344       write_frame_info_ptrs None;
1345       (* FIXME: not clear why, but checking interrupt in glue context
1346        * causes many.rs to crash when run on a sufficiently large number
1347        * of tasks; possibly a weird interaction with growing? *)
1348       (* check_interrupt_flag (); *)
1349       iflog (fun _ -> annotate "finished prologue");
1350
1351   and emitted_quads e =
1352     Array.sub e.Il.emit_quads 0 e.Il.emit_pc
1353
1354   and capture_emitted_glue (fix:fixup) (spill:fixup) (g:glue) : unit =
1355     let e = emitter() in
1356       iflog (fun _ -> annotate_quads (glue_str cx g));
1357       let code = { code_fixup = fix;
1358                    code_quads = emitted_quads e;
1359                    code_vregs_and_spill = Some (Il.num_vregs e, spill); }
1360       in
1361         htab_put cx.ctxt_glue_code g code
1362
1363   and trans_glue_frame_exit (fix:fixup) (spill:fixup) (g:glue) : unit =
1364     iflog (fun _ -> annotate "epilogue");
1365     abi.Abi.abi_emit_fn_epilogue (emitter());
1366     capture_emitted_glue fix spill g;
1367     pop_emitter ()
1368
1369   and emit_exit_task_glue (fix:fixup) (g:glue) : unit =
1370     let name = glue_str cx g in
1371     let spill = new_fixup (name ^ " spill") in
1372       push_new_emitter_with_vregs None;
1373       (* 
1374        * We return-to-here in a synthetic frame we did not build; our job is
1375        * merely to call upcall_exit.
1376        *)
1377       iflog (fun _ -> annotate "assume 'exited' state");
1378       trans_void_upcall "upcall_exit" [| |];
1379       capture_emitted_glue fix spill g;
1380       pop_emitter ()
1381
1382   and get_exit_task_glue _ : fixup =
1383     let g = GLUE_exit_task in
1384       match htab_search cx.ctxt_glue_code g with
1385           Some code -> code.code_fixup
1386         | None ->
1387             let fix = cx.ctxt_exit_task_fixup in
1388               emit_exit_task_glue fix g;
1389               fix
1390
1391   (*
1392    * Closure representation has 3 GEP-parts:
1393    * 
1394    *  ......
1395    *  . gc . gc control word, if mutable
1396    *  +----+
1397    *  | rc | refcount
1398    *  +----+
1399    * 
1400    *  +----+
1401    *  | tf | ----> pair of fn+binding that closure 
1402    *  +----+   /   targets
1403    *  | tb | --
1404    *  +----+
1405    * 
1406    *  +----+
1407    *  | b1 | bound arg1
1408    *  +----+
1409    *  .    .
1410    *  .    .
1411    *  .    .
1412    *  +----+
1413    *  | bN | bound argN
1414    *  +----+
1415    *)
1416
1417   and closure_referent_type
1418       (bs:Ast.slot array)
1419       (* FIXME (issue #5): mutability flag *)
1420       : Il.referent_ty =
1421     let rc = Il.ScalarTy word_sty in
1422     let targ = referent_type abi (mk_simple_ty_fn [||]) in
1423     let bindings = Array.map (slot_referent_type abi) bs in
1424       Il.StructTy [| rc; targ; Il.StructTy bindings |]
1425
1426   (* FIXME (issue #2): this should eventually use tail calling logic *)
1427
1428   and emit_fn_binding_glue
1429       (arg_slots:Ast.slot array)
1430       (arg_bound_flags:bool array)
1431       (fix:fixup)
1432       (g:glue)
1433       : unit =
1434     let extract_slots want_bound =
1435       arr_filter_some
1436         (arr_map2
1437            (fun slot bound ->
1438               if bound = want_bound then Some slot else None)
1439            arg_slots
1440            arg_bound_flags)
1441     in
1442     let bound_slots = extract_slots true in
1443     let unbound_slots = extract_slots false in
1444     let (self_ty:Ast.ty) = mk_simple_ty_fn unbound_slots in
1445     let (callee_ty:Ast.ty) = mk_simple_ty_fn arg_slots in
1446
1447     let self_closure_rty = closure_referent_type bound_slots in
1448     (* FIXME (issue #81): binding type parameters doesn't work. *)
1449     let self_args_rty =
1450       call_args_referent_type cx 0 self_ty (Some self_closure_rty)
1451     in
1452     let callee_args_rty =
1453       call_args_referent_type cx 0 callee_ty (Some Il.OpaqueTy)
1454     in
1455
1456     let callsz = Il.referent_ty_size word_bits callee_args_rty in
1457     let spill = new_fixup "bind glue spill" in
1458       trans_glue_frame_entry callsz spill;
1459
1460       let all_self_args_cell = caller_args_cell self_args_rty in
1461       let self_indirect_args_cell =
1462         get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
1463       in
1464       let closure_cell =
1465         deref (get_element_ptr self_indirect_args_cell
1466                  Abi.indirect_args_elt_closure)
1467       in
1468       let closure_target_cell =
1469         get_element_ptr closure_cell Abi.binding_field_binding
1470       in
1471       let closure_target_fn_cell =
1472         get_element_ptr closure_target_cell Abi.binding_field_item
1473       in
1474
1475         merge_bound_args
1476           self_args_rty callee_args_rty
1477           arg_slots arg_bound_flags;
1478         iflog (fun _ -> annotate "call through to closure target fn");
1479
1480         (* 
1481          * Closures, unlike first-class [disp,*binding] pairs, contain
1482          * a fully-resolved target pointer, not a displacement. So we
1483          * don't want to use callee_fn_ptr or the like to access the
1484          * contents. We just call through the cell directly.
1485          *)
1486
1487         call_code (code_of_cell closure_target_fn_cell);
1488         trans_glue_frame_exit fix spill g
1489
1490
1491   and get_fn_binding_glue
1492       (bind_id:node_id)
1493       (arg_slots:Ast.slot array)
1494       (arg_bound_flags:bool array)
1495       : fixup =
1496     let g = GLUE_fn_binding bind_id in
1497       match htab_search cx.ctxt_glue_code g with
1498           Some code -> code.code_fixup
1499         | None ->
1500             let fix = new_fixup (glue_str cx g) in
1501               emit_fn_binding_glue arg_slots arg_bound_flags fix g;
1502               fix
1503
1504
1505   (* 
1506    * Mem-glue functions are either 'mark', 'drop' or 'free', they take
1507    * one pointer arg and return nothing.
1508    *)
1509
1510   and trans_mem_glue_frame_entry (n_outgoing_args:int) (spill:fixup) : unit =
1511     let isz = cx.ctxt_abi.Abi.abi_implicit_args_sz in
1512     let callsz = SIZE_fixed (Int64.add isz (word_n n_outgoing_args)) in
1513       trans_glue_frame_entry callsz spill
1514
1515   and get_mem_glue (g:glue) (inner:Il.mem -> unit) : fixup =
1516     match htab_search cx.ctxt_glue_code g with
1517         Some code -> code.code_fixup
1518       | None ->
1519           begin
1520             let name = glue_str cx g in
1521             let fix = new_fixup name in
1522               (* 
1523                * Put a temporary code entry in the table to handle
1524                * recursive emit calls during the generation of the glue
1525                * function.
1526                *)
1527             let tmp_code = { code_fixup = fix;
1528                              code_quads = [| |];
1529                              code_vregs_and_spill = None; } in
1530             let spill = new_fixup (name ^ " spill") in
1531               htab_put cx.ctxt_glue_code g tmp_code;
1532               log cx "emitting glue: %s" name;
1533               trans_mem_glue_frame_entry Abi.worst_case_glue_call_args spill;
1534               let (arg:Il.mem) = fp_imm arg0_disp in
1535                 inner arg;
1536                 Hashtbl.remove cx.ctxt_glue_code g;
1537                 trans_glue_frame_exit fix spill g;
1538                 fix
1539           end
1540
1541   and get_typed_mem_glue
1542       (g:glue)
1543       (fty:Ast.ty)
1544       (inner:Il.cell -> Il.cell -> unit)
1545       : fixup =
1546       get_mem_glue g
1547         begin
1548           fun _ ->
1549             let n_ty_params = 0 in
1550             let calltup_rty =
1551               call_args_referent_type cx n_ty_params fty None
1552             in
1553             let calltup_cell = caller_args_cell calltup_rty in
1554             let out_cell =
1555               get_element_ptr calltup_cell Abi.calltup_elt_out_ptr
1556             in
1557             let args_cell =
1558               get_element_ptr calltup_cell Abi.calltup_elt_args
1559             in
1560               begin
1561                 match Il.cell_referent_ty args_cell with
1562                     Il.StructTy az ->
1563                       assert ((Array.length az)
1564                               <= Abi.worst_case_glue_call_args);
1565                   | _ -> bug () "unexpected cell referent ty in glue args"
1566               end;
1567               inner out_cell args_cell
1568         end
1569
1570   and trace_str b s =
1571     if b
1572     then
1573       begin
1574         let static = trans_static_string s in
1575           trans_void_upcall "upcall_trace_str" [| static |]
1576       end
1577
1578   and trace_word b w =
1579     if b
1580     then
1581       trans_void_upcall "upcall_trace_word" [| Il.Cell w |]
1582
1583   and ty_params_covering (t:Ast.ty) : Ast.slot =
1584     let n_ty_params = n_used_type_params t in
1585     let params = make_tydesc_tys n_ty_params in
1586       alias_slot (Ast.TY_tup params)
1587
1588   and get_drop_glue
1589       (ty:Ast.ty)
1590       (curr_iso:Ast.ty_iso option)
1591       : fixup =
1592     let g = GLUE_drop ty in
1593     let inner _ (args:Il.cell) =
1594       let ty_params = deref (get_element_ptr args 0) in
1595       let cell = get_element_ptr args 1 in
1596         note_drop_step ty "in drop-glue, dropping";
1597         trace_word cx.ctxt_sess.Session.sess_trace_drop cell;
1598         drop_ty ty_params (deref cell) ty curr_iso;
1599         note_drop_step ty "drop-glue complete";
1600     in
1601     let ty_params_ptr = ty_params_covering ty in
1602     let fty = mk_simple_ty_fn [| ty_params_ptr; alias_slot ty |] in
1603       get_typed_mem_glue g fty inner
1604
1605
1606   and get_free_glue
1607       (ty:Ast.ty)
1608       (is_gc:bool)
1609       (curr_iso:Ast.ty_iso option)
1610       : fixup =
1611     let g = GLUE_free ty in
1612     let inner _ (args:Il.cell) =
1613       (* Free-glue assumes it's called with a pointer to a box allocation with
1614        * normal box layout. It's just a way to move drop+free out of leaf
1615        * code.
1616        *)
1617       let ty_params = deref (get_element_ptr args 0) in
1618       let cell = get_element_ptr args 1 in
1619         free_ty is_gc ty_params ty cell curr_iso
1620     in
1621     let ty_params_ptr = ty_params_covering ty in
1622     let fty = mk_simple_ty_fn [| ty_params_ptr; local_slot ty |] in
1623       get_typed_mem_glue g fty inner
1624
1625
1626   and get_sever_glue
1627       (ty:Ast.ty)
1628       (curr_iso:Ast.ty_iso option)
1629       : fixup =
1630     let g = GLUE_sever ty in
1631     let inner _ (args:Il.cell) =
1632       let ty_params = deref (get_element_ptr args 0) in
1633       let cell = get_element_ptr args 1 in
1634         note_gc_step ty "in sever-glue, severing";
1635         sever_ty ty_params (deref cell) ty curr_iso;
1636         note_gc_step ty "in sever-glue complete";
1637     in
1638     let ty_params_ptr = ty_params_covering ty in
1639     let fty = mk_simple_ty_fn [| ty_params_ptr; alias_slot ty |] in
1640       get_typed_mem_glue g fty inner
1641
1642
1643   and get_mark_glue
1644       (ty:Ast.ty)
1645       (curr_iso:Ast.ty_iso option)
1646       : fixup =
1647     let g = GLUE_mark ty in
1648     let inner _ (args:Il.cell) =
1649       let ty_params = deref (get_element_ptr args 0) in
1650       let cell = get_element_ptr args 1 in
1651         note_gc_step ty "in mark-glue, marking";
1652         mark_ty ty_params (deref cell) ty curr_iso;
1653         note_gc_step ty "mark-glue complete";
1654     in
1655     let ty_params_ptr = ty_params_covering ty in
1656     let fty = mk_simple_ty_fn [| ty_params_ptr; alias_slot ty |] in
1657       get_typed_mem_glue g fty inner
1658
1659
1660   and get_clone_glue
1661       (ty:Ast.ty)
1662       (curr_iso:Ast.ty_iso option)
1663       : fixup =
1664     let g = GLUE_clone ty in
1665     let inner (out_ptr:Il.cell) (args:Il.cell) =
1666       let dst = deref out_ptr in
1667       let ty_params = deref (get_element_ptr args 0) in
1668       let src = deref (get_element_ptr args 1) in
1669       let clone_task = get_element_ptr args 2 in
1670         clone_ty ty_params clone_task dst src ty curr_iso
1671     in
1672     let ty_params_ptr = ty_params_covering ty in
1673     let fty =
1674       mk_ty_fn
1675         (local_slot ty)        (* dst *)
1676         [|
1677           ty_params_ptr;
1678           alias_slot ty;       (* src *)
1679           word_slot            (* clone-task *)
1680         |]
1681     in
1682       get_typed_mem_glue g fty inner
1683
1684
1685   and get_copy_glue
1686       (ty:Ast.ty)
1687       (curr_iso:Ast.ty_iso option)
1688       : fixup =
1689     let g = GLUE_copy ty in
1690     let inner (out_ptr:Il.cell) (args:Il.cell) =
1691       let dst = deref out_ptr in
1692       let ty_params = deref (get_element_ptr args 0) in
1693       let src = deref (get_element_ptr args 1) in
1694         trans_copy_ty ty_params false dst ty src ty curr_iso
1695     in
1696     let ty_params_ptr = ty_params_covering ty in
1697     let fty =
1698       mk_ty_fn
1699         (local_slot ty)
1700         [| ty_params_ptr; alias_slot ty |]
1701     in
1702       get_typed_mem_glue g fty inner
1703
1704
1705   (* Glue functions use mostly the same calling convention as ordinary
1706    * functions.
1707    * 
1708    * Each glue function expects its own particular arguments, which are
1709    * usually aliases-- ie, caller doesn't transfer ownership to the
1710    * glue. And nothing is represented in terms of AST nodes. So we
1711    * don't do lvals-and-atoms here.
1712    *)
1713
1714   and trans_call_glue
1715       (code:Il.code)
1716       (dst:Il.cell option)
1717       (args:Il.cell array)
1718       : unit =
1719     let inner dst =
1720       let scratch = next_vreg_cell Il.voidptr_t in
1721       let pop _ = emit (Il.Pop scratch) in
1722         for i = ((Array.length args) - 1) downto 0
1723         do
1724           emit (Il.Push (Il.Cell args.(i)))
1725         done;
1726         emit (Il.Push (Il.Cell abi.Abi.abi_tp_cell));
1727         emit (Il.Push dst);
1728         call_code code;
1729         pop ();
1730         pop ();
1731         Array.iter (fun _ -> pop()) args;
1732     in
1733       match dst with
1734           None -> inner zero
1735         | Some dst -> aliasing true dst (fun dst -> inner (Il.Cell dst))
1736
1737   and trans_call_static_glue
1738       (callee:Il.operand)
1739       (dst:Il.cell option)
1740       (args:Il.cell array)
1741       : unit =
1742     trans_call_glue (code_of_operand callee) dst args
1743
1744   and trans_call_dynamic_glue
1745       (tydesc:Il.cell)
1746       (idx:int)
1747       (dst:Il.cell option)
1748       (args:Il.cell array)
1749       : unit =
1750     let fptr = get_vtbl_entry_idx tydesc idx in
1751       trans_call_glue (code_of_operand (Il.Cell fptr)) dst args
1752
1753   and trans_call_simple_static_glue
1754       (fix:fixup)
1755       (ty_params:Il.cell)
1756       (arg:Il.cell)
1757       : unit =
1758     trans_call_static_glue
1759       (code_fixup_to_ptr_operand fix)
1760       None [| alias ty_params; arg |]
1761
1762   and get_tydesc_params
1763       (outer_ty_params:Il.cell)
1764       (td:Il.cell)
1765       : Il.cell =
1766     let first_param =
1767       get_element_ptr (deref td) Abi.tydesc_field_first_param
1768     in
1769     let res = next_vreg_cell Il.voidptr_t in
1770       mov res (Il.Cell (alias outer_ty_params));
1771       emit (Il.cmp (Il.Cell first_param) zero);
1772       let no_param_jmp = mark() in
1773         emit (Il.jmp Il.JE Il.CodeNone);
1774         mov res (Il.Cell first_param);
1775         patch no_param_jmp;
1776         res
1777
1778   and trans_call_simple_dynamic_glue
1779       (ty_param:int)
1780       (vtbl_idx:int)
1781       (ty_params:Il.cell)
1782       (arg:Il.cell)
1783       : unit =
1784     iflog (fun _ ->
1785              annotate (Printf.sprintf "calling tydesc[%d].glue[%d]"
1786                          ty_param vtbl_idx));
1787     let td = get_ty_param ty_params ty_param in
1788     let ty_params_ptr = get_tydesc_params ty_params td in
1789       trans_call_dynamic_glue
1790         td vtbl_idx
1791         None [| ty_params_ptr; arg; |]
1792
1793   (* trans_compare returns a quad number of the cjmp, which the caller
1794      patches to the cjmp destination.  *)
1795   and trans_compare
1796       (cjmp:Il.jmpop)
1797       (lhs:Il.operand)
1798       (rhs:Il.operand)
1799       : quad_idx list =
1800     (* FIXME: this is an x86-ism; abstract via ABI. *)
1801     emit (Il.cmp (Il.Cell (Il.Reg (force_to_reg lhs))) rhs);
1802     let jmp = mark() in
1803       emit (Il.jmp cjmp Il.CodeNone);
1804       [jmp]
1805
1806   and trans_cond (invert:bool) (expr:Ast.expr) : quad_idx list =
1807
1808     let anno _ =
1809       iflog
1810         begin
1811           fun _ ->
1812             annotate ((Fmt.fmt_to_str Ast.fmt_expr expr) ^
1813                         ": cond, finale")
1814         end
1815     in
1816
1817     match expr with
1818         Ast.EXPR_binary (binop, a, b) ->
1819           let lhs = trans_atom a in
1820           let rhs = trans_atom b in
1821           let cjmp = binop_to_jmpop binop in
1822           let cjmp' =
1823             if invert then
1824               match cjmp with
1825                   Il.JE -> Il.JNE
1826                 | Il.JNE -> Il.JE
1827                 | Il.JL -> Il.JGE
1828                 | Il.JLE -> Il.JG
1829                 | Il.JGE -> Il.JL
1830                 | Il.JG -> Il.JLE
1831                 | _ -> bug () "Unhandled inverse binop in trans_cond"
1832             else
1833               cjmp
1834           in
1835             anno ();
1836             trans_compare cjmp' lhs rhs
1837
1838       | _ ->
1839           let bool_operand = trans_expr expr in
1840             anno ();
1841             trans_compare Il.JNE bool_operand
1842               (if invert then imm_true else imm_false)
1843
1844   and trans_binop (binop:Ast.binop) : Il.binop =
1845     match binop with
1846         Ast.BINOP_or -> Il.OR
1847       | Ast.BINOP_and -> Il.AND
1848       | Ast.BINOP_xor -> Il.XOR
1849
1850       | Ast.BINOP_lsl -> Il.LSL
1851       | Ast.BINOP_lsr -> Il.LSR
1852       | Ast.BINOP_asr -> Il.ASR
1853
1854       | Ast.BINOP_add -> Il.ADD
1855       | Ast.BINOP_sub -> Il.SUB
1856
1857       (* FIXME (issue #57):
1858        * switch on type of operands, IMUL/IDIV/IMOD etc.
1859        *)
1860       | Ast.BINOP_mul -> Il.UMUL
1861       | Ast.BINOP_div -> Il.UDIV
1862       | Ast.BINOP_mod -> Il.UMOD
1863       | _ -> bug () "bad binop to Trans.trans_binop"
1864
1865   and trans_binary
1866       (binop:Ast.binop)
1867       (lhs:Il.operand)
1868       (rhs:Il.operand) : Il.operand =
1869     let arith op =
1870       let bits = Il.operand_bits word_bits lhs in
1871       let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy bits) in
1872         emit (Il.binary op dst lhs rhs);
1873         Il.Cell dst
1874     in
1875     match binop with
1876         Ast.BINOP_or | Ast.BINOP_and | Ast.BINOP_xor
1877       | Ast.BINOP_lsl | Ast.BINOP_lsr | Ast.BINOP_asr
1878       | Ast.BINOP_add | Ast.BINOP_sub
1879       (* FIXME (issue #57):
1880        * switch on type of operands, IMUL/IDIV/IMOD etc.
1881        *)
1882       | Ast.BINOP_mul | Ast.BINOP_div | Ast.BINOP_mod ->
1883           arith (trans_binop binop)
1884
1885       | _ -> let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy Il.Bits8) in
1886           mov dst imm_true;
1887           let jmps = trans_compare (binop_to_jmpop binop) lhs rhs in
1888             mov dst imm_false;
1889             List.iter patch jmps;
1890             Il.Cell dst
1891
1892
1893   and trans_expr (expr:Ast.expr) : Il.operand =
1894
1895     let anno _ =
1896       iflog
1897         begin
1898           fun _ ->
1899             annotate ((Fmt.fmt_to_str Ast.fmt_expr expr) ^
1900                         ": plain exit, finale")
1901         end
1902     in
1903       match expr with
1904           Ast.EXPR_binary (binop, a, b) ->
1905             assert (is_prim_type (simplified_ty (atom_type cx a)));
1906             assert (is_prim_type (simplified_ty (atom_type cx b)));
1907             trans_binary binop (trans_atom a) (trans_atom b)
1908
1909         | Ast.EXPR_unary (unop, a) ->
1910             assert (is_prim_type (simplified_ty (atom_type cx a)));
1911             let src = trans_atom a in
1912             let bits = Il.operand_bits word_bits src in
1913             let dst = Il.Reg (Il.next_vreg (emitter()), Il.ValTy bits) in
1914             let op = match unop with
1915                 Ast.UNOP_not
1916               | Ast.UNOP_bitnot -> Il.NOT
1917               | Ast.UNOP_neg -> Il.NEG
1918               | Ast.UNOP_cast t ->
1919                   let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
1920                   let at = atom_type cx a in
1921                   let (t, at) = (simplified_ty t, simplified_ty at) in
1922                     if (type_is_2s_complement at) &&
1923                       (type_is_2s_complement t)
1924                     then
1925                       if type_is_unsigned_2s_complement t
1926                       then Il.UMOV
1927                       else Il.IMOV
1928                     else
1929                       err None "unsupported cast operator"
1930             in
1931               anno ();
1932               emit (Il.unary op dst src);
1933               Il.Cell dst
1934
1935         | Ast.EXPR_atom a ->
1936             trans_atom a
1937
1938   and trans_block (block:Ast.block) : unit =
1939     trace_str cx.ctxt_sess.Session.sess_trace_block
1940       "entering block";
1941     push_emitter_size_cache ();
1942     emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups block.id));
1943     Array.iter trans_stmt block.node;
1944     trace_str cx.ctxt_sess.Session.sess_trace_block
1945       "exiting block";
1946     emit Il.Leave;
1947     pop_emitter_size_cache ();
1948     trace_str cx.ctxt_sess.Session.sess_trace_block
1949       "exited block";
1950
1951   and upcall_fixup (name:string) : fixup =
1952     Semant.require_native cx REQUIRED_LIB_rustrt name;
1953
1954   and trans_upcall
1955       (name:string)
1956       (ret:Il.cell)
1957       (args:Il.operand array)
1958       : unit =
1959     abi.Abi.abi_emit_native_call (emitter())
1960       ret nabi_rust (upcall_fixup name) args;
1961
1962   and trans_void_upcall
1963       (name:string)
1964       (args:Il.operand array)
1965       : unit =
1966     abi.Abi.abi_emit_native_void_call (emitter())
1967       nabi_rust (upcall_fixup name) args;
1968
1969   and trans_log_int (a:Ast.atom) : unit =
1970     trans_void_upcall "upcall_log_int" [| (trans_atom a) |]
1971
1972   and trans_log_str (a:Ast.atom) : unit =
1973     trans_void_upcall "upcall_log_str" [| (trans_atom a) |]
1974
1975   and trans_spawn
1976       ((*initializing*)_:bool)
1977       (dst:Ast.lval)
1978       (domain:Ast.domain)
1979       (fn_lval:Ast.lval)
1980       (args:Ast.atom array)
1981       : unit =
1982     let (task_cell, _) = trans_lval_init dst in
1983     let (fptr_operand, fn_ty) = trans_callee fn_lval in
1984     (*let fn_ty_params = [| |] in*)
1985     let _ =
1986       (* FIXME (issue #82): handle indirect-spawns (clone closure). *)
1987       if not (lval_is_direct_fn cx fn_lval)
1988       then bug () "unhandled indirect-spawn"
1989     in
1990     let args_rty = call_args_referent_type cx 0 fn_ty None in
1991     let fptr_operand = reify_ptr fptr_operand in
1992     let exit_task_glue_fixup = get_exit_task_glue () in
1993     let callsz =
1994       calculate_sz_in_current_frame (Il.referent_ty_size word_bits args_rty)
1995     in
1996     let exit_task_glue_fptr =
1997       code_fixup_to_ptr_operand exit_task_glue_fixup
1998     in
1999     let exit_task_glue_fptr = reify_ptr exit_task_glue_fptr in
2000
2001       iflog (fun _ -> annotate "spawn task: copy args");
2002
2003       let new_task = next_vreg_cell Il.voidptr_t in
2004       let call = { call_ctrl = CALL_indirect;
2005                    call_callee_ptr = fptr_operand;
2006                    call_callee_ty = fn_ty;
2007                    call_callee_ty_params = [| |];
2008                    call_output = task_cell;
2009                    call_args = args;
2010                    call_iterator_args = [| |];
2011                    call_indirect_args = [| |] }
2012       in
2013         match domain with
2014             Ast.DOMAIN_thread ->
2015               begin
2016                 trans_upcall "upcall_new_thread" new_task [| |];
2017                 copy_fn_args false true (CLONE_all new_task) call;
2018                 trans_upcall "upcall_start_thread" task_cell
2019                   [|
2020                     Il.Cell new_task;
2021                     exit_task_glue_fptr;
2022                     fptr_operand;
2023                     callsz
2024                   |];
2025             end
2026          | _ ->
2027              begin
2028                  trans_upcall "upcall_new_task" new_task [| |];
2029                  copy_fn_args false true (CLONE_chan new_task) call;
2030                  trans_upcall "upcall_start_task" task_cell
2031                    [|
2032                      Il.Cell new_task;
2033                      exit_task_glue_fptr;
2034                      fptr_operand;
2035                      callsz
2036                    |];
2037              end;
2038       ()
2039
2040   and get_curr_span _ =
2041       if Stack.is_empty curr_stmt
2042       then ("<none>", 0, 0)
2043       else
2044         let stmt_id = Stack.top curr_stmt in
2045           match (Session.get_span cx.ctxt_sess stmt_id) with
2046               None -> ("<none>", 0, 0)
2047             | Some sp -> sp.lo
2048
2049   and trans_cond_fail (str:string) (fwd_jmps:quad_idx list) : unit =
2050     let (filename, line, _) = get_curr_span () in
2051       iflog (fun _ -> annotate ("condition-fail: " ^ str));
2052       trans_void_upcall "upcall_fail"
2053         [|
2054           trans_static_string str;
2055           trans_static_string filename;
2056           imm (Int64.of_int line)
2057         |];
2058       List.iter patch fwd_jmps
2059
2060   and trans_check_expr (id:node_id) (e:Ast.expr) : unit =
2061     match simplified_ty (expr_type cx e) with
2062         Ast.TY_bool ->
2063           let fwd_jmps = trans_cond false e in
2064             trans_cond_fail (Fmt.fmt_to_str Ast.fmt_expr e) fwd_jmps
2065       | _ -> bugi cx id "check expr on non-bool"
2066
2067   and trans_malloc
2068       (dst:Il.cell)
2069       (nbytes:Il.operand)
2070       (gc_ctrl_word:Il.operand)
2071       : unit =
2072     trans_upcall "upcall_malloc" dst [| nbytes; gc_ctrl_word |]
2073
2074   and trans_free (src:Il.cell) (is_gc:bool) : unit =
2075     let is_gc = if is_gc then 1L else 0L in
2076       trans_void_upcall "upcall_free" [| Il.Cell src; imm is_gc |]
2077
2078   and trans_yield () : unit =
2079     trans_void_upcall "upcall_yield" [| |];
2080
2081   and trans_fail () : unit =
2082     let (filename, line, _) = get_curr_span () in
2083       trans_void_upcall "upcall_fail"
2084         [|
2085           trans_static_string "explicit failure";
2086           trans_static_string filename;
2087           imm (Int64.of_int line)
2088         |];
2089
2090   and trans_join (task:Ast.lval) : unit =
2091     trans_void_upcall "upcall_join" [| trans_atom (Ast.ATOM_lval task) |]
2092
2093   and trans_send (chan:Ast.lval) (src:Ast.lval) : unit =
2094     let (srccell, _) = trans_lval src in
2095       aliasing false srccell
2096         begin
2097           fun src_alias ->
2098             trans_void_upcall "upcall_send"
2099               [| trans_atom (Ast.ATOM_lval chan);
2100                  Il.Cell src_alias |];
2101         end
2102
2103   and trans_recv (initializing:bool) (dst:Ast.lval) (chan:Ast.lval) : unit =
2104     let (dstcell, _) = trans_lval_maybe_init initializing dst in
2105       aliasing true dstcell
2106         begin
2107           fun dst_alias ->
2108             trans_void_upcall "upcall_recv"
2109               [| Il.Cell dst_alias;
2110                  trans_atom (Ast.ATOM_lval chan) |];
2111         end
2112
2113   and trans_init_port (dst:Ast.lval) : unit =
2114     let (dstcell, dst_ty) = trans_lval_init dst in
2115     let unit_ty = match dst_ty with
2116         Ast.TY_port t -> t
2117       | _ -> bug () "init dst of port-init has non-port type"
2118     in
2119     let unit_sz = ty_sz abi unit_ty in
2120       trans_upcall "upcall_new_port" dstcell [| imm unit_sz |]
2121
2122   and trans_del_port (port:Il.cell) : unit =
2123     trans_void_upcall "upcall_del_port" [| Il.Cell port |]
2124
2125   and trans_init_chan (dst:Ast.lval) (port:Ast.lval) : unit =
2126     let (dstcell, _) = trans_lval_init dst
2127     in
2128       trans_upcall "upcall_new_chan" dstcell
2129         [| trans_atom (Ast.ATOM_lval port) |]
2130
2131   and trans_del_chan (chan:Il.cell) : unit =
2132     trans_void_upcall "upcall_del_chan" [| Il.Cell chan |]
2133
2134   and trans_kill_task (task:Il.cell) : unit =
2135     trans_void_upcall "upcall_kill" [| Il.Cell task |]
2136
2137   (*
2138    * A vec is implicitly boxed: every slot vec[T] is 1 word and
2139    * points to a refcounted structure. That structure has 3 words with
2140    * defined meaning at the beginning; data follows the header.
2141    *
2142    *   word 0: refcount or gc control word
2143    *   word 1: allocated size of data
2144    *   word 2: initialised size of data
2145    *   word 3...N: data
2146    * 
2147    * This 3-word prefix is shared with strings, we factor the common
2148    * part out for reuse in string code.
2149    *)
2150
2151   and trans_init_vec (dst:Ast.lval) (atoms:Ast.atom array) : unit =
2152     let (dst_cell, dst_ty) = trans_lval_init dst in
2153     let gc_ctrl =
2154       if (ty_mem_ctrl dst_ty) = MEM_gc
2155       then Il.Cell (get_tydesc None dst_ty)
2156       else zero
2157     in
2158     let unit_ty = match dst_ty with
2159         Ast.TY_vec t -> t
2160       | _ -> bug () "init dst of vec-init has non-vec type"
2161     in
2162     let fill = next_vreg_cell word_sty in
2163     let unit_sz = ty_sz_in_current_frame unit_ty in
2164       umul fill unit_sz (imm (Int64.of_int (Array.length atoms)));
2165       trans_upcall "upcall_new_vec" dst_cell [| Il.Cell fill; gc_ctrl |];
2166       let vec = deref dst_cell in
2167         let body_mem =
2168           fst (need_mem_cell
2169                  (get_element_ptr_dyn_in_current_frame
2170                     vec Abi.vec_elt_data))
2171         in
2172         let unit_rty = referent_type abi unit_ty in
2173         let body_rty = Il.StructTy (Array.map (fun _ -> unit_rty) atoms) in
2174         let body = Il.Mem (body_mem, body_rty) in
2175           Array.iteri
2176             begin
2177               fun i atom ->
2178                 let cell = get_element_ptr_dyn_in_current_frame body i in
2179                   trans_init_ty_from_atom cell unit_ty atom
2180             end
2181             atoms;
2182             mov (get_element_ptr vec Abi.vec_elt_fill) (Il.Cell fill);
2183
2184
2185   and trans_init_box (dst:Ast.lval) (src:Ast.atom) : unit =
2186     let src_op = trans_atom src in
2187     let src_cell = Il.Mem (force_to_mem src_op) in
2188     let src_ty = simplified_ty (atom_type cx src) in
2189     let dst_sloti = lval_base_to_slot cx dst in
2190     let dst_cell = cell_of_block_slot dst_sloti.id in
2191     let dst_cell = deref_slot true dst_cell dst_sloti.node in
2192     let dst_ty = slot_ty dst_sloti.node in
2193     let (dst_cell, dst_ty) =
2194       deref_ty DEREF_one_box true dst_cell dst_ty
2195     in
2196     let _ = assert (dst_ty = src_ty) in
2197       trans_copy_ty (get_ty_params_of_current_frame()) true
2198         dst_cell dst_ty src_cell src_ty None
2199
2200
2201   and get_dynamic_tydesc (idopt:node_id option) (t:Ast.ty) : Il.cell =
2202     let td = next_vreg_cell Il.voidptr_t in
2203     let root_desc =
2204       Il.Cell (crate_rel_to_ptr
2205                  (get_static_tydesc idopt t 0L 0L)
2206                  (tydesc_rty abi))
2207     in
2208     let (t, param_descs) = linearize_ty_params t in
2209     let descs = Array.append [| root_desc |] param_descs in
2210     let n = Array.length descs in
2211     let rty = referent_type abi t in
2212     let (size_sz, align_sz) = Il.referent_ty_layout word_bits rty in
2213     let size = calculate_sz_in_current_frame size_sz in
2214     let align = calculate_sz_in_current_frame align_sz in
2215     let descs_ptr = next_vreg_cell Il.voidptr_t in
2216       if (Array.length descs) > 0
2217       then
2218         (* FIXME (issue #83): this relies on knowledge that spills are
2219          * contiguous.
2220          *)
2221         let spills =
2222           Array.map (fun _ -> next_spill_cell Il.voidptr_t) descs
2223         in
2224           Array.iteri (fun i t -> mov spills.(n-(i+1)) t) descs;
2225           lea descs_ptr (fst (need_mem_cell spills.(n-1)))
2226       else
2227         mov descs_ptr zero;
2228       trans_upcall "upcall_get_type_desc" td
2229         [| Il.Cell (curr_crate_ptr());
2230            size; align; imm (Int64.of_int n);
2231            Il.Cell descs_ptr |];
2232       td
2233
2234   and get_tydesc (idopt:node_id option) (ty:Ast.ty) : Il.cell =
2235     log cx "getting tydesc for %a" Ast.sprintf_ty ty;
2236     match simplified_ty ty with
2237         Ast.TY_param (idx, _) ->
2238           (get_ty_param_in_current_frame idx)
2239       | t when has_parametric_types t ->
2240           (get_dynamic_tydesc idopt t)
2241       | _ ->
2242           (crate_rel_to_ptr (get_static_tydesc idopt ty
2243                                (ty_sz abi ty)
2244                                (ty_align abi ty))
2245              (tydesc_rty abi))
2246
2247   and box_rc_cell (cell:Il.cell) : Il.cell =
2248     get_element_ptr (deref cell) Abi.box_rc_slot_field_refcnt
2249
2250   and box_allocation_size
2251       (ty:Ast.ty)
2252       : Il.operand =
2253     let header_sz =
2254       match ty_mem_ctrl ty with
2255           MEM_gc
2256         | MEM_rc_opaque
2257         | MEM_rc_struct -> word_n Abi.box_rc_header_size
2258         | MEM_interior -> bug () "box_allocation_size of MEM_interior"
2259     in
2260     let ty = simplified_ty ty in
2261     let refty_sz =
2262       Il.referent_ty_size abi.Abi.abi_word_bits (referent_type abi ty)
2263     in
2264       match refty_sz with
2265           SIZE_fixed _ -> imm (Int64.add (ty_sz abi ty) header_sz)
2266         | _ ->
2267             let ty_params = get_ty_params_of_current_frame() in
2268             let refty_sz = calculate_sz ty_params refty_sz in
2269             let v = next_vreg word_sty in
2270             let vc = Il.Reg (v, word_sty) in
2271               mov vc refty_sz;
2272               add_to vc (imm header_sz);
2273               Il.Cell vc;
2274
2275   and iter_tag_parts
2276       (ty_params:Il.cell)
2277       (dst_cell:Il.cell)
2278       (src_cell:Il.cell)
2279       (ttag:Ast.ty_tag)
2280       (f:Il.cell -> Il.cell -> Ast.ty -> (Ast.ty_iso option) -> unit)
2281       (curr_iso:Ast.ty_iso option)
2282       : unit =
2283     let tag_keys = sorted_htab_keys ttag in
2284     let src_tag = get_element_ptr src_cell 0 in
2285     let dst_tag = get_element_ptr dst_cell 0 in
2286     let src_union = get_element_ptr_dyn ty_params src_cell 1 in
2287     let dst_union = get_element_ptr_dyn ty_params dst_cell 1 in
2288     let tmp = next_vreg_cell word_sty in
2289       f dst_tag src_tag word_ty curr_iso;
2290       mov tmp (Il.Cell src_tag);
2291       Array.iteri
2292         begin
2293           fun i key ->
2294             (iflog (fun _ ->
2295                       annotate (Printf.sprintf "tag case #%i == %a" i
2296                                   Ast.sprintf_name key)));
2297             let jmps =
2298               trans_compare Il.JNE (Il.Cell tmp) (imm (Int64.of_int i))
2299             in
2300             let ttup = Hashtbl.find ttag key in
2301               iter_tup_parts
2302                 (get_element_ptr_dyn ty_params)
2303                 (get_variant_ptr dst_union i)
2304                 (get_variant_ptr src_union i)
2305                 ttup f curr_iso;
2306               List.iter patch jmps
2307         end
2308         tag_keys
2309
2310   and get_iso_tag tiso =
2311     tiso.Ast.iso_group.(tiso.Ast.iso_index)
2312
2313
2314   and seq_unit_ty (seq:Ast.ty) : Ast.ty =
2315     match simplified_ty seq with
2316         Ast.TY_vec t -> t
2317       | Ast.TY_str -> Ast.TY_mach TY_u8
2318       | _ -> bug () "seq_unit_ty of non-vec, non-str type"
2319
2320
2321   and iter_seq_parts
2322       (ty_params:Il.cell)
2323       (dst_cell:Il.cell)
2324       (src_cell:Il.cell)
2325       (unit_ty:Ast.ty)
2326       (f:Il.cell -> Il.cell -> Ast.ty -> (Ast.ty_iso option) -> unit)
2327       (curr_iso:Ast.ty_iso option)
2328       : unit =
2329     let unit_sz = ty_sz_with_ty_params ty_params unit_ty in
2330       (* 
2331        * Unlike most of the iter_ty_parts helpers; this one allocates a
2332        * vreg and so has to be aware of when it's iterating over 2
2333        * sequences of cells or just 1.
2334        *)
2335       check_box_rty src_cell;
2336       check_box_rty dst_cell;
2337       if dst_cell = src_cell
2338       then
2339         begin
2340           let src_cell = deref src_cell in
2341           let data =
2342             get_element_ptr_dyn ty_params src_cell Abi.vec_elt_data
2343           in
2344           let len = get_element_ptr src_cell Abi.vec_elt_fill in
2345           let ptr = next_vreg_cell Il.voidptr_t in
2346           let lim = next_vreg_cell Il.voidptr_t in
2347             lea lim (fst (need_mem_cell data));
2348             mov ptr (Il.Cell lim);
2349             add_to lim (Il.Cell len);
2350             let back_jmp_target = mark () in
2351             let fwd_jmps = trans_compare Il.JAE (Il.Cell ptr) (Il.Cell lim) in
2352             let unit_cell =
2353               deref (ptr_cast ptr (referent_type abi unit_ty))
2354             in
2355               f unit_cell unit_cell unit_ty curr_iso;
2356               add_to ptr unit_sz;
2357               check_interrupt_flag ();
2358               emit (Il.jmp Il.JMP (Il.CodeLabel back_jmp_target));
2359               List.iter patch fwd_jmps;
2360         end
2361       else
2362         begin
2363           bug () "Unsupported form of seq iter: src != dst."
2364         end
2365
2366
2367   and iter_ty_parts_full
2368       (ty_params:Il.cell)
2369       (dst_cell:Il.cell)
2370       (src_cell:Il.cell)
2371       (ty:Ast.ty)
2372       (f:Il.cell -> Il.cell -> Ast.ty -> (Ast.ty_iso option) -> unit)
2373       (curr_iso:Ast.ty_iso option)
2374       : unit =
2375     (* 
2376      * FIXME: this will require some reworking if we support
2377      * rec, tag or tup slots that fit in a vreg. It requires 
2378      * addrs presently.
2379      *)
2380     match strip_mutable_or_constrained_ty ty with
2381         Ast.TY_rec entries ->
2382           iter_rec_parts
2383             (get_element_ptr_dyn ty_params) dst_cell src_cell
2384             entries f curr_iso
2385
2386       | Ast.TY_tup tys ->
2387           iter_tup_parts
2388             (get_element_ptr_dyn ty_params) dst_cell src_cell
2389             tys f curr_iso
2390
2391       | Ast.TY_tag tag ->
2392           iter_tag_parts ty_params dst_cell src_cell tag f curr_iso
2393
2394       | Ast.TY_iso tiso ->
2395           let ttag = get_iso_tag tiso in
2396             iter_tag_parts ty_params dst_cell src_cell ttag f (Some tiso)
2397
2398       | Ast.TY_fn _
2399       | Ast.TY_obj _ -> bug () "Attempting to iterate over fn/pred/obj slots"
2400
2401       | Ast.TY_vec _
2402       | Ast.TY_str ->
2403           let unit_ty = seq_unit_ty ty in
2404             iter_seq_parts ty_params dst_cell src_cell unit_ty f curr_iso
2405
2406       | _ -> ()
2407
2408   (* 
2409    * This just calls iter_ty_parts_full with your cell as both src and
2410    * dst, with an adaptor function that discards the dst parts of the
2411    * parallel traversal and and calls your provided function on the
2412    * passed-in src parts.
2413    *)
2414   and iter_ty_parts
2415       (ty_params:Il.cell)
2416       (cell:Il.cell)
2417       (ty:Ast.ty)
2418       (f:Il.cell -> Ast.ty -> (Ast.ty_iso option) -> unit)
2419       (curr_iso:Ast.ty_iso option)
2420       : unit =
2421     iter_ty_parts_full ty_params cell cell ty
2422       (fun _ src_cell ty curr_iso -> f src_cell ty curr_iso)
2423       curr_iso
2424
2425   and drop_ty
2426       (ty_params:Il.cell)
2427       (cell:Il.cell)
2428       (ty:Ast.ty)
2429       (curr_iso:Ast.ty_iso option)
2430       : unit =
2431
2432     let ty = strip_mutable_or_constrained_ty ty in
2433     let ty = maybe_iso curr_iso ty in
2434     let curr_iso = maybe_enter_iso ty curr_iso in
2435     let mctrl = ty_mem_ctrl ty in
2436
2437       match ty with
2438
2439           Ast.TY_fn _ ->
2440             note_drop_step ty "drop_ty: fn path";
2441             let binding = get_element_ptr cell Abi.binding_field_binding in
2442             let null_jmp = null_check binding in
2443               (* Drop non-null bindings. *)
2444               (* FIXME (issue #58): this is completely wrong, Closures need to
2445                * carry tydescs like objs. For now this only works by accident,
2446                * and will leak closures with box substructure.
2447                *)
2448               drop_ty ty_params binding (Ast.TY_box Ast.TY_int) curr_iso;
2449               patch null_jmp;
2450               note_drop_step ty "drop_ty: done fn path";
2451
2452         | Ast.TY_obj _ ->
2453             note_drop_step ty "drop_ty: obj path";
2454             let binding = get_element_ptr cell Abi.binding_field_binding in
2455             let null_jmp = null_check binding in
2456             let obj = deref binding in
2457             let rc = get_element_ptr obj 0 in
2458             let rc_jmp = drop_refcount_and_cmp rc in
2459             let tydesc = get_element_ptr obj 1 in
2460             let body = get_element_ptr obj 2 in
2461             let ty_params =
2462               get_element_ptr (deref tydesc) Abi.tydesc_field_first_param
2463             in
2464             let dtor =
2465               get_element_ptr (deref tydesc) Abi.tydesc_field_obj_drop_glue
2466             in
2467             let null_dtor_jmp = null_check dtor in
2468               (* Call any dtor, if present. *)
2469             note_drop_step ty "drop_ty: calling obj dtor";
2470             trans_call_dynamic_glue tydesc
2471               Abi.tydesc_field_obj_drop_glue None [| binding |];
2472             patch null_dtor_jmp;
2473             (* Drop the body. *)
2474             note_drop_step ty "drop_ty: dropping obj body";
2475             trans_call_dynamic_glue tydesc
2476               Abi.tydesc_field_drop_glue None [| ty_params; alias body |];
2477             (* FIXME: this will fail if the user has lied about the
2478              * state-ness of their obj. We need to store state-ness in the
2479              * captured tydesc, and use that.  *)
2480             note_drop_step ty "drop_ty: freeing obj body";
2481             trans_free binding (type_has_state ty);
2482             mov binding zero;
2483             patch rc_jmp;
2484             patch null_jmp;
2485             note_drop_step ty "drop_ty: done obj path";
2486
2487
2488       | Ast.TY_param (i, _) ->
2489           note_drop_step ty "drop_ty: parametric-ty path";
2490           aliasing false cell
2491             begin
2492               fun cell ->
2493                 trans_call_simple_dynamic_glue
2494                   i Abi.tydesc_field_drop_glue ty_params cell
2495             end;
2496           note_drop_step ty "drop_ty: done parametric-ty path";
2497
2498       | _ ->
2499           match mctrl with
2500               MEM_gc
2501             | MEM_rc_opaque
2502             | MEM_rc_struct ->
2503
2504                 note_drop_step ty "drop_ty: box-drop path";
2505
2506                 let _ = check_box_rty cell in
2507                 let null_jmp = null_check cell in
2508                 let rc = box_rc_cell cell in
2509                 let j = drop_refcount_and_cmp rc in
2510
2511                   (* FIXME (issue #25): check to see that the box has
2512                    * further box members; if it doesn't we can elide the
2513                    * call to the glue function.  *)
2514
2515                   trans_call_simple_static_glue
2516                     (get_free_glue ty (mctrl = MEM_gc) curr_iso)
2517                     ty_params cell;
2518
2519                   (* Null the slot out to prevent double-free if the frame
2520                    * unwinds.
2521                    *)
2522                   mov cell zero;
2523                   patch j;
2524                   patch null_jmp;
2525                   note_drop_step ty "drop_ty: done box-drop path";
2526
2527             | MEM_interior when type_is_structured ty ->
2528                 note_drop_step ty "drop:ty structured-interior path";
2529                 iter_ty_parts ty_params cell ty
2530                   (drop_ty ty_params) curr_iso;
2531                 note_drop_step ty "drop_ty: done structured-interior path";
2532
2533
2534             | MEM_interior ->
2535                 note_drop_step ty "drop_ty: no-op simple-interior path";
2536                 (* Interior allocation of all-interior value not caught above:
2537                  * nothing to do.
2538                  *)
2539                 ()
2540
2541   and sever_ty
2542       (ty_params:Il.cell)
2543       (cell:Il.cell)
2544       (ty:Ast.ty)
2545       (curr_iso:Ast.ty_iso option)
2546       : unit =
2547     let _ = note_gc_step ty "severing" in
2548     let sever_box c =
2549       let _ = check_box_rty c in
2550       let null_jmp = null_check c in
2551       let rc = box_rc_cell c in
2552       let _ = note_gc_step ty "severing GC cell" in
2553         emit (Il.binary Il.SUB rc (Il.Cell rc) one);
2554         mov c zero;
2555         patch null_jmp
2556     in
2557     let ty = strip_mutable_or_constrained_ty ty in
2558
2559       match ty with
2560           Ast.TY_fn _
2561         | Ast.TY_obj _ ->
2562             if type_has_state ty
2563             then
2564               let binding = get_element_ptr cell Abi.binding_field_binding in
2565                 sever_box binding;
2566
2567         | _ ->
2568             match ty_mem_ctrl ty with
2569                 MEM_gc ->
2570                   sever_box cell
2571
2572               | MEM_interior when type_is_structured ty ->
2573                   iter_ty_parts ty_params cell ty
2574                     (sever_ty ty_params) curr_iso
2575
2576               | _ -> ()
2577                   (* No need to follow links / call glue; severing is
2578                      shallow. *)
2579
2580   and clone_ty
2581       (ty_params:Il.cell)
2582       (clone_task:Il.cell)
2583       (dst:Il.cell)
2584       (src:Il.cell)
2585       (ty:Ast.ty)
2586       (curr_iso:Ast.ty_iso option)
2587       : unit =
2588     let ty = strip_mutable_or_constrained_ty ty in
2589       match ty with
2590           Ast.TY_chan _ ->
2591             trans_upcall "upcall_clone_chan" dst
2592               [| (Il.Cell clone_task); (Il.Cell src) |]
2593         | Ast.TY_task
2594         | Ast.TY_port _
2595         | _ when type_has_state ty
2596             -> bug () "cloning state type"
2597         | _ when i64_le (ty_sz abi ty) word_sz
2598             -> mov dst (Il.Cell src)
2599         | Ast.TY_fn _
2600         | Ast.TY_obj _ -> ()
2601         | Ast.TY_box ty ->
2602             let glue_fix = get_clone_glue ty curr_iso in
2603               trans_call_static_glue
2604                 (code_fixup_to_ptr_operand glue_fix)
2605                 (Some dst)
2606                 [| alias ty_params; src; clone_task |]
2607         | _ ->
2608             iter_ty_parts_full ty_params dst src ty
2609               (clone_ty ty_params clone_task) curr_iso
2610
2611   and free_ty
2612       (is_gc:bool)
2613       (ty_params:Il.cell)
2614       (ty:Ast.ty)
2615       (cell:Il.cell)
2616       (curr_iso:Ast.ty_iso option)
2617       : unit =
2618     check_box_rty cell;
2619     note_drop_step ty "in free-ty";
2620     begin
2621     match simplified_ty ty with
2622         Ast.TY_port _ -> trans_del_port cell
2623       | Ast.TY_chan _ -> trans_del_chan cell
2624       | Ast.TY_task -> trans_kill_task cell
2625       | Ast.TY_str -> trans_free cell false
2626       | Ast.TY_vec s ->
2627           iter_seq_parts ty_params cell cell s
2628             (fun _ src ty iso -> drop_ty ty_params src ty iso) curr_iso;
2629           trans_free cell is_gc
2630
2631       | _ ->
2632           note_drop_step ty "in free-ty, dropping structured body";
2633           let (body_mem, _) =
2634             need_mem_cell
2635               (get_element_ptr_dyn ty_params (deref cell)
2636                  Abi.box_rc_slot_field_body)
2637           in
2638           let body_ty = simplified_ty ty in
2639           let vr = next_vreg_cell Il.voidptr_t in
2640             lea vr body_mem;
2641             trace_word cx.ctxt_sess.Session.sess_trace_drop vr;
2642             trans_call_simple_static_glue
2643               (get_drop_glue body_ty curr_iso) ty_params vr;
2644             note_drop_step ty "in free-ty, calling free";
2645             trans_free cell is_gc;
2646     end;
2647     note_drop_step ty "free-ty done";
2648
2649   and maybe_iso
2650       (curr_iso:Ast.ty_iso option)
2651       (t:Ast.ty)
2652       : Ast.ty =
2653     match (curr_iso, strip_mutable_or_constrained_ty t) with
2654         (_, Ast.TY_idx _) -> bug () "traversing raw TY_idx (non-box )edge"
2655       | (Some iso, Ast.TY_box (Ast.TY_idx n)) ->
2656           Ast.TY_box (Ast.TY_iso { iso with Ast.iso_index = n })
2657       | (None, Ast.TY_box (Ast.TY_idx _)) ->
2658           bug () "TY_idx outside TY_iso"
2659       | _ -> t
2660
2661   and maybe_enter_iso
2662       (t:Ast.ty)
2663       (curr_iso:Ast.ty_iso option)
2664       : Ast.ty_iso option =
2665     match strip_mutable_or_constrained_ty t with
2666         Ast.TY_box (Ast.TY_iso tiso) -> Some tiso
2667       | _ -> curr_iso
2668
2669   and mark_slot
2670       (ty_params:Il.cell)
2671       (cell:Il.cell)
2672       (slot:Ast.slot)
2673       (curr_iso:Ast.ty_iso option)
2674       : unit =
2675     (* Marking goes straight through aliases. Reachable means reachable. *)
2676     mark_ty ty_params (deref_slot false cell slot) (slot_ty slot) curr_iso
2677
2678   and mark_ty
2679       (ty_params:Il.cell)
2680       (cell:Il.cell)
2681       (ty:Ast.ty)
2682       (curr_iso:Ast.ty_iso option)
2683       : unit =
2684     let ty = strip_mutable_or_constrained_ty ty in
2685     match ty_mem_ctrl ty with
2686         MEM_gc ->
2687           let tmp = next_vreg_cell Il.voidptr_t in
2688             trans_upcall "upcall_mark" tmp [| Il.Cell cell |];
2689             let marked_jump =
2690               trans_compare Il.JE (Il.Cell tmp) zero;
2691             in
2692               (* Iterate over box parts marking outgoing links. *)
2693             let (body_mem, _) =
2694               need_mem_cell
2695                 (get_element_ptr (deref cell)
2696                    Abi.box_gc_slot_field_body)
2697             in
2698             let ty = maybe_iso curr_iso ty in
2699             let curr_iso = maybe_enter_iso ty curr_iso in
2700               lea tmp body_mem;
2701               trans_call_simple_static_glue
2702                 (get_mark_glue ty curr_iso)
2703                 ty_params tmp;
2704               List.iter patch marked_jump;
2705
2706         | MEM_interior when type_is_structured ty ->
2707             (iflog (fun _ ->
2708                       annotate ("mark interior memory " ^
2709                                   (Fmt.fmt_to_str Ast.fmt_ty ty))));
2710             let (mem, _) = need_mem_cell cell in
2711             let tmp = next_vreg_cell Il.voidptr_t in
2712             let ty = maybe_iso curr_iso ty in
2713             let curr_iso = maybe_enter_iso ty curr_iso in
2714               lea tmp mem;
2715               trans_call_simple_static_glue
2716                 (get_mark_glue ty curr_iso)
2717                 ty_params tmp
2718
2719         | _ -> ()
2720
2721   and check_box_rty cell =
2722     match cell with
2723         Il.Reg (_, Il.AddrTy (Il.StructTy fields))
2724       | Il.Mem (_, Il.ScalarTy (Il.AddrTy (Il.StructTy fields)))
2725           when (((Array.length fields) > 0) && (fields.(0) = word_rty)) -> ()
2726       | _ -> bug ()
2727           "expected plausibly-box cell, got %s"
2728             (Il.string_of_referent_ty (Il.cell_referent_ty cell))
2729
2730   and drop_slot_in_current_frame
2731       (cell:Il.cell)
2732       (slot:Ast.slot)
2733       (curr_iso:Ast.ty_iso option)
2734       : unit =
2735       drop_slot (get_ty_params_of_current_frame()) cell slot curr_iso
2736
2737   and null_check (cell:Il.cell) : quad_idx =
2738     emit (Il.cmp (Il.Cell cell) zero);
2739     let j = mark() in
2740       emit (Il.jmp Il.JE Il.CodeNone);
2741       j
2742
2743   and drop_refcount_and_cmp (rc:Il.cell) : quad_idx =
2744     iflog (fun _ -> annotate "drop refcount and maybe free");
2745     emit (Il.binary Il.SUB rc (Il.Cell rc) one);
2746     emit (Il.cmp (Il.Cell rc) zero);
2747     let j = mark () in
2748       emit (Il.jmp Il.JNE Il.CodeNone);
2749       j
2750
2751   and drop_slot
2752       (ty_params:Il.cell)
2753       (cell:Il.cell)
2754       (slot:Ast.slot)
2755       (curr_iso:Ast.ty_iso option)
2756       : unit =
2757     match slot.Ast.slot_mode with
2758         Ast.MODE_alias -> ()
2759           (* Aliases are always free to drop. *)
2760       | Ast.MODE_local ->
2761           drop_ty ty_params cell (slot_ty slot) curr_iso
2762
2763   and note_drop_step ty step =
2764     if cx.ctxt_sess.Session.sess_trace_drop ||
2765       cx.ctxt_sess.Session.sess_log_trans
2766     then
2767       let mctrl_str =
2768         match ty_mem_ctrl ty with
2769             MEM_gc -> "MEM_gc"
2770           | MEM_rc_struct -> "MEM_rc_struct"
2771           | MEM_rc_opaque -> "MEM_rc_opaque"
2772           | MEM_interior -> "MEM_interior"
2773       in
2774       let tystr = Fmt.fmt_to_str Ast.fmt_ty ty in
2775       let str = step ^ " " ^ mctrl_str ^ " " ^ tystr in
2776         begin
2777           annotate str;
2778           trace_str cx.ctxt_sess.Session.sess_trace_drop str
2779         end
2780
2781   and note_gc_step ty step =
2782     if cx.ctxt_sess.Session.sess_trace_gc ||
2783       cx.ctxt_sess.Session.sess_log_trans
2784     then
2785       let mctrl_str =
2786         match ty_mem_ctrl ty with
2787             MEM_gc -> "MEM_gc"
2788           | MEM_rc_struct -> "MEM_rc_struct"
2789           | MEM_rc_opaque -> "MEM_rc_opaque"
2790           | MEM_interior -> "MEM_interior"
2791       in
2792       let tystr = Fmt.fmt_to_str Ast.fmt_ty ty in
2793       let str = step ^ " " ^ mctrl_str ^ " " ^ tystr in
2794         begin
2795           annotate str;
2796           trace_str cx.ctxt_sess.Session.sess_trace_gc str
2797         end
2798
2799   (* Returns the offset of the slot-body in the initialized allocation. *)
2800   and init_box (cell:Il.cell) (ty:Ast.ty) : unit =
2801     let mctrl = ty_mem_ctrl ty in
2802       match mctrl with
2803           MEM_gc
2804         | MEM_rc_opaque
2805         | MEM_rc_struct ->
2806             let ctrl =
2807               if mctrl = MEM_gc
2808               then Il.Cell (get_tydesc None ty)
2809               else zero
2810             in
2811               iflog (fun _ -> annotate "init box: malloc");
2812               let sz = box_allocation_size ty in
2813                 trans_malloc cell sz ctrl;
2814                 iflog (fun _ -> annotate "init box: load refcount");
2815                 let rc = box_rc_cell cell in
2816                   mov rc one
2817
2818       | MEM_interior -> bug () "init_box of MEM_interior"
2819
2820   and deref_ty
2821       (dctrl:deref_ctrl)
2822       (initializing:bool)
2823       (cell:Il.cell)
2824       (ty:Ast.ty)
2825       : (Il.cell * Ast.ty) =
2826     match (ty, dctrl) with
2827
2828       | (Ast.TY_mutable ty, _)
2829       | (Ast.TY_constrained (ty, _), _) ->
2830           deref_ty dctrl initializing cell ty
2831
2832       | (Ast.TY_box ty', DEREF_one_box)
2833       | (Ast.TY_box ty', DEREF_all_boxes) ->
2834           check_box_rty cell;
2835           if initializing
2836           then init_box cell ty;
2837           let cell =
2838             get_element_ptr_dyn_in_current_frame
2839               (deref cell)
2840               (Abi.box_rc_slot_field_body)
2841           in
2842           let inner_dctrl =
2843             if dctrl = DEREF_one_box
2844             then DEREF_none
2845             else DEREF_all_boxes
2846           in
2847             (* Possibly deref recursively. *)
2848             deref_ty inner_dctrl initializing cell ty'
2849
2850       | _ -> (cell, ty)
2851
2852
2853   and deref_slot
2854       (initializing:bool)
2855       (cell:Il.cell)
2856       (slot:Ast.slot)
2857       : Il.cell =
2858     match slot.Ast.slot_mode with
2859         Ast.MODE_local ->
2860           cell
2861
2862       | Ast.MODE_alias _  ->
2863           if initializing
2864           then cell
2865           else deref cell
2866
2867   and trans_copy_tup
2868       (ty_params:Il.cell)
2869       (initializing:bool)
2870       (dst:Il.cell)
2871       (src:Il.cell)
2872       (tys:Ast.ty_tup)
2873       : unit =
2874     Array.iteri
2875       begin
2876         fun i ty ->
2877           let sub_dst_cell = get_element_ptr_dyn ty_params dst i in
2878           let sub_src_cell = get_element_ptr_dyn ty_params src i in
2879             trans_copy_ty
2880               ty_params initializing
2881               sub_dst_cell ty sub_src_cell ty None
2882       end
2883       tys
2884
2885   and trans_copy_ty
2886       (ty_params:Il.cell)
2887       (initializing:bool)
2888       (dst:Il.cell) (dst_ty:Ast.ty)
2889       (src:Il.cell) (src_ty:Ast.ty)
2890       (curr_iso:Ast.ty_iso option)
2891       : unit =
2892     let anno (weight:string) : unit =
2893       iflog
2894         begin
2895           fun _ ->
2896             annotate
2897               (Printf.sprintf "%sweight copy: %a <- %a"
2898                  weight
2899                  Ast.sprintf_ty dst_ty
2900                  Ast.sprintf_ty src_ty)
2901         end;
2902     in
2903       iflog
2904         begin
2905           fun _ ->
2906             log cx "trans_copy_ty";
2907             log cx "   dst ty %a, src ty %a"
2908               Ast.sprintf_ty dst_ty Ast.sprintf_ty src_ty;
2909             log cx "   dst cell %s, src cell %s"
2910               (cell_str dst) (cell_str src);
2911         end;
2912       assert (simplified_ty src_ty = simplified_ty dst_ty);
2913       match (ty_mem_ctrl src_ty, ty_mem_ctrl dst_ty) with
2914
2915         | (MEM_rc_opaque, MEM_rc_opaque)
2916         | (MEM_gc, MEM_gc)
2917         | (MEM_rc_struct, MEM_rc_struct) ->
2918             (* Lightweight copy: twiddle refcounts, move pointer. *)
2919             anno "refcounted light";
2920             add_to (box_rc_cell src) one;
2921             if not initializing
2922             then
2923               drop_ty ty_params dst dst_ty None;
2924             mov dst (Il.Cell src)
2925
2926         | _ ->
2927             (* Heavyweight copy: duplicate 1 level of the referent. *)
2928             anno "heavy";
2929             trans_copy_ty_heavy ty_params initializing
2930               dst dst_ty src src_ty curr_iso
2931
2932   (* NB: heavyweight copying here does not mean "producing a deep
2933    * clone of the entire data tree rooted at the src operand". It means
2934    * "replicating a single level of the tree".
2935    * 
2936    * There is no general-recursion entailed in performing a heavy
2937    * copy. There is only "one level" to each heavy copy call.
2938    * 
2939    * In other words, this is a lightweight copy:
2940    * 
2941    *    [dstptr]  <-copy-  [srcptr]
2942    *         \              |
2943    *          \             |
2944    *        [some record.rc++]
2945    *             |
2946    *           [some other record]
2947    * 
2948    * Whereas this is a heavyweight copy:
2949    * 
2950    *    [dstptr]  <-copy-  [srcptr]
2951    *       |                  |
2952    *       |                  |
2953    *  [some record]       [some record]
2954    *             |          |
2955    *           [some other record]
2956    * 
2957    *)
2958
2959   and trans_copy_ty_heavy
2960       (ty_params:Il.cell)
2961       (initializing:bool)
2962       (dst:Il.cell) (dst_ty:Ast.ty)
2963       (src:Il.cell) (src_ty:Ast.ty)
2964       (curr_iso:Ast.ty_iso option)
2965       : unit =
2966     let src_ty = strip_mutable_or_constrained_ty src_ty in
2967     let dst_ty = strip_mutable_or_constrained_ty dst_ty in
2968     let dst_ty = maybe_iso curr_iso dst_ty in
2969     let src_ty = maybe_iso curr_iso src_ty in
2970
2971       iflog
2972         begin
2973           fun _ ->
2974             log cx "trans_copy_ty_heavy";
2975             log cx "   dst ty %a, src ty %a"
2976               Ast.sprintf_ty dst_ty Ast.sprintf_ty src_ty;
2977             log cx "   dst cell %s, src cell %s"
2978               (cell_str dst) (cell_str src);
2979         end;
2980
2981       assert (src_ty = dst_ty);
2982       iflog (fun _ ->
2983                annotate ("heavy copy: slot preparation"));
2984
2985       let curr_iso = maybe_enter_iso dst_ty curr_iso in
2986       let (dst, ty) = deref_ty DEREF_none initializing dst dst_ty in
2987       let (src, _) = deref_ty DEREF_none false src src_ty in
2988         assert (ty = dst_ty);
2989         match ty with
2990             Ast.TY_nil
2991           | Ast.TY_bool
2992           | Ast.TY_mach _
2993           | Ast.TY_int
2994           | Ast.TY_uint
2995           | Ast.TY_native _
2996           | Ast.TY_type
2997           | Ast.TY_char ->
2998               iflog
2999                 (fun _ -> annotate
3000                    (Printf.sprintf "copy_ty: simple mov (%Ld byte scalar)"
3001                       (ty_sz abi ty)));
3002               mov dst (Il.Cell src)
3003
3004           | Ast.TY_param (i, _) ->
3005               iflog
3006                 (fun _ -> annotate
3007                    (Printf.sprintf "copy_ty: parametric copy %#d" i));
3008               aliasing false src
3009                 begin
3010                   fun src ->
3011                     let td = get_ty_param ty_params i in
3012                     let ty_params_ptr = get_tydesc_params ty_params td in
3013                       trans_call_dynamic_glue
3014                         td Abi.tydesc_field_copy_glue
3015                         (Some dst) [| ty_params_ptr; src; |]
3016                 end
3017
3018           | Ast.TY_fn _
3019           | Ast.TY_obj _ ->
3020               begin
3021                 let src_item = get_element_ptr src Abi.binding_field_item in
3022                 let dst_item = get_element_ptr dst Abi.binding_field_item in
3023                 let src_binding =
3024                   get_element_ptr src Abi.binding_field_binding
3025                 in
3026                 let dst_binding =
3027                   get_element_ptr dst Abi.binding_field_binding
3028                 in
3029                   mov dst_item (Il.Cell src_item);
3030                   let null_jmp = null_check src_binding in
3031                     (* Copy if we have a src binding. *)
3032                     (* FIXME (issue #58): this is completely wrong, call
3033                      * through to the binding's self-copy fptr. For now
3034                      * this only works by accident.
3035                      *)
3036                     trans_copy_ty ty_params initializing
3037                       dst_binding (Ast.TY_box Ast.TY_int)
3038                       src_binding (Ast.TY_box Ast.TY_int)
3039                       curr_iso;
3040                     patch null_jmp
3041               end
3042
3043           | _ ->
3044               iter_ty_parts_full ty_params dst src ty
3045                 (fun dst src ty curr_iso ->
3046                    trans_copy_ty ty_params true
3047                      dst ty src ty curr_iso)
3048                 curr_iso
3049
3050
3051   and trans_copy
3052       (initializing:bool)
3053       (dst:Ast.lval)
3054       (src:Ast.expr)
3055       : unit =
3056     let (dst_cell, dst_ty) = trans_lval_maybe_init initializing dst in
3057     let dst_ty = strip_mutable_or_constrained_ty dst_ty in
3058     let rec can_append t =
3059       match t with
3060           Ast.TY_vec _
3061         | Ast.TY_str -> true
3062         | Ast.TY_box t when can_append t -> true
3063         | _ -> false
3064     in
3065       match (dst_ty, src) with
3066           (t,
3067            Ast.EXPR_binary (Ast.BINOP_add,
3068                             Ast.ATOM_lval a, Ast.ATOM_lval b))
3069             when can_append t ->
3070             (*
3071              * Translate str or vec
3072              * 
3073              *   s = a + b
3074              * 
3075              * as
3076              * 
3077              *   s = a;
3078              *   s += b;
3079              *)
3080             let (a_cell, a_ty) = trans_lval a in
3081             let (b_cell, b_ty) = trans_lval b in
3082               trans_copy_ty
3083                 (get_ty_params_of_current_frame())
3084                 initializing dst_cell dst_ty
3085                 a_cell a_ty None;
3086               trans_vec_append dst_cell dst_ty
3087                 (Il.Cell b_cell) b_ty
3088
3089
3090         | (Ast.TY_obj caller_obj_ty,
3091            Ast.EXPR_unary (Ast.UNOP_cast t, a)) ->
3092             let src_ty = atom_type cx a in
3093             let _ = assert (not (is_prim_type (src_ty))) in
3094               begin
3095                 let t = Hashtbl.find cx.ctxt_all_cast_types t.id in
3096                 let _ = assert (t = (Ast.TY_obj caller_obj_ty)) in
3097                 let callee_obj_ty =
3098                   match atom_type cx a with
3099                       Ast.TY_obj t -> t
3100                     | _ -> bug () "obj cast from non-obj type"
3101                 in
3102                 let src_cell = need_cell (trans_atom a) in
3103
3104                 (* FIXME (issue #84): this is wrong. It treats the underlying
3105                  * obj-state as the same as the callee and simply substitutes
3106                  * the forwarding vtbl, which would be great if it had any way
3107                  * convey the callee vtbl to the forwarding functions. But it
3108                  * doesn't. Instead, we have to malloc a fresh 3-word
3109                  * refcounted obj to hold the callee's vtbl+state pair, copy
3110                  * that in as the state here.  *)
3111                 let _ =
3112                   trans_copy_ty (get_ty_params_of_current_frame())
3113                     initializing
3114                     dst_cell dst_ty
3115                     src_cell src_ty
3116                 in
3117                 let caller_vtbl_oper =
3118                   get_forwarding_vtbl caller_obj_ty callee_obj_ty
3119                 in
3120                 let (caller_obj, _) =
3121                   deref_ty DEREF_none initializing dst_cell dst_ty
3122                 in
3123                 let caller_vtbl =
3124                   get_element_ptr caller_obj Abi.binding_field_item
3125                 in
3126                   mov caller_vtbl caller_vtbl_oper
3127               end
3128
3129         | (_, Ast.EXPR_binary _)
3130         | (_, Ast.EXPR_unary _)
3131         | (_, Ast.EXPR_atom (Ast.ATOM_literal _)) ->
3132             (*
3133              * Translations of these expr types yield vregs,
3134              * so copy is just MOV into the lval.
3135              *)
3136             let src_operand = trans_expr src in
3137               mov
3138                 (fst (deref_ty DEREF_none false dst_cell dst_ty))
3139                 src_operand
3140
3141         | (_, Ast.EXPR_atom (Ast.ATOM_lval src_lval)) ->
3142             if lval_is_direct_fn cx src_lval then
3143               trans_copy_direct_fn dst_cell src_lval
3144             else
3145               (* Possibly-large structure copying *)
3146               let (src_cell, src_ty) = trans_lval src_lval in
3147                 trans_copy_ty
3148                   (get_ty_params_of_current_frame())
3149                   initializing
3150                   dst_cell dst_ty
3151                   src_cell src_ty
3152                   None
3153
3154   and trans_copy_direct_fn
3155       (dst_cell:Il.cell)
3156       (flv:Ast.lval)
3157       : unit =
3158     let item = lval_item cx flv in
3159     let fix = Hashtbl.find cx.ctxt_fn_fixups item.id in
3160
3161     let dst_pair_item_cell =
3162       get_element_ptr dst_cell Abi.binding_field_item
3163     in
3164     let dst_pair_binding_cell =
3165       get_element_ptr dst_cell Abi.binding_field_binding
3166     in
3167       mov dst_pair_item_cell (crate_rel_imm fix);
3168       mov dst_pair_binding_cell zero
3169
3170
3171   and trans_init_structural_from_atoms
3172       (dst:Il.cell)
3173       (dst_tys:Ast.ty array)
3174       (atoms:Ast.atom array)
3175       : unit =
3176     Array.iteri
3177       begin
3178         fun i atom ->
3179           trans_init_ty_from_atom
3180             (get_element_ptr_dyn_in_current_frame dst i)
3181             dst_tys.(i) atom
3182       end
3183       atoms
3184
3185   and trans_init_rec_update
3186       (dst:Il.cell)
3187       (dst_tys:Ast.ty array)
3188       (trec:Ast.ty_rec)
3189       (atab:(Ast.ident * Ast.atom) array)
3190       (base:Ast.lval)
3191       : unit =
3192     Array.iteri
3193       begin
3194         fun i (fml_ident, _) ->
3195           let fml_entry _ (act_ident, atom) =
3196             if act_ident = fml_ident then Some atom else None
3197           in
3198           let dst_ty = dst_tys.(i) in
3199             match arr_search atab fml_entry with
3200                 Some atom ->
3201                   trans_init_ty_from_atom
3202                     (get_element_ptr_dyn_in_current_frame dst i)
3203                     dst_ty atom
3204               | None ->
3205                   let (src, _) = trans_lval base in
3206                     trans_copy_ty
3207                       (get_ty_params_of_current_frame()) true
3208                       (get_element_ptr_dyn_in_current_frame dst i) dst_ty
3209                       (get_element_ptr_dyn_in_current_frame src i) dst_ty
3210                       None
3211       end
3212       trec
3213
3214   and trans_init_ty_from_atom
3215       (dst:Il.cell) (ty:Ast.ty) (atom:Ast.atom)
3216       : unit =
3217     let src = Il.Mem (force_to_mem (trans_atom atom)) in
3218       trans_copy_ty (get_ty_params_of_current_frame())
3219        true dst ty src ty None
3220
3221   and trans_init_slot_from_cell
3222       (ty_params:Il.cell)
3223       (clone:clone_ctrl)
3224       (dst:Il.cell) (dst_slot:Ast.slot)
3225       (src:Il.cell) (src_ty:Ast.ty)
3226       : unit =
3227     let dst_ty = slot_ty dst_slot in
3228     let _ =
3229       iflog (fun _ ->
3230                log cx "trans_init_slot_from_cell";
3231                log cx "   dst slot %a, src ty %a"
3232                  Ast.sprintf_slot dst_slot Ast.sprintf_ty src_ty;
3233                log cx "   dst cell %s, src cell %s"
3234                  (cell_str dst) (cell_str src))
3235     in
3236       match (dst_slot.Ast.slot_mode, clone) with
3237           (Ast.MODE_alias, CLONE_none) ->
3238             mov dst (Il.Cell (alias (Il.Mem (need_mem_cell src))))
3239
3240         | (Ast.MODE_local, CLONE_none) ->
3241             trans_copy_ty
3242               ty_params true
3243               dst dst_ty src src_ty None
3244
3245         | (Ast.MODE_alias, _) ->
3246             bug () "attempting to clone into alias slot"
3247
3248         | (_, CLONE_chan clone_task) ->
3249             let clone =
3250               if (type_contains_chan src_ty)
3251               then CLONE_all clone_task
3252               else CLONE_none
3253             in
3254               (* Feed back with massaged args. *)
3255               trans_init_slot_from_cell ty_params
3256                 clone dst dst_slot src src_ty
3257
3258         | (_, CLONE_all clone_task) ->
3259             clone_ty ty_params clone_task dst src src_ty None
3260
3261
3262   and trans_init_slot_from_atom
3263       (clone:clone_ctrl)
3264       (dst:Il.cell) (dst_slot:Ast.slot)
3265       (src_atom:Ast.atom)
3266       : unit =
3267     let _ =
3268       iflog (fun _ ->
3269                log cx "trans_init_slot_from_atom";
3270                log cx "   dst slot %a, src ty %a"
3271                  Ast.sprintf_slot dst_slot
3272                  Ast.sprintf_ty (atom_type cx src_atom);
3273                log cx "   dst cell %s"
3274                  (cell_str dst))
3275     in
3276     match (dst_slot.Ast.slot_mode, clone, src_atom) with
3277         (Ast.MODE_alias, CLONE_none,
3278          Ast.ATOM_literal _) ->
3279           (* Aliasing a literal is a bit weird since nobody
3280            * else will ever see it, but it seems harmless.
3281            *)
3282           let src = trans_atom src_atom in
3283             mov dst (Il.Cell (alias (Il.Mem (force_to_mem src))))
3284
3285       | (Ast.MODE_alias, CLONE_chan _, _)
3286       | (Ast.MODE_alias, CLONE_all _, _) ->
3287           bug () "attempting to clone into alias slot"
3288       | _ ->
3289           let src = Il.Mem (force_to_mem (trans_atom src_atom)) in
3290             begin
3291               log cx "   forced-to-mem src cell %s" (cell_str src);
3292               trans_init_slot_from_cell
3293                 (get_ty_params_of_current_frame())
3294                 clone dst dst_slot src (atom_type cx src_atom)
3295             end
3296
3297
3298   and trans_be_fn
3299       (cx:ctxt)
3300       (dst_cell:Il.cell)
3301       (flv:Ast.lval)
3302       (ty_params:Ast.ty array)
3303       (args:Ast.atom array)
3304       : unit =
3305     let (ptr, fn_ty) = trans_callee flv in
3306     let cc = call_ctrl flv in
3307     let call = { call_ctrl = cc;
3308                  call_callee_ptr = ptr;
3309                  call_callee_ty = fn_ty;
3310                  call_callee_ty_params = ty_params;
3311                  call_output = dst_cell;
3312                  call_args = args;
3313                  call_iterator_args = call_iterator_args None;
3314                  call_indirect_args = call_indirect_args flv cc }
3315     in
3316       (* FIXME (issue #85): true if caller is object fn *)
3317     let caller_is_closure = false in
3318       log cx "trans_be_fn: %s call to lval %a"
3319         (call_ctrl_string cc) Ast.sprintf_lval flv;
3320       trans_be (fun () -> Ast.sprintf_lval () flv) caller_is_closure call
3321
3322   and trans_prepare_fn_call
3323       (initializing:bool)
3324       (cx:ctxt)
3325       (dst_cell:Il.cell)
3326       (flv:Ast.lval)
3327       (ty_params:Ast.ty array)
3328       (fco:for_each_ctrl option)
3329       (args:Ast.atom array)
3330       : Il.operand =
3331     let (ptr, fn_ty) = trans_callee flv in
3332     let cc = call_ctrl flv in
3333     let call = { call_ctrl = cc;
3334                  call_callee_ptr = ptr;
3335                  call_callee_ty = fn_ty;
3336                  call_callee_ty_params = ty_params;
3337                  call_output = dst_cell;
3338                  call_args = args;
3339                  call_iterator_args = call_iterator_args fco;
3340                  call_indirect_args = call_indirect_args flv cc }
3341     in
3342       iflog
3343         begin
3344           fun _ ->
3345             log cx "trans_prepare_fn_call: %s call to lval %a"
3346               (call_ctrl_string cc) Ast.sprintf_lval flv;
3347             log cx "lval type: %a" Ast.sprintf_ty fn_ty;
3348             Array.iteri (fun i t -> log cx "ty param %d = %a"
3349                            i Ast.sprintf_ty t)
3350               ty_params;
3351         end;
3352       trans_prepare_call initializing (fun () -> Ast.sprintf_lval () flv) call
3353
3354   and trans_call_pred_and_check
3355       (constr:Ast.constr)
3356       (flv:Ast.lval)
3357       (args:Ast.atom array)
3358       : unit =
3359     let (ptr, fn_ty) = trans_callee flv in
3360     let dst_cell = Il.Mem (force_to_mem imm_false) in
3361     let call = { call_ctrl = call_ctrl flv;
3362                  call_callee_ptr = ptr;
3363                  call_callee_ty = fn_ty;
3364                  call_callee_ty_params = [| |];
3365                  call_output = dst_cell;
3366                  call_args = args;
3367                  call_iterator_args = [| |];
3368                  call_indirect_args = [| |] }
3369     in
3370       iflog (fun _ -> annotate "predicate call");
3371       let fn_ptr =
3372         trans_prepare_call true (fun _ -> Ast.sprintf_lval () flv) call
3373       in
3374         call_code (code_of_operand fn_ptr);
3375         iflog (fun _ -> annotate "predicate check/fail");
3376         let jmp = trans_compare Il.JE (Il.Cell dst_cell) imm_true in
3377         let errstr = Printf.sprintf "predicate check: %a"
3378           Ast.sprintf_constr constr
3379         in
3380           trans_cond_fail errstr jmp
3381
3382   and trans_init_closure
3383       (closure_cell:Il.cell)
3384       (target_fn_ptr:Il.operand)
3385       (target_binding_ptr:Il.operand)
3386       (bound_arg_slots:Ast.slot array)
3387       (bound_args:Ast.atom array)
3388       : unit =
3389
3390     let rc_cell = get_element_ptr closure_cell 0 in
3391     let targ_cell = get_element_ptr closure_cell 1 in
3392     let args_cell = get_element_ptr closure_cell 2 in
3393
3394     iflog (fun _ -> annotate "init closure refcount");
3395     mov rc_cell one;
3396     iflog (fun _ -> annotate "set closure target code ptr");
3397     mov (get_element_ptr targ_cell 0) (reify_ptr target_fn_ptr);
3398     iflog (fun _ -> annotate "set closure target binding ptr");
3399     mov (get_element_ptr targ_cell 1) (reify_ptr target_binding_ptr);
3400
3401     iflog (fun _ -> annotate "set closure bound args");
3402     copy_bound_args args_cell bound_arg_slots bound_args
3403
3404   and trans_bind_fn
3405       (initializing:bool)
3406       (cc:call_ctrl)
3407       (bind_id:node_id)
3408       (dst:Ast.lval)
3409       (flv:Ast.lval)
3410       (fn_sig:Ast.ty_sig)
3411       (args:Ast.atom option array)
3412       : unit =
3413     let (dst_cell, _) = trans_lval_maybe_init initializing dst in
3414     let (target_ptr, _) = trans_callee flv in
3415     let arg_bound_flags = Array.map bool_of_option args in
3416     let arg_slots =
3417       arr_map2
3418         (fun arg_slot bound_flag ->
3419            if bound_flag then Some arg_slot else None)
3420         fn_sig.Ast.sig_input_slots
3421         arg_bound_flags
3422     in
3423     let bound_arg_slots = arr_filter_some arg_slots in
3424     let bound_args = arr_filter_some args in
3425     let glue_fixup =
3426       get_fn_binding_glue bind_id fn_sig.Ast.sig_input_slots arg_bound_flags
3427     in
3428     let target_fn_ptr = callee_fn_ptr target_ptr cc in
3429     let target_binding_ptr = callee_binding_ptr flv cc in
3430     let closure_rty = closure_referent_type bound_arg_slots in
3431     let closure_sz = force_sz (Il.referent_ty_size word_bits closure_rty) in
3432     let fn_cell = get_element_ptr dst_cell Abi.binding_field_item in
3433     let closure_cell =
3434       ptr_cast
3435         (get_element_ptr dst_cell Abi.binding_field_binding)
3436         (Il.ScalarTy (Il.AddrTy (closure_rty)))
3437     in
3438       iflog (fun _ -> annotate "assign glue-code to fn slot of pair");
3439       mov fn_cell (crate_rel_imm glue_fixup);
3440       iflog (fun _ ->
3441                annotate "heap-allocate closure to binding slot of pair");
3442       trans_malloc closure_cell (imm closure_sz) zero;
3443       trans_init_closure
3444         (deref closure_cell)
3445         target_fn_ptr target_binding_ptr
3446         bound_arg_slots bound_args
3447
3448
3449   and trans_arg0 (arg_cell:Il.cell) (initializing:bool) (call:call) : unit =
3450     (* Emit arg0 of any call: the output slot. *)
3451     iflog (fun _ -> annotate "fn-call arg 0: output slot");
3452     if not initializing
3453     then
3454       drop_slot
3455         (get_ty_params_of_current_frame())
3456         call.call_output
3457         (call_output_slot call) None;
3458     (* We always get to the same state here: the output slot is uninitialized.
3459      * We then do something that's illegal to do in the language, but legal
3460      * here: alias the uninitialized memory. We are ok doing this because the
3461      * call will fill it in before anyone else observes it. That's the
3462      * point.
3463      *)
3464     mov arg_cell (Il.Cell (alias call.call_output));
3465
3466   and trans_arg1 (arg_cell:Il.cell) : unit =
3467     (* Emit arg1 of any call: the task pointer. *)
3468     iflog (fun _ -> annotate "fn-call arg 1: task pointer");
3469     trans_init_slot_from_cell
3470       (get_ty_params_of_current_frame())
3471       CLONE_none
3472       arg_cell word_slot
3473       abi.Abi.abi_tp_cell word_ty
3474
3475   and trans_argN
3476       (clone:clone_ctrl)
3477       (arg_cell:Il.cell)
3478       (arg_slot:Ast.slot)
3479       (arg:Ast.atom)
3480       : unit =
3481     log cx "trans_argN: arg slot %a, arg atom %a"
3482       Ast.sprintf_slot arg_slot Ast.sprintf_atom arg;
3483     trans_init_slot_from_atom clone arg_cell arg_slot arg
3484
3485   and code_of_cell (cell:Il.cell) : Il.code =
3486     match cell with
3487         Il.Mem (_, Il.ScalarTy (Il.AddrTy Il.CodeTy))
3488       | Il.Reg (_, Il.AddrTy Il.CodeTy) -> Il.CodePtr (Il.Cell cell)
3489       | _ ->
3490           bug () "expected code-pointer cell, found %s"
3491             (cell_str cell)
3492
3493   and code_of_operand (operand:Il.operand) : Il.code =
3494     match operand with
3495         Il.Cell c -> code_of_cell c
3496       | Il.ImmPtr (_, Il.CodeTy) -> Il.CodePtr operand
3497       | _ ->
3498           bug () "expected code-pointer operand, got %s"
3499             (oper_str operand)
3500
3501   and ty_arg_slots (ty:Ast.ty) : Ast.slot array =
3502     match simplified_ty ty with
3503         Ast.TY_fn (tsig, _) -> tsig.Ast.sig_input_slots
3504       | _ -> bug () "Trans.ty_arg_slots on non-callable type: %a"
3505           Ast.sprintf_ty ty
3506
3507   and copy_fn_args
3508       (tail_area:bool)
3509       (initializing_arg0:bool)
3510       (clone:clone_ctrl)
3511       (call:call)
3512       : unit =
3513
3514     let n_ty_params = Array.length call.call_callee_ty_params in
3515     let all_callee_args_rty =
3516       let clo =
3517         if call.call_ctrl = CALL_direct
3518         then None
3519         else (Some Il.OpaqueTy)
3520       in
3521         call_args_referent_type cx n_ty_params call.call_callee_ty clo
3522     in
3523     let all_callee_args_cell =
3524       callee_args_cell tail_area all_callee_args_rty
3525     in
3526
3527     let _ = iflog (fun _ -> annotate
3528                      (Printf.sprintf
3529                         "copying fn args to %d-ty-param call with rty: %s\n"
3530                         n_ty_params (Il.string_of_referent_ty
3531                                        all_callee_args_rty)))
3532     in
3533     let callee_arg_slots = ty_arg_slots call.call_callee_ty in
3534     let callee_output_cell =
3535       get_element_ptr all_callee_args_cell Abi.calltup_elt_out_ptr
3536     in
3537     let callee_task_cell =
3538       get_element_ptr all_callee_args_cell Abi.calltup_elt_task_ptr
3539     in
3540     let callee_ty_params =
3541       get_element_ptr all_callee_args_cell Abi.calltup_elt_ty_params
3542     in
3543     let callee_args =
3544       get_element_ptr_dyn_in_current_frame
3545         all_callee_args_cell Abi.calltup_elt_args
3546     in
3547     let callee_iterator_args =
3548       get_element_ptr_dyn_in_current_frame
3549         all_callee_args_cell Abi.calltup_elt_iterator_args
3550     in
3551     let callee_indirect_args =
3552       get_element_ptr_dyn_in_current_frame
3553         all_callee_args_cell Abi.calltup_elt_indirect_args
3554     in
3555
3556     let n_args = Array.length call.call_args in
3557     let n_iterators = Array.length call.call_iterator_args in
3558     let n_indirects = Array.length call.call_indirect_args in
3559
3560       Array.iteri
3561         begin
3562           fun i arg_atom ->
3563             iflog (fun _ ->
3564                      annotate
3565                        (Printf.sprintf "fn-call arg %d of %d (+ %d indirect)"
3566                           i n_args n_indirects));
3567             trans_argN
3568               clone
3569               (get_element_ptr_dyn_in_current_frame callee_args i)
3570               callee_arg_slots.(i)
3571               arg_atom
3572         end
3573         call.call_args;
3574
3575       Array.iteri
3576         begin
3577           fun i iterator_arg_operand ->
3578             iflog (fun _ ->
3579                      annotate (Printf.sprintf "fn-call iterator-arg %d of %d"
3580                                  i n_iterators));
3581             mov
3582               (get_element_ptr_dyn_in_current_frame callee_iterator_args i)
3583               iterator_arg_operand
3584         end
3585         call.call_iterator_args;
3586
3587       Array.iteri
3588         begin
3589           fun i indirect_arg_operand ->
3590             iflog (fun _ ->
3591                      annotate (Printf.sprintf "fn-call indirect-arg %d of %d"
3592                                  i n_indirects));
3593             mov
3594               (get_element_ptr_dyn_in_current_frame callee_indirect_args i)
3595               indirect_arg_operand
3596         end
3597         call.call_indirect_args;
3598
3599       Array.iteri
3600         begin
3601           fun i ty_param ->
3602             iflog (fun _ ->
3603                      annotate
3604                        (Printf.sprintf "fn-call ty param %d of %d"
3605                           i n_ty_params));
3606             trans_init_slot_from_cell
3607               (get_ty_params_of_current_frame())
3608               CLONE_none
3609               (get_element_ptr callee_ty_params i) word_slot
3610               (get_tydesc None ty_param) word_ty
3611         end
3612         call.call_callee_ty_params;
3613
3614         trans_arg1 callee_task_cell;
3615
3616         trans_arg0 callee_output_cell initializing_arg0 call
3617
3618
3619
3620   and call_code (code:Il.code) : unit =
3621     let vr = next_vreg_cell Il.voidptr_t in
3622       emit (Il.call vr code);
3623
3624
3625   and copy_bound_args
3626       (dst_cell:Il.cell)
3627       (bound_arg_slots:Ast.slot array)
3628       (bound_args:Ast.atom array)
3629       : unit =
3630     let n_slots = Array.length bound_arg_slots in
3631       Array.iteri
3632         begin
3633           fun i slot ->
3634             iflog (fun _ ->
3635                      annotate (Printf.sprintf
3636                                  "copy bound arg %d of %d" i n_slots));
3637             trans_argN CLONE_none
3638               (get_element_ptr dst_cell i)
3639               slot bound_args.(i)
3640         end
3641         bound_arg_slots
3642
3643   and merge_bound_args
3644       (all_self_args_rty:Il.referent_ty)
3645       (all_callee_args_rty:Il.referent_ty)
3646       (arg_slots:Ast.slot array)
3647       (arg_bound_flags:bool array)
3648       : unit =
3649     begin
3650       (* 
3651        * NB: 'all_*_args', both self and callee, are always 4-tuples: 
3652        * 
3653        *    [out_ptr, task_ptr, [args], [indirect_args]] 
3654        * 
3655        * The first few bindings here just destructure those via GEP.
3656        * 
3657        *)
3658       let all_self_args_cell = caller_args_cell all_self_args_rty in
3659       let all_callee_args_cell = callee_args_cell false all_callee_args_rty in
3660
3661       let self_args_cell =
3662         get_element_ptr all_self_args_cell Abi.calltup_elt_args
3663       in
3664       let self_ty_params_cell =
3665         get_element_ptr all_self_args_cell Abi.calltup_elt_ty_params
3666       in
3667       let callee_args_cell =
3668         get_element_ptr all_callee_args_cell Abi.calltup_elt_args
3669       in
3670       let self_indirect_args_cell =
3671         get_element_ptr all_self_args_cell Abi.calltup_elt_indirect_args
3672       in
3673
3674       let n_args = Array.length arg_bound_flags in
3675       let bound_i = ref 0 in
3676       let unbound_i = ref 0 in
3677
3678         iflog (fun _ -> annotate "copy out-ptr");
3679         mov
3680           (get_element_ptr all_callee_args_cell Abi.calltup_elt_out_ptr)
3681           (Il.Cell (get_element_ptr all_self_args_cell
3682                       Abi.calltup_elt_out_ptr));
3683
3684         iflog (fun _ -> annotate "copy task-ptr");
3685         mov
3686           (get_element_ptr all_callee_args_cell Abi.calltup_elt_task_ptr)
3687           (Il.Cell (get_element_ptr all_self_args_cell
3688                       Abi.calltup_elt_task_ptr));
3689
3690         iflog (fun _ -> annotate "extract closure indirect-arg");
3691         let closure_cell =
3692           deref (get_element_ptr self_indirect_args_cell
3693                    Abi.indirect_args_elt_closure)
3694         in
3695         let closure_args_cell = get_element_ptr closure_cell 2 in
3696
3697           for arg_i = 0 to (n_args - 1) do
3698             let dst_cell = get_element_ptr callee_args_cell arg_i in
3699             let slot = arg_slots.(arg_i) in
3700             let is_bound = arg_bound_flags.(arg_i) in
3701             let src_cell =
3702               if is_bound then
3703                 begin
3704                   iflog (fun _ -> annotate
3705                            (Printf.sprintf
3706                               "extract bound arg %d as actual arg %d"
3707                               !bound_i arg_i));
3708                   get_element_ptr closure_args_cell (!bound_i)
3709                 end
3710               else
3711                 begin
3712                   iflog (fun _ -> annotate
3713                            (Printf.sprintf
3714                               "extract unbound arg %d as actual arg %d"
3715                               !unbound_i arg_i));
3716                   get_element_ptr self_args_cell (!unbound_i);
3717                 end
3718             in
3719               iflog (fun _ -> annotate
3720                        (Printf.sprintf
3721                           "copy into actual-arg %d" arg_i));
3722               trans_init_slot_from_cell
3723                 self_ty_params_cell CLONE_none
3724                 dst_cell slot
3725                 (deref_slot false src_cell slot) (slot_ty slot);
3726               incr (if is_bound then bound_i else unbound_i);
3727           done;
3728           assert ((!bound_i + !unbound_i) == n_args)
3729     end
3730
3731
3732   and callee_fn_ptr
3733       (fptr:Il.operand)
3734       (cc:call_ctrl)
3735       : Il.operand =
3736     match cc with
3737         CALL_direct
3738       | CALL_vtbl -> fptr
3739       | CALL_indirect ->
3740           (* fptr is a pair [disp, binding*] *)
3741           let pair_cell = need_cell (reify_ptr fptr) in
3742           let disp_cell = get_element_ptr pair_cell Abi.binding_field_item in
3743             Il.Cell (crate_rel_to_ptr (Il.Cell disp_cell) Il.CodeTy)
3744
3745   and callee_binding_ptr
3746       (pair_lval:Ast.lval)
3747       (cc:call_ctrl)
3748       : Il.operand =
3749     if cc = CALL_direct
3750     then zero
3751     else
3752       let (pair_cell, _) = trans_lval pair_lval in
3753         Il.Cell (get_element_ptr pair_cell Abi.binding_field_binding)
3754
3755   and call_ctrl flv : call_ctrl =
3756     if lval_is_static cx flv
3757     then CALL_direct
3758     else
3759       if lval_is_obj_vtbl cx flv
3760       then CALL_vtbl
3761       else CALL_indirect
3762
3763   and call_ctrl_string cc =
3764     match cc with
3765         CALL_direct -> "direct"
3766       | CALL_indirect -> "indirect"
3767       | CALL_vtbl -> "vtbl"
3768
3769   and call_iterator_args
3770       (fco:for_each_ctrl option)
3771       : Il.operand array =
3772     match fco with
3773         None -> [| |]
3774       | Some fco ->
3775           begin
3776             iflog (fun _ -> annotate "calculate iterator args");
3777             [| reify_ptr (code_fixup_to_ptr_operand fco.for_each_fixup);
3778                Il.Cell (Il.Reg (abi.Abi.abi_fp_reg, Il.voidptr_t)); |]
3779           end
3780
3781   and call_indirect_args
3782       (flv:Ast.lval)
3783       (cc:call_ctrl)
3784       : Il.operand array =
3785       begin
3786         match cc with
3787             CALL_direct -> [| |]
3788           | CALL_indirect -> [| callee_binding_ptr flv cc |]
3789           | CALL_vtbl ->
3790               begin
3791                 match flv with
3792                     (* FIXME (issue #84): will need to pass both words of obj
3793                      * if we add a 'self' value for self-dispatch within
3794                      * objs. Also to support forwarding-functions / 'as'.
3795                      *)
3796                     Ast.LVAL_ext (base, _) -> [| callee_binding_ptr base cc |]
3797                   | _ ->
3798                       bug (lval_base_id flv)
3799                         "call_indirect_args on obj-fn without base obj"
3800               end
3801       end
3802
3803   and trans_be
3804       (logname:(unit -> string))
3805       (caller_is_closure:bool)
3806       (call:call)
3807       : unit =
3808     let callee_fptr = callee_fn_ptr call.call_callee_ptr call.call_ctrl in
3809     let callee_code = code_of_operand callee_fptr in
3810     let callee_args_rty =
3811       call_args_referent_type cx 0 call.call_callee_ty
3812         (if call.call_ctrl = CALL_direct then None else (Some Il.OpaqueTy))
3813     in
3814     let callee_argsz =
3815       force_sz (Il.referent_ty_size word_bits callee_args_rty)
3816     in
3817     let closure_rty =
3818       if caller_is_closure
3819       then Some Il.OpaqueTy
3820       else None
3821     in
3822     let caller_args_rty = current_fn_args_rty closure_rty in
3823     let caller_argsz =
3824       force_sz (Il.referent_ty_size word_bits caller_args_rty)
3825     in
3826       iflog (fun _ -> annotate
3827                (Printf.sprintf "copy args for tail call to %s" (logname ())));
3828       copy_fn_args true true CLONE_none call;
3829       drop_slots_at_curr_stmt();
3830       abi.Abi.abi_emit_fn_tail_call (emitter())
3831         (force_sz (current_fn_callsz()))
3832         caller_argsz callee_code callee_argsz;
3833
3834   and trans_prepare_call
3835       (initializing:bool)
3836       (logname:(unit -> string))
3837       (call:call)
3838       : Il.operand =
3839
3840     let callee_fptr = callee_fn_ptr call.call_callee_ptr call.call_ctrl in
3841       iflog (fun _ -> annotate
3842                (Printf.sprintf "copy args for call to %s" (logname ())));
3843       copy_fn_args false initializing CLONE_none call;
3844       iflog (fun _ -> annotate (Printf.sprintf "call %s" (logname ())));
3845       callee_fptr
3846
3847   and callee_drop_slot
3848       (k:Ast.slot_key)
3849       (slot_id:node_id)
3850       (slot:Ast.slot)
3851       : unit =
3852     iflog (fun _ ->
3853              annotate (Printf.sprintf "callee_drop_slot %d = %s "
3854                          (int_of_node slot_id)
3855                          (Fmt.fmt_to_str Ast.fmt_slot_key k)));
3856     drop_slot_in_current_frame (cell_of_block_slot slot_id) slot None
3857
3858
3859   and trans_alt_tag (at:Ast.stmt_alt_tag) : unit =
3860
3861     let trans_arm arm : quad_idx =
3862       let (pat, block) = arm.node in
3863         (* Translates the pattern and returns the addresses of the branch
3864          * instructions, which are taken if the match fails. *)
3865       let rec trans_pat pat src_cell src_ty =
3866         match pat with
3867             Ast.PAT_lit lit ->
3868               trans_compare Il.JNE (trans_lit lit) (Il.Cell src_cell)
3869
3870           | Ast.PAT_tag (lval, pats) ->
3871               let tag_name = tag_ctor_name_to_tag_name (lval_to_name lval) in
3872               let ty_tag =
3873                 match src_ty with
3874                     Ast.TY_tag tag_ty -> tag_ty
3875                   | Ast.TY_iso ti -> (ti.Ast.iso_group).(ti.Ast.iso_index)
3876                   | _ -> bug cx "expected tag type"
3877               in
3878               let tag_keys = sorted_htab_keys ty_tag in
3879               let tag_number = arr_idx tag_keys tag_name in
3880               let ty_tup = Hashtbl.find ty_tag tag_name in
3881
3882               let tag_cell:Il.cell = get_element_ptr src_cell 0 in
3883               let union_cell =
3884                 get_element_ptr_dyn_in_current_frame src_cell 1
3885               in
3886
3887               let next_jumps =
3888                 trans_compare Il.JNE
3889                   (Il.Cell tag_cell) (imm (Int64.of_int tag_number))
3890               in
3891
3892               let tup_cell:Il.cell = get_variant_ptr union_cell tag_number in
3893
3894               let trans_elem_pat i elem_pat : quad_idx list =
3895                 let elem_cell =
3896                   get_element_ptr_dyn_in_current_frame tup_cell i
3897                 in
3898                 let elem_ty = ty_tup.(i) in
3899                   trans_pat elem_pat elem_cell elem_ty
3900               in
3901
3902               let elem_jumps = Array.mapi trans_elem_pat pats in
3903                 next_jumps @ (List.concat (Array.to_list elem_jumps))
3904
3905           | Ast.PAT_slot (dst, _) ->
3906               let dst_slot = get_slot cx dst.id in
3907               let dst_cell = cell_of_block_slot dst.id in
3908                 trans_init_slot_from_cell
3909                   (get_ty_params_of_current_frame())
3910                   CLONE_none dst_cell dst_slot
3911                   src_cell src_ty;
3912                 []                (* irrefutable *)
3913
3914           | Ast.PAT_wild -> []    (* irrefutable *)
3915       in
3916
3917       let (lval_cell, lval_slot) = trans_lval at.Ast.alt_tag_lval in
3918       let next_jumps = trans_pat pat lval_cell lval_slot in
3919         trans_block block;
3920         let last_jump = mark() in
3921           emit (Il.jmp Il.JMP Il.CodeNone);
3922           List.iter patch next_jumps;
3923           last_jump
3924     in
3925     let last_jumps = Array.map trans_arm at.Ast.alt_tag_arms in
3926       Array.iter patch last_jumps
3927
3928   and drop_slots_at_curr_stmt _ : unit =
3929     let stmt = Stack.top curr_stmt in
3930       match htab_search cx.ctxt_post_stmt_slot_drops stmt with
3931           None -> ()
3932         | Some slots ->
3933             List.iter
3934               begin
3935                 fun slot_id ->
3936                   let slot = get_slot cx slot_id in
3937                   let k = Hashtbl.find cx.ctxt_slot_keys slot_id in
3938                     iflog (fun _ ->
3939                              annotate
3940                                (Printf.sprintf
3941                                   "post-stmt, drop_slot %d = %s "
3942                                   (int_of_node slot_id)
3943                                   (Fmt.fmt_to_str Ast.fmt_slot_key k)));
3944                     drop_slot_in_current_frame
3945                       (cell_of_block_slot slot_id) slot None
3946               end
3947               slots
3948
3949   and trans_stmt (stmt:Ast.stmt) : unit =
3950     (* Helper to localize errors by stmt, at minimum. *)
3951     try
3952       iflog
3953         begin
3954           fun _ ->
3955             let s = Fmt.fmt_to_str Ast.fmt_stmt_body stmt in
3956               log cx "translating stmt: %s" s;
3957               annotate s;
3958         end;
3959       Stack.push stmt.id curr_stmt;
3960       trans_stmt_full stmt;
3961       begin
3962         match stmt.node with
3963             Ast.STMT_be _
3964           | Ast.STMT_ret _ -> ()
3965           | _ -> drop_slots_at_curr_stmt();
3966       end;
3967       ignore (Stack.pop curr_stmt);
3968     with
3969         Semant_err (None, msg) -> raise (Semant_err ((Some stmt.id), msg))
3970
3971
3972   and maybe_init (id:node_id) (action:string) (dst:Ast.lval) : bool =
3973     let b = Hashtbl.mem cx.ctxt_copy_stmt_is_init id in
3974     let act = if b then ("initializing-" ^ action) else action in
3975       iflog
3976         (fun _ ->
3977            annotate (Printf.sprintf "%s on dst lval %a"
3978                        act Ast.sprintf_lval dst));
3979       b
3980
3981
3982   and get_current_output_cell_and_slot _ : (Il.cell * Ast.slot) =
3983     let curr_fty =
3984       need_ty_fn (Hashtbl.find cx.ctxt_all_item_types (current_fn()))
3985     in
3986     let curr_args = get_args_for_current_frame () in
3987     let curr_outptr =
3988       get_element_ptr curr_args Abi.calltup_elt_out_ptr
3989     in
3990     let dst_cell = deref curr_outptr in
3991     let dst_slot = (fst curr_fty).Ast.sig_output_slot in
3992       (dst_cell, dst_slot)
3993
3994   and trans_set_outptr (at:Ast.atom) : unit =
3995     let (dst_cell, dst_slot) = get_current_output_cell_and_slot () in
3996       trans_init_slot_from_atom
3997         CLONE_none dst_cell dst_slot at
3998
3999
4000   and trans_for_loop (fo:Ast.stmt_for) : unit =
4001     let ty_params = get_ty_params_of_current_frame () in
4002     let dst_slot_id = (fst (fo.Ast.for_slot)).id in
4003     let dst_slot = get_slot cx dst_slot_id in
4004     let dst_cell = cell_of_block_slot dst_slot_id in
4005     let (head_stmts, seq) = fo.Ast.for_seq in
4006     let (seq_cell, seq_ty) = trans_lval seq in
4007     let unit_ty = seq_unit_ty seq_ty in
4008       Array.iter trans_stmt head_stmts;
4009       iter_seq_parts ty_params seq_cell seq_cell unit_ty
4010         begin
4011           fun _ src_cell unit_ty _ ->
4012             trans_init_slot_from_cell
4013               ty_params CLONE_none
4014               dst_cell dst_slot
4015               src_cell unit_ty;
4016             trans_block fo.Ast.for_body;
4017         end
4018         None
4019
4020   and trans_for_each_loop (stmt_id:node_id) (fe:Ast.stmt_for_each) : unit =
4021     let id = fe.Ast.for_each_body.id in
4022     let g = GLUE_loop_body id in
4023     let name = glue_str cx g in
4024     let fix = new_fixup name in
4025     let framesz = get_framesz cx id in
4026     let callsz = get_callsz cx id in
4027     let spill = Hashtbl.find cx.ctxt_spill_fixups id in
4028       push_new_emitter_with_vregs (Some id);
4029       iflog (fun _ -> annotate "prologue");
4030       abi.Abi.abi_emit_fn_prologue (emitter())
4031         framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
4032       write_frame_info_ptrs None;
4033       iflog (fun _ -> annotate "finished prologue");
4034       trans_block fe.Ast.for_each_body;
4035       trans_glue_frame_exit fix spill g;
4036
4037       (* 
4038        * We've now emitted the body helper-fn. Next, set up a loop that
4039        * calls the iter and passes the helper-fn in.
4040        *)
4041       emit (Il.Enter
4042               (Hashtbl.find
4043                  cx.ctxt_block_fixups
4044                  fe.Ast.for_each_head.id));
4045       let (dst_slot, _) = fe.Ast.for_each_slot in
4046       let dst_cell = cell_of_block_slot dst_slot.id in
4047       let (flv, args) = fe.Ast.for_each_call in
4048       let ty_params =
4049         match htab_search cx.ctxt_call_lval_params (lval_base_id flv) with
4050             Some params -> params
4051           | None -> [| |]
4052       in
4053       let depth = Hashtbl.find cx.ctxt_stmt_loop_depths stmt_id in
4054       let fc = { for_each_fixup = fix; for_each_depth = depth } in
4055         iflog (fun _ ->
4056                  log cx "for-each at depth %d\n" depth);
4057         let fn_ptr =
4058           trans_prepare_fn_call true cx dst_cell flv ty_params (Some fc) args
4059         in
4060           call_code (code_of_operand fn_ptr);
4061           emit Il.Leave;
4062
4063   and trans_put (atom_opt:Ast.atom option) : unit =
4064     begin
4065       match atom_opt with
4066           None -> ()
4067         | Some at -> trans_set_outptr at
4068     end;
4069     let block_fptr = Il.Cell (get_iter_block_fn_for_current_frame ()) in
4070     let fp = get_iter_outer_frame_ptr_for_current_frame () in
4071     let vr = next_vreg_cell Il.voidptr_t in
4072       mov vr zero;
4073       trans_call_glue (code_of_operand block_fptr) None [| vr; fp |]
4074
4075   and trans_vec_append dst_cell dst_ty src_oper src_ty =
4076     let elt_ty = seq_unit_ty dst_ty in
4077     let trim_trailing_null = dst_ty = Ast.TY_str in
4078       assert (simplified_ty src_ty = simplified_ty dst_ty);
4079       match simplified_ty src_ty with
4080           Ast.TY_str
4081         | Ast.TY_vec _ ->
4082             let is_gc = if type_has_state src_ty then 1L else 0L in
4083             let src_cell = need_cell src_oper in
4084             let src_vec = deref src_cell in
4085             let src_fill = get_element_ptr src_vec Abi.vec_elt_fill in
4086             let dst_vec = deref dst_cell in
4087             let dst_fill = get_element_ptr dst_vec Abi.vec_elt_fill in
4088               if trim_trailing_null
4089               then sub_from dst_fill (imm 1L);
4090               trans_upcall "upcall_vec_grow"
4091                 dst_cell
4092                 [| Il.Cell dst_cell;
4093                    Il.Cell src_fill;
4094                    imm is_gc |];
4095
4096               (* 
4097                * By now, dst_cell points to a vec/str with room for us
4098                * to add to.
4099                *)
4100
4101               (* Reload dst vec, fill; might have changed. *)
4102               let dst_vec = deref dst_cell in
4103               let dst_fill = get_element_ptr dst_vec Abi.vec_elt_fill in
4104
4105               (* Copy loop: *)
4106               let eltp_rty = Il.AddrTy (referent_type abi elt_ty) in
4107               let dptr = next_vreg_cell eltp_rty in
4108               let sptr = next_vreg_cell eltp_rty in
4109               let dlim = next_vreg_cell eltp_rty in
4110               let elt_sz = ty_sz_in_current_frame elt_ty in
4111               let dst_data =
4112                 get_element_ptr_dyn_in_current_frame
4113                   dst_vec Abi.vec_elt_data
4114               in
4115               let src_data =
4116                 get_element_ptr_dyn_in_current_frame
4117                   src_vec Abi.vec_elt_data
4118               in
4119                 lea dptr (fst (need_mem_cell dst_data));
4120                 lea sptr (fst (need_mem_cell src_data));
4121                 add_to dptr (Il.Cell dst_fill);
4122                 mov dlim (Il.Cell dptr);
4123                 add_to dlim (Il.Cell src_fill);
4124                 let fwd_jmp = mark () in
4125                   emit (Il.jmp Il.JMP Il.CodeNone);
4126                   let back_jmp_targ = mark () in
4127                     (* copy slot *)
4128                     trans_copy_ty
4129                       (get_ty_params_of_current_frame()) true
4130                       (deref dptr) elt_ty
4131                       (deref sptr) elt_ty
4132                       None;
4133                     add_to dptr elt_sz;
4134                     add_to sptr elt_sz;
4135                     patch fwd_jmp;
4136                     check_interrupt_flag ();
4137                     let back_jmp =
4138                       trans_compare Il.JB (Il.Cell dptr) (Il.Cell dlim) in
4139                       List.iter
4140                         (fun j -> patch_existing j back_jmp_targ) back_jmp;
4141                       let v = next_vreg_cell word_sty in
4142                         mov v (Il.Cell src_fill);
4143                         add_to dst_fill (Il.Cell v);
4144         | t ->
4145             begin
4146               bug () "unsupported vector-append type %a" Ast.sprintf_ty t
4147             end
4148
4149
4150   and trans_copy_binop dst binop a_src =
4151     let (dst_cell, dst_ty) = trans_lval_maybe_init false dst in
4152     let src_oper = trans_atom a_src in
4153       match dst_ty with
4154           Ast.TY_str
4155         | Ast.TY_vec _ when binop = Ast.BINOP_add ->
4156             trans_vec_append dst_cell dst_ty src_oper (atom_type cx a_src)
4157         | _ ->
4158             let (dst_cell, _) = deref_ty DEREF_none false dst_cell dst_ty in
4159             let op = trans_binop binop in
4160               emit (Il.binary op dst_cell (Il.Cell dst_cell) src_oper);
4161
4162
4163   and trans_call id dst flv args =
4164     let init = maybe_init id "call" dst in
4165     let ty = lval_ty cx flv in
4166     let ty_params =
4167       match
4168         htab_search
4169           cx.ctxt_call_lval_params (lval_base_id flv)
4170       with
4171           Some params -> params
4172         | None -> [| |]
4173     in
4174       match simplified_ty ty with
4175           Ast.TY_fn _ ->
4176             let (dst_cell, _) = trans_lval_maybe_init init dst in
4177             let fn_ptr =
4178               trans_prepare_fn_call init cx dst_cell flv
4179                 ty_params None args
4180             in
4181               call_code (code_of_operand fn_ptr)
4182         | _ -> bug () "Calling unexpected lval."
4183
4184
4185   and trans_log id a =
4186     match simplified_ty (atom_type cx a) with
4187         (* NB: If you extend this, be sure to update the
4188          * typechecking code in type.ml as well. *)
4189         Ast.TY_str -> trans_log_str a
4190       | Ast.TY_int | Ast.TY_uint | Ast.TY_bool
4191       | Ast.TY_char | Ast.TY_mach (TY_u8)
4192       | Ast.TY_mach (TY_u16) | Ast.TY_mach (TY_u32)
4193       | Ast.TY_mach (TY_i8) | Ast.TY_mach (TY_i16)
4194       | Ast.TY_mach (TY_i32) ->
4195           trans_log_int a
4196       | _ -> bugi cx id "unimplemented logging type"
4197
4198
4199   and trans_stmt_full (stmt:Ast.stmt) : unit =
4200     match stmt.node with
4201
4202         Ast.STMT_log a ->
4203           trans_log stmt.id a
4204
4205       | Ast.STMT_check_expr e ->
4206           trans_check_expr stmt.id e
4207
4208       | Ast.STMT_yield ->
4209           trans_yield ()
4210
4211       | Ast.STMT_fail ->
4212           trans_fail ()
4213
4214       | Ast.STMT_join task ->
4215           trans_join task
4216
4217       | Ast.STMT_send (chan,src) ->
4218           trans_send chan src
4219
4220       | Ast.STMT_spawn (dst, domain, plv, args) ->
4221           trans_spawn (maybe_init stmt.id "spawn" dst) dst domain plv args
4222
4223       | Ast.STMT_recv (dst, chan) ->
4224           trans_recv (maybe_init stmt.id "recv" dst) dst chan
4225
4226       | Ast.STMT_copy (dst, e_src) ->
4227           trans_copy (maybe_init stmt.id "copy" dst) dst e_src
4228
4229       | Ast.STMT_copy_binop (dst, binop, a_src) ->
4230           trans_copy_binop dst binop a_src
4231
4232       | Ast.STMT_call (dst, flv, args) ->
4233           trans_call stmt.id dst flv args
4234
4235       | Ast.STMT_bind (dst, flv, args) ->
4236           begin
4237             let init = maybe_init stmt.id "bind" dst in
4238               match lval_ty cx flv with
4239                   Ast.TY_fn (tsig, _) ->
4240                     trans_bind_fn
4241                       init (call_ctrl flv) stmt.id dst flv tsig args
4242                 | _ -> bug () "Binding unexpected lval."
4243           end
4244
4245       | Ast.STMT_init_rec (dst, atab, base) ->
4246           let (slot_cell, ty) = trans_lval_init dst in
4247           let (trec, dst_tys) =
4248             match ty with
4249                 Ast.TY_rec trec -> (trec, Array.map snd trec)
4250               | _ ->
4251                   bugi cx stmt.id
4252                     "non-rec destination type in stmt_init_rec"
4253           in
4254           let (dst_cell, _) = deref_ty DEREF_none true slot_cell ty in
4255             begin
4256               match base with
4257                   None ->
4258                     let atoms = Array.map snd atab in
4259                       trans_init_structural_from_atoms
4260                         dst_cell dst_tys atoms
4261                 | Some base_lval ->
4262                     trans_init_rec_update
4263                       dst_cell dst_tys trec atab base_lval
4264             end
4265
4266       | Ast.STMT_init_tup (dst, atoms) ->
4267           let (slot_cell, ty) = trans_lval_init dst in
4268           let dst_tys =
4269             match ty with
4270                 Ast.TY_tup ttup -> ttup
4271               | _ ->
4272                   bugi cx stmt.id
4273                     "non-tup destination type in stmt_init_tup"
4274           in
4275           let (dst_cell, _) = deref_ty DEREF_none true slot_cell ty in
4276             trans_init_structural_from_atoms dst_cell dst_tys atoms
4277
4278
4279       | Ast.STMT_init_str (dst, s) ->
4280           trans_init_str dst s
4281
4282       | Ast.STMT_init_vec (dst, atoms) ->
4283           trans_init_vec dst atoms
4284
4285       | Ast.STMT_init_port dst ->
4286           trans_init_port dst
4287
4288       | Ast.STMT_init_chan (dst, port) ->
4289           begin
4290             match port with
4291                 None ->
4292                   let (dst_cell, _) =
4293                     trans_lval_init dst
4294                   in
4295                     mov dst_cell imm_false
4296               | Some p ->
4297                   trans_init_chan dst p
4298           end
4299
4300       | Ast.STMT_init_box (dst, src) ->
4301           trans_init_box dst src
4302
4303       | Ast.STMT_block block ->
4304           trans_block block
4305
4306       | Ast.STMT_while sw ->
4307           let (head_stmts, head_expr) = sw.Ast.while_lval in
4308           let fwd_jmp = mark () in
4309             emit (Il.jmp Il.JMP Il.CodeNone);
4310             let block_begin = mark () in
4311               trans_block sw.Ast.while_body;
4312               patch fwd_jmp;
4313               Array.iter trans_stmt head_stmts;
4314               check_interrupt_flag ();
4315               let back_jmps = trans_cond false head_expr in
4316                 List.iter (fun j -> patch_existing j block_begin) back_jmps;
4317
4318       | Ast.STMT_if si ->
4319           let skip_thn_jmps = trans_cond true si.Ast.if_test in
4320             trans_block si.Ast.if_then;
4321             begin
4322               match si.Ast.if_else with
4323                   None -> List.iter patch skip_thn_jmps
4324                 | Some els ->
4325                     let skip_els_jmp = mark () in
4326                       begin
4327                         emit (Il.jmp Il.JMP Il.CodeNone);
4328                         List.iter patch skip_thn_jmps;
4329                         trans_block els;
4330                         patch skip_els_jmp
4331                       end
4332             end
4333
4334       | Ast.STMT_check (preds, calls) ->
4335           Array.iteri
4336             (fun i (fn, args) -> trans_call_pred_and_check preds.(i) fn args)
4337             calls
4338
4339       | Ast.STMT_ret atom_opt ->
4340           begin
4341             match atom_opt with
4342                 None -> ()
4343               | Some at -> trans_set_outptr at
4344           end;
4345           drop_slots_at_curr_stmt();
4346           Stack.push (mark()) (Stack.top epilogue_jumps);
4347           emit (Il.jmp Il.JMP Il.CodeNone)
4348
4349       | Ast.STMT_be (flv, args) ->
4350           let ty_params =
4351             match htab_search cx.ctxt_call_lval_params (lval_base_id flv) with
4352                 Some params -> params
4353               | None -> [| |]
4354             in
4355           let (dst_cell, _) = get_current_output_cell_and_slot () in
4356             trans_be_fn cx dst_cell flv ty_params args
4357
4358       | Ast.STMT_put atom_opt ->
4359           trans_put atom_opt
4360
4361       | Ast.STMT_alt_tag stmt_alt_tag -> trans_alt_tag stmt_alt_tag
4362
4363       | Ast.STMT_decl _ -> ()
4364
4365       | Ast.STMT_for fo ->
4366           trans_for_loop fo
4367
4368       | Ast.STMT_for_each fe ->
4369           trans_for_each_loop stmt.id fe
4370
4371       | _ -> bugi cx stmt.id "unhandled form of statement in trans_stmt %a"
4372           Ast.sprintf_stmt stmt
4373
4374   and capture_emitted_quads (fix:fixup) (node:node_id) : unit =
4375     let e = emitter() in
4376     let n_vregs = Il.num_vregs e in
4377     let quads = emitted_quads e in
4378     let name = path_name () in
4379     let f =
4380       if Stack.is_empty curr_file
4381       then bugi cx node "missing file scope when capturing quads."
4382       else Stack.top curr_file
4383     in
4384     let item_code = Hashtbl.find cx.ctxt_file_code f in
4385       begin
4386         iflog (fun _ ->
4387                  log cx "capturing quads for item #%d" (int_of_node node);
4388                  annotate_quads name);
4389         let vr_s =
4390           match htab_search cx.ctxt_spill_fixups node with
4391               None -> (assert (n_vregs = 0); None)
4392             | Some spill -> Some (n_vregs, spill)
4393         in
4394         let code = { code_fixup = fix;
4395                      code_quads = quads;
4396                      code_vregs_and_spill = vr_s; }
4397         in
4398           htab_put item_code node code;
4399           htab_put cx.ctxt_all_item_code node code
4400       end
4401
4402   and get_frame_glue_fns (fnid:node_id) : Il.operand =
4403     let n_ty_params = n_item_ty_params cx fnid in
4404     let get_frame_glue glue inner =
4405       get_mem_glue glue
4406         begin
4407           fun mem ->
4408             iter_frame_and_arg_slots cx fnid
4409               begin
4410                 fun key slot_id slot ->
4411                   match htab_search cx.ctxt_slot_offsets slot_id with
4412                       Some off when not (slot_is_obj_state cx slot_id) ->
4413                         let referent_type = slot_id_referent_type slot_id in
4414                         let fp_cell = rty_ptr_at mem referent_type in
4415                         let (fp, st) = force_to_reg (Il.Cell fp_cell) in
4416                         let ty_params =
4417                           get_ty_params_of_frame fp n_ty_params
4418                         in
4419                         let slot_cell =
4420                           deref_off_sz ty_params (Il.Reg (fp,st)) off
4421                         in
4422                           inner key slot_id ty_params slot slot_cell
4423                     | _ -> ()
4424               end
4425         end
4426     in
4427     trans_crate_rel_data_operand
4428       (DATA_frame_glue_fns fnid)
4429       begin
4430         fun _ ->
4431           let mark_frame_glue_fixup =
4432             get_frame_glue (GLUE_mark_frame fnid)
4433               begin
4434                 fun _ _ ty_params slot slot_cell ->
4435                   mark_slot ty_params slot_cell slot None
4436               end
4437           in
4438           let drop_frame_glue_fixup =
4439             get_frame_glue (GLUE_drop_frame fnid)
4440               begin
4441                 fun _ _ ty_params slot slot_cell ->
4442                   drop_slot ty_params slot_cell slot None
4443               end
4444           in
4445           let reloc_frame_glue_fixup =
4446             get_frame_glue (GLUE_reloc_frame fnid)
4447               begin
4448                 fun _ _ _ _ _ ->
4449                   ()
4450               end
4451           in
4452             table_of_crate_rel_fixups
4453               [|
4454                (* 
4455                 * NB: this must match the struct-offsets given in ABI
4456                 * & rust runtime library.
4457                 *)
4458                 mark_frame_glue_fixup;
4459                 drop_frame_glue_fixup;
4460                 reloc_frame_glue_fixup;
4461               |]
4462       end
4463   in
4464
4465   let trans_frame_entry (fnid:node_id) : unit =
4466     let framesz = get_framesz cx fnid in
4467     let callsz = get_callsz cx fnid in
4468       Stack.push (Stack.create()) epilogue_jumps;
4469       push_new_emitter_with_vregs (Some fnid);
4470       iflog (fun _ -> annotate "prologue");
4471       iflog (fun _ -> annotate (Printf.sprintf
4472                                   "framesz %s"
4473                                   (string_of_size framesz)));
4474       iflog (fun _ -> annotate (Printf.sprintf
4475                                   "callsz %s"
4476                                   (string_of_size callsz)));
4477       abi.Abi.abi_emit_fn_prologue
4478         (emitter()) framesz callsz nabi_rust
4479         (upcall_fixup "upcall_grow_task");
4480
4481       write_frame_info_ptrs (Some fnid);
4482       check_interrupt_flag ();
4483       iflog (fun _ -> annotate "finished prologue");
4484   in
4485
4486   let trans_frame_exit (fnid:node_id) (drop_args:bool) : unit =
4487     Stack.iter patch (Stack.pop epilogue_jumps);
4488     if drop_args
4489     then
4490       begin
4491         iflog (fun _ -> annotate "drop args");
4492         iter_arg_slots cx fnid callee_drop_slot;
4493       end;
4494     iflog (fun _ -> annotate "epilogue");
4495     abi.Abi.abi_emit_fn_epilogue (emitter());
4496     capture_emitted_quads (get_fn_fixup cx fnid) fnid;
4497     pop_emitter ()
4498   in
4499
4500   let trans_fn
4501       (fnid:node_id)
4502       (body:Ast.block)
4503       : unit =
4504     trans_frame_entry fnid;
4505     trans_block body;
4506     trans_frame_exit fnid true;
4507   in
4508
4509   let trans_obj_ctor
4510       (obj_id:node_id)
4511       (header:Ast.header_slots)
4512       : unit =
4513     trans_frame_entry obj_id;
4514
4515     let all_args_rty = current_fn_args_rty None in
4516     let all_args_cell = caller_args_cell all_args_rty in
4517     let frame_args =
4518       get_element_ptr_dyn_in_current_frame
4519         all_args_cell Abi.calltup_elt_args
4520     in
4521     let frame_ty_params =
4522       get_element_ptr_dyn_in_current_frame
4523         all_args_cell Abi.calltup_elt_ty_params
4524     in
4525
4526     let obj_args_tup =
4527       Array.map (fun (sloti,_) -> (slot_ty sloti.node)) header
4528     in
4529     let obj_args_ty = Ast.TY_tup obj_args_tup in
4530     let state_ty = Ast.TY_tup [| Ast.TY_type; obj_args_ty |] in
4531     let state_ptr_ty = Ast.TY_box state_ty in
4532     let state_ptr_rty = referent_type abi state_ptr_ty in
4533     let state_malloc_sz = box_allocation_size state_ptr_ty in
4534
4535     let ctor_ty = Hashtbl.find cx.ctxt_all_item_types obj_id in
4536     let obj_ty =
4537       slot_ty (fst (need_ty_fn ctor_ty)).Ast.sig_output_slot
4538     in
4539
4540     let vtbl_ptr = get_obj_vtbl obj_id in
4541     let _ =
4542       iflog (fun _ -> annotate "calculate vtbl-ptr from displacement")
4543     in
4544     let vtbl_cell = crate_rel_to_ptr vtbl_ptr Il.CodeTy in
4545
4546     let _ = iflog (fun _ -> annotate "load destination obj pair ptr") in
4547     let dst_pair_cell = deref (ptr_at (fp_imm out_mem_disp) obj_ty) in
4548     let dst_pair_item_cell =
4549       get_element_ptr dst_pair_cell Abi.binding_field_item
4550     in
4551     let dst_pair_state_cell =
4552       get_element_ptr dst_pair_cell Abi.binding_field_binding
4553     in
4554
4555       (* Load first cell of pair with vtbl ptr.*)
4556       iflog (fun _ -> annotate "mov vtbl-ptr to obj.item cell");
4557       mov dst_pair_item_cell (Il.Cell vtbl_cell);
4558
4559       (* Load second cell of pair with pointer to fresh state tuple.*)
4560       iflog (fun _ -> annotate "malloc state-tuple to obj.state cell");
4561       trans_malloc dst_pair_state_cell state_malloc_sz zero;
4562
4563       (* Copy args into the state tuple. *)
4564       let state_ptr = next_vreg_cell (need_scalar_ty state_ptr_rty) in
4565         iflog (fun _ -> annotate "load obj.state ptr to vreg");
4566         mov state_ptr (Il.Cell dst_pair_state_cell);
4567         let state = deref state_ptr in
4568         let refcnt = get_element_ptr_dyn_in_current_frame state 0 in
4569         let body = get_element_ptr_dyn_in_current_frame state 1 in
4570         let obj_tydesc = get_element_ptr_dyn_in_current_frame body 0 in
4571         let obj_args = get_element_ptr_dyn_in_current_frame body 1 in
4572           iflog (fun _ -> annotate "write refcnt=1 to obj state");
4573           mov refcnt one;
4574           iflog (fun _ -> annotate "get args-tup tydesc");
4575           mov obj_tydesc
4576             (Il.Cell (get_tydesc
4577                         (Some obj_id)
4578                         (Ast.TY_tup obj_args_tup)));
4579           iflog (fun _ -> annotate "copy ctor args to obj args");
4580           trans_copy_tup
4581             frame_ty_params true
4582             obj_args frame_args obj_args_tup;
4583           (* We have to do something curious here: we can't drop the
4584            * arg slots directly as in the normal frame-exit sequence,
4585            * because the arg slot ids are actually given layout
4586            * positions inside the object state, and are at different
4587            * offsets within that state than within the current
4588            * frame. So we manually drop the argument slots here,
4589            * without mentioning the slot ids.
4590            *)
4591           Array.iteri
4592             (fun i (sloti, _) ->
4593                let cell =
4594                  get_element_ptr_dyn_in_current_frame
4595                    frame_args i
4596                in
4597                  drop_slot frame_ty_params cell sloti.node None)
4598             header;
4599           trans_frame_exit obj_id false;
4600   in
4601
4602   let string_of_name_component (nc:Ast.name_component) : string =
4603     match nc with
4604         Ast.COMP_ident i -> i
4605       | _ -> bug ()
4606           "Trans.string_of_name_component on non-COMP_ident"
4607   in
4608
4609
4610   let trans_static_name_components
4611       (ncs:Ast.name_component list)
4612       : Il.operand =
4613     let f nc =
4614       trans_crate_rel_static_string_frag (string_of_name_component nc)
4615     in
4616       trans_crate_rel_data_operand
4617         (DATA_name (Walk.name_of ncs))
4618         (fun _ -> Asm.SEQ (Array.append
4619                              (Array.map f (Array.of_list ncs))
4620                              [| Asm.WORD (word_ty_mach, Asm.IMM 0L) |]))
4621   in
4622
4623   let trans_required_fn (fnid:node_id) (blockid:node_id) : unit =
4624     trans_frame_entry fnid;
4625     emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups blockid));
4626     let (ilib, conv) = Hashtbl.find cx.ctxt_required_items fnid in
4627     let lib_num =
4628       htab_search_or_add cx.ctxt_required_lib_num ilib
4629         (fun _ -> Hashtbl.length cx.ctxt_required_lib_num)
4630     in
4631     let f = next_vreg_cell (Il.AddrTy (Il.CodeTy)) in
4632     let n_ty_params = n_item_ty_params cx fnid in
4633     let args_rty = direct_call_args_referent_type cx fnid in
4634     let caller_args_cell = caller_args_cell args_rty in
4635       begin
4636         match ilib with
4637             REQUIRED_LIB_rust ls ->
4638               begin
4639                 let c_sym_num =
4640                   htab_search_or_add cx.ctxt_required_c_sym_num
4641                     (ilib, "rust_crate")
4642                     (fun _ -> Hashtbl.length cx.ctxt_required_c_sym_num)
4643                 in
4644                 let rust_sym_num =
4645                   htab_search_or_add cx.ctxt_required_rust_sym_num fnid
4646                     (fun _ -> Hashtbl.length cx.ctxt_required_rust_sym_num)
4647                 in
4648                 let path_elts = stk_elts_from_bot path in
4649                 let _ =
4650                   assert (ls.required_prefix < (List.length path_elts))
4651                 in
4652                 let relative_path_elts =
4653                   list_drop ls.required_prefix path_elts
4654                 in
4655                 let libstr = trans_static_string ls.required_libname in
4656                 let relpath =
4657                   trans_static_name_components relative_path_elts
4658                 in
4659                   trans_upcall "upcall_require_rust_sym" f
4660                     [| Il.Cell (curr_crate_ptr());
4661                        imm (Int64.of_int lib_num);
4662                        imm (Int64.of_int c_sym_num);
4663                        imm (Int64.of_int rust_sym_num);
4664                        libstr;
4665                        relpath |];
4666
4667                   trans_copy_forward_args args_rty;
4668
4669                   call_code (code_of_operand (Il.Cell f));
4670               end
4671
4672           | REQUIRED_LIB_c ls ->
4673               begin
4674                 let c_sym_str =
4675                   match htab_search cx.ctxt_required_syms fnid with
4676                       Some s -> s
4677                     | None ->
4678                         string_of_name_component (Stack.top path)
4679                 in
4680                 let c_sym_num =
4681                   (* FIXME: permit remapping symbol names to handle
4682                    * mangled variants.
4683                    *)
4684                   htab_search_or_add cx.ctxt_required_c_sym_num
4685                     (ilib, c_sym_str)
4686                     (fun _ -> Hashtbl.length cx.ctxt_required_c_sym_num)
4687                 in
4688                 let libstr = trans_static_string ls.required_libname in
4689                 let symstr = trans_static_string c_sym_str in
4690                 let check_rty_sz rty =
4691                   let sz = force_sz (Il.referent_ty_size word_bits rty) in
4692                     if sz = 0L || sz = word_sz
4693                     then ()
4694                     else bug () "bad arg or ret cell size for native require"
4695                 in
4696                 let out =
4697                   get_element_ptr caller_args_cell Abi.calltup_elt_out_ptr
4698                 in
4699                 let _ = check_rty_sz (pointee_type out) in
4700                 let args =
4701                   let ty_params_cell =
4702                     get_element_ptr caller_args_cell Abi.calltup_elt_ty_params
4703                   in
4704                   let args_cell =
4705                     get_element_ptr caller_args_cell Abi.calltup_elt_args
4706                   in
4707                   let n_args =
4708                     match args_cell with
4709                         Il.Mem (_, Il.StructTy elts) -> Array.length elts
4710                       | _ -> bug () "non-StructTy in Trans.trans_required_fn"
4711                   in
4712                   let mk_ty_param i =
4713                     Il.Cell (get_element_ptr ty_params_cell i)
4714                   in
4715                   let mk_arg i =
4716                     let arg = get_element_ptr args_cell i in
4717                     let _ = check_rty_sz (Il.cell_referent_ty arg) in
4718                       Il.Cell arg
4719                   in
4720                     Array.append
4721                       (Array.init n_ty_params mk_ty_param)
4722                       (Array.init n_args mk_arg)
4723                 in
4724                 let nabi = { nabi_convention = conv;
4725                              nabi_indirect = true }
4726                 in
4727                   if conv <> CONV_rust
4728                   then assert (n_ty_params = 0);
4729                   trans_upcall "upcall_require_c_sym" f
4730                     [| Il.Cell (curr_crate_ptr());
4731                        imm (Int64.of_int lib_num);
4732                        imm (Int64.of_int c_sym_num);
4733                        libstr;
4734                        symstr |];
4735
4736                   abi.Abi.abi_emit_native_call_in_thunk (emitter())
4737                     out nabi (Il.Cell f) args;
4738               end
4739
4740           | _ -> bug ()
4741               "Trans.required_rust_fn on unexpected form of require library"
4742       end;
4743       emit Il.Leave;
4744       match ilib with
4745           REQUIRED_LIB_rust _ ->
4746             trans_frame_exit fnid false;
4747         | REQUIRED_LIB_c _ ->
4748             trans_frame_exit fnid true;
4749         | _ -> bug ()
4750             "Trans.required_rust_fn on unexpected form of require library"
4751   in
4752
4753   let trans_tag
4754       (n:Ast.ident)
4755       (tagid:node_id)
4756       (tag:(Ast.header_tup * Ast.ty_tag * node_id))
4757       : unit =
4758     trans_frame_entry tagid;
4759     trace_str cx.ctxt_sess.Session.sess_trace_tag
4760       ("in tag constructor " ^ n);
4761     let (header_tup, _, _) = tag in
4762     let ctor_ty = Hashtbl.find cx.ctxt_all_item_types tagid in
4763     let ttag =
4764       match slot_ty (fst (need_ty_fn ctor_ty)).Ast.sig_output_slot with
4765           Ast.TY_tag ttag -> ttag
4766         | Ast.TY_iso tiso -> get_iso_tag tiso
4767         | _ -> bugi cx tagid "unexpected fn type for tag constructor"
4768     in
4769     let tag_keys = sorted_htab_keys ttag in
4770     let i = arr_idx tag_keys (Ast.NAME_base (Ast.BASE_ident n)) in
4771     let _ = log cx "tag variant: %s -> tag value #%d" n i in
4772     let (dst_cell, dst_slot) = get_current_output_cell_and_slot() in
4773     let dst_cell = deref_slot true dst_cell dst_slot in
4774     let tag_cell = get_element_ptr dst_cell 0 in
4775     let union_cell = get_element_ptr_dyn_in_current_frame dst_cell 1 in
4776     let tag_body_cell = get_variant_ptr union_cell i in
4777     let tag_body_rty = snd (need_mem_cell tag_body_cell) in
4778     let ty_params = get_ty_params_of_current_frame() in
4779       (* A clever compiler will inline this. We are not clever. *)
4780       iflog (fun _ -> annotate (Printf.sprintf "write tag #%d" i));
4781       mov tag_cell (imm (Int64.of_int i));
4782       iflog (fun _ -> annotate ("copy tag-content tuple: tag_body_rty=" ^
4783                                   (Il.string_of_referent_ty tag_body_rty)));
4784       Array.iteri
4785         begin
4786           fun i sloti ->
4787             let slot = sloti.node in
4788             let ty = slot_ty slot in
4789               trans_copy_ty ty_params true
4790                 (get_element_ptr_dyn_in_current_frame tag_body_cell i) ty
4791                 (deref_slot false (cell_of_block_slot sloti.id) slot) ty
4792                 None;
4793         end
4794         header_tup;
4795       trace_str cx.ctxt_sess.Session.sess_trace_tag
4796         ("finished tag constructor " ^ n);
4797       trans_frame_exit tagid true;
4798   in
4799
4800   let enter_file_for id =
4801     if Hashtbl.mem cx.ctxt_item_files id
4802     then Stack.push id curr_file
4803   in
4804
4805   let leave_file_for id =
4806     if Hashtbl.mem cx.ctxt_item_files id
4807     then
4808       if Stack.is_empty curr_file
4809       then bugi cx id "Missing source file on file-scope exit."
4810       else ignore (Stack.pop curr_file)
4811   in
4812
4813   let visit_defined_mod_item_pre n _ i =
4814     iflog (fun _ -> log cx "translating defined item #%d = %s"
4815              (int_of_node i.id) (path_name()));
4816     match i.node.Ast.decl_item with
4817         Ast.MOD_ITEM_fn f -> trans_fn i.id f.Ast.fn_body
4818       | Ast.MOD_ITEM_tag t -> trans_tag n i.id t
4819       | Ast.MOD_ITEM_obj ob ->
4820           trans_obj_ctor i.id
4821             (Array.map (fun (sloti,ident) ->
4822                           ({sloti with node = get_slot cx sloti.id},ident))
4823                ob.Ast.obj_state)
4824       | _ -> ()
4825   in
4826
4827   let visit_required_mod_item_pre _ _ i =
4828     iflog (fun _ -> log cx "translating required item #%d = %s"
4829              (int_of_node i.id) (path_name()));
4830     match i.node.Ast.decl_item with
4831         Ast.MOD_ITEM_fn f -> trans_required_fn i.id f.Ast.fn_body.id
4832       | Ast.MOD_ITEM_mod _ -> ()
4833       | Ast.MOD_ITEM_type _ -> ()
4834       | _ -> bugi cx i.id "unsupported type of require: %s" (path_name())
4835   in
4836
4837   let visit_obj_drop_pre obj b =
4838     let g = GLUE_obj_drop obj.id in
4839     let fix =
4840       match htab_search cx.ctxt_glue_code g with
4841           Some code -> code.code_fixup
4842         | None -> bug () "visit_obj_drop_pre without assigned fixup"
4843     in
4844     let framesz = get_framesz cx b.id in
4845     let callsz = get_callsz cx b.id in
4846     let spill = Hashtbl.find cx.ctxt_spill_fixups b.id in
4847       push_new_emitter_with_vregs (Some b.id);
4848       iflog (fun _ -> annotate "prologue");
4849       abi.Abi.abi_emit_fn_prologue (emitter())
4850         framesz callsz nabi_rust (upcall_fixup "upcall_grow_task");
4851       write_frame_info_ptrs None;
4852       iflog (fun _ -> annotate "finished prologue");
4853       trans_block b;
4854       Hashtbl.remove cx.ctxt_glue_code g;
4855       trans_glue_frame_exit fix spill g;
4856       inner.Walk.visit_obj_drop_pre obj b
4857   in
4858
4859   let visit_defined_obj_fn_pre _ _ fn =
4860     trans_fn fn.id fn.node.Ast.fn_body
4861   in
4862
4863   let visit_required_obj_fn_pre _ _ _ =
4864     ()
4865   in
4866
4867   let visit_obj_fn_pre obj ident fn =
4868     enter_file_for fn.id;
4869     begin
4870       if Hashtbl.mem cx.ctxt_required_items fn.id
4871       then
4872         visit_required_obj_fn_pre obj ident fn
4873       else
4874         visit_defined_obj_fn_pre obj ident fn;
4875     end;
4876     inner.Walk.visit_obj_fn_pre obj ident fn
4877   in
4878
4879   let visit_mod_item_pre n p i =
4880     enter_file_for i.id;
4881     begin
4882       if Hashtbl.mem cx.ctxt_required_items i.id
4883       then
4884         visit_required_mod_item_pre n p i
4885       else
4886         visit_defined_mod_item_pre n p i
4887     end;
4888     inner.Walk.visit_mod_item_pre n p i
4889   in
4890
4891   let visit_mod_item_post n p i =
4892     inner.Walk.visit_mod_item_post n p i;
4893     leave_file_for i.id
4894   in
4895
4896   let visit_obj_fn_post obj ident fn =
4897     inner.Walk.visit_obj_fn_post obj ident fn;
4898     leave_file_for fn.id
4899   in
4900
4901   let visit_crate_pre crate =
4902     enter_file_for crate.id;
4903     inner.Walk.visit_crate_pre crate
4904   in
4905
4906   let visit_crate_post crate =
4907
4908     inner.Walk.visit_crate_post crate;
4909
4910     let emit_aux_global_glue cx glue fix fn =
4911       let glue_name = glue_str cx glue in
4912         push_new_emitter_without_vregs None;
4913         let e = emitter() in
4914           fn e;
4915           iflog (fun _ -> annotate_quads glue_name);
4916           if (Il.num_vregs e) != 0
4917           then bug () "%s uses nonzero vregs" glue_name;
4918           pop_emitter();
4919           let code =
4920             { code_fixup = fix;
4921               code_quads = emitted_quads e;
4922               code_vregs_and_spill = None; }
4923           in
4924             htab_put cx.ctxt_glue_code glue code
4925     in
4926
4927     let tab_sz htab =
4928       Asm.WORD (word_ty_mach, Asm.IMM (Int64.of_int (Hashtbl.length htab)))
4929     in
4930
4931     let crate_data =
4932       (cx.ctxt_crate_fixup,
4933        Asm.DEF
4934          (cx.ctxt_crate_fixup,
4935           Asm.SEQ [|
4936             (* 
4937              * NB: this must match the rust_crate structure
4938              * in the rust runtime library.
4939              *)
4940             crate_rel_word cx.ctxt_image_base_fixup;
4941             Asm.WORD (word_ty_mach, Asm.M_POS cx.ctxt_crate_fixup);
4942
4943             crate_rel_word cx.ctxt_debug_abbrev_fixup;
4944             Asm.WORD (word_ty_mach, Asm.M_SZ cx.ctxt_debug_abbrev_fixup);
4945
4946             crate_rel_word cx.ctxt_debug_info_fixup;
4947             Asm.WORD (word_ty_mach, Asm.M_SZ cx.ctxt_debug_info_fixup);
4948
4949             crate_rel_word cx.ctxt_activate_fixup;
4950             crate_rel_word cx.ctxt_yield_fixup;
4951             crate_rel_word cx.ctxt_unwind_fixup;
4952             crate_rel_word cx.ctxt_gc_fixup;
4953             crate_rel_word cx.ctxt_exit_task_fixup;
4954
4955             tab_sz cx.ctxt_required_rust_sym_num;
4956             tab_sz cx.ctxt_required_c_sym_num;
4957             tab_sz cx.ctxt_required_lib_num;
4958           |]))
4959     in
4960
4961       (* Emit additional glue we didn't do elsewhere. *)
4962       emit_aux_global_glue cx GLUE_activate
4963         cx.ctxt_activate_fixup
4964         abi.Abi.abi_activate;
4965
4966       emit_aux_global_glue cx GLUE_yield
4967         cx.ctxt_yield_fixup
4968         abi.Abi.abi_yield;
4969
4970       emit_aux_global_glue cx GLUE_unwind
4971         cx.ctxt_unwind_fixup
4972         (fun e -> abi.Abi.abi_unwind
4973            e nabi_rust (upcall_fixup "upcall_exit"));
4974
4975       emit_aux_global_glue cx GLUE_gc
4976         cx.ctxt_gc_fixup
4977         abi.Abi.abi_gc;
4978
4979       ignore (get_exit_task_glue ());
4980
4981       begin
4982         match abi.Abi.abi_get_next_pc_thunk with
4983             None -> ()
4984           | Some (_, fix, fn) ->
4985               emit_aux_global_glue cx GLUE_get_next_pc fix fn
4986       end;
4987
4988       htab_put cx.ctxt_data
4989         DATA_crate crate_data;
4990
4991       provide_existing_native cx SEG_data "rust_crate" cx.ctxt_crate_fixup;
4992
4993       leave_file_for crate.id
4994   in
4995
4996     { inner with
4997         Walk.visit_crate_pre = visit_crate_pre;
4998         Walk.visit_crate_post = visit_crate_post;
4999         Walk.visit_mod_item_pre = visit_mod_item_pre;
5000         Walk.visit_mod_item_post = visit_mod_item_post;
5001         Walk.visit_obj_fn_pre = visit_obj_fn_pre;
5002         Walk.visit_obj_fn_post = visit_obj_fn_post;
5003         Walk.visit_obj_drop_pre = visit_obj_drop_pre;
5004     }
5005 ;;
5006
5007
5008 let fixup_assigning_visitor
5009     (cx:ctxt)
5010     (path:Ast.name_component Stack.t)
5011     (inner:Walk.visitor)
5012     : Walk.visitor =
5013
5014   let path_name (_:unit) : string =
5015     Fmt.fmt_to_str Ast.fmt_name (Walk.path_to_name path)
5016   in
5017
5018   let enter_file_for id =
5019     if Hashtbl.mem cx.ctxt_item_files id
5020     then
5021       begin
5022         let name =
5023           if Stack.is_empty path
5024           then "crate root"
5025           else path_name()
5026         in
5027         htab_put cx.ctxt_file_fixups id (new_fixup name);
5028         if not (Hashtbl.mem cx.ctxt_file_code id)
5029         then htab_put cx.ctxt_file_code id (Hashtbl.create 0);
5030       end
5031   in
5032
5033   let visit_mod_item_pre n p i =
5034     enter_file_for i.id;
5035     begin
5036       match i.node.Ast.decl_item with
5037
5038           Ast.MOD_ITEM_tag _ ->
5039             htab_put cx.ctxt_fn_fixups i.id
5040               (new_fixup (path_name()));
5041
5042         | Ast.MOD_ITEM_fn _ ->
5043             begin
5044               let path = path_name () in
5045               let fixup =
5046                 if (not cx.ctxt_sess.Session.sess_library_mode)
5047                   && (Some path) = cx.ctxt_main_name
5048                 then
5049                   match cx.ctxt_main_fn_fixup with
5050                       None -> bug () "missing main fixup in trans"
5051                     | Some fix -> fix
5052                 else
5053                   new_fixup path
5054               in
5055                 htab_put cx.ctxt_fn_fixups i.id fixup;
5056             end
5057
5058         | Ast.MOD_ITEM_obj _ ->
5059             htab_put cx.ctxt_fn_fixups i.id
5060               (new_fixup (path_name()));
5061
5062         | _ -> ()
5063     end;
5064     inner.Walk.visit_mod_item_pre n p i
5065   in
5066
5067   let visit_obj_fn_pre obj ident fn =
5068     htab_put cx.ctxt_fn_fixups fn.id
5069       (new_fixup (path_name()));
5070     inner.Walk.visit_obj_fn_pre obj ident fn
5071   in
5072
5073   let visit_obj_drop_pre obj b =
5074     let g = GLUE_obj_drop obj.id in
5075     let fix = new_fixup (path_name()) in
5076     let tmp_code = { code_fixup = fix;
5077                      code_quads = [| |];
5078                      code_vregs_and_spill = None; } in
5079       htab_put cx.ctxt_glue_code g tmp_code;
5080       inner.Walk.visit_obj_drop_pre obj b
5081   in
5082
5083   let visit_block_pre b =
5084     htab_put cx.ctxt_block_fixups b.id
5085       (new_fixup ("lexical block in " ^ (path_name())));
5086     inner.Walk.visit_block_pre b
5087   in
5088
5089   let visit_crate_pre c =
5090     enter_file_for c.id;
5091     inner.Walk.visit_crate_pre c
5092   in
5093
5094   { inner with
5095       Walk.visit_crate_pre = visit_crate_pre;
5096       Walk.visit_mod_item_pre = visit_mod_item_pre;
5097       Walk.visit_obj_fn_pre = visit_obj_fn_pre;
5098       Walk.visit_obj_drop_pre = visit_obj_drop_pre;
5099       Walk.visit_block_pre = visit_block_pre; }
5100
5101
5102 let process_crate
5103     (cx:ctxt)
5104     (crate:Ast.crate)
5105     : unit =
5106   let path = Stack.create () in
5107   let passes =
5108     [|
5109       (unreferenced_required_item_ignoring_visitor cx
5110          (fixup_assigning_visitor cx path
5111             Walk.empty_visitor));
5112       (unreferenced_required_item_ignoring_visitor cx
5113          (Walk.mod_item_logging_visitor
5114             (log cx "translation pass: %s")
5115             path
5116             (trans_visitor cx path
5117                Walk.empty_visitor)))
5118     |];
5119   in
5120     log cx "translating crate";
5121     begin
5122       match cx.ctxt_main_name with
5123           None -> ()
5124         | Some m -> log cx "with main fn %s" m
5125     end;
5126     run_passes cx "trans" path passes (log cx "%s") crate;
5127 ;;
5128
5129 (*
5130  * Local Variables:
5131  * fill-column: 78;
5132  * indent-tabs-mode: nil
5133  * buffer-file-coding-system: utf-8-unix
5134  * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
5135  * End:
5136  *)