aboutsummaryrefslogtreecommitdiff
path: root/src/boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot')
-rw-r--r--src/boot/be/il.ml4
-rw-r--r--src/boot/be/x86.ml61
-rw-r--r--src/boot/fe/item.ml5
-rw-r--r--src/boot/fe/pexp.ml50
-rw-r--r--src/boot/llvm/lltrans.ml39
-rw-r--r--src/boot/me/trans.ml59
-rw-r--r--src/boot/me/type.ml9
7 files changed, 149 insertions, 78 deletions
diff --git a/src/boot/be/il.ml b/src/boot/be/il.ml
index 792e83e2..172d8661 100644
--- a/src/boot/be/il.ml
+++ b/src/boot/be/il.ml
@@ -695,7 +695,7 @@ type emitter = { mutable emit_pc: int;
emit_target_specific: (emitter -> quad -> unit);
mutable emit_quads: quads;
emit_annotations: (int,string) Hashtbl.t;
- emit_size_cache: ((size,operand) Hashtbl.t) Stack.t;
+ emit_size_cache: (size,operand) Hashtbl.t;
emit_node: node_id option;
}
@@ -722,7 +722,7 @@ let new_emitter
emit_target_specific = emit_target_specific;
emit_quads = Array.create 4 badq;
emit_annotations = Hashtbl.create 0;
- emit_size_cache = Stack.create ();
+ emit_size_cache = Hashtbl.create 0;
emit_node = node;
}
;;
diff --git a/src/boot/be/x86.ml b/src/boot/be/x86.ml
index 217149c7..55b101bb 100644
--- a/src/boot/be/x86.ml
+++ b/src/boot/be/x86.ml
@@ -302,11 +302,41 @@ let emit_target_specific
| Il.IMOD | Il.UMOD ->
let dst_eax = hr_like_cell eax dst in
let lhs_eax = hr_like_op eax lhs in
- let rhs_ecx = hr_like_op ecx lhs in
- if lhs <> (Il.Cell lhs_eax)
- then mov lhs_eax lhs;
- if rhs <> (Il.Cell rhs_ecx)
- then mov rhs_ecx rhs;
+ let rhs_ecx = hr_like_op ecx rhs in
+ (* Horrible: we bounce complex mul inputs off spill slots
+ * to ensure non-interference between the temporaries used
+ * during mem-base-reg reloads and the registers we're
+ * preparing. *)
+ let next_spill_like op =
+ Il.Mem (Il.next_spill_slot e
+ (Il.ScalarTy (Il.operand_scalar_ty op)))
+ in
+ let is_mem op =
+ match op with
+ Il.Cell (Il.Mem _) -> true
+ | _ -> false
+ in
+ let bounce_lhs = is_mem lhs in
+ let bounce_rhs = is_mem rhs in
+ let lhs_spill = next_spill_like lhs in
+ let rhs_spill = next_spill_like rhs in
+
+ if bounce_lhs
+ then mov lhs_spill lhs;
+
+ if bounce_rhs
+ then mov rhs_spill rhs;
+
+ mov lhs_eax
+ (if bounce_lhs
+ then (Il.Cell lhs_spill)
+ else lhs);
+
+ mov rhs_ecx
+ (if bounce_rhs
+ then (Il.Cell rhs_spill)
+ else rhs);
+
put (Il.Binary
{ b with
Il.binary_lhs = (Il.Cell lhs_eax);
@@ -314,7 +344,7 @@ let emit_target_specific
Il.binary_dst = dst_eax; });
if dst <> dst_eax
then mov dst (Il.Cell dst_eax);
-
+
| _ when (Il.Cell dst) <> lhs ->
mov dst lhs;
put (Il.Binary
@@ -1936,15 +1966,20 @@ let zero (dst:Il.cell) (count:Il.operand) : Asm.frag =
;;
let mov (signed:bool) (dst:Il.cell) (src:Il.operand) : Asm.frag =
- if is_ty8 (Il.cell_scalar_ty dst) || is_ty8 (Il.operand_scalar_ty src)
+ if is_ty8 (Il.cell_scalar_ty dst)
then
begin
- (match dst with
- Il.Reg (Il.Hreg r, _)
- -> assert (is_ok_r8 r) | _ -> ());
- (match src with
- Il.Cell (Il.Reg (Il.Hreg r, _))
- -> assert (is_ok_r8 r) | _ -> ());
+ match dst with
+ Il.Reg (Il.Hreg r, _) -> assert (is_ok_r8 r)
+ | _ -> ()
+ end;
+
+ if is_ty8 (Il.operand_scalar_ty src)
+ then
+ begin
+ match src with
+ Il.Cell (Il.Reg (Il.Hreg r, _)) -> assert (is_ok_r8 r)
+ | _ -> ()
end;
match (signed, dst, src) with
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index 69fe5fc2..82ec2faf 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -253,7 +253,10 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
let lv = name_to_lval apos bpos name in
Ast.PAT_tag (lv, paren_comma_list parse_pat ps)
- | LIT_INT _ | LIT_CHAR _ | LIT_BOOL _ ->
+ | LIT_INT _
+ | LIT_UINT _
+ | LIT_CHAR _
+ | LIT_BOOL _ ->
Ast.PAT_lit (Pexp.parse_lit ps)
| UNDERSCORE -> bump ps; Ast.PAT_wild
diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml
index fb2d91a0..3e17e0e4 100644
--- a/src/boot/fe/pexp.ml
+++ b/src/boot/fe/pexp.ml
@@ -817,11 +817,33 @@ and parse_or_pexp (ps:pstate) : pexp =
step lhs
+and parse_as_pexp (ps:pstate) : pexp =
+ let apos = lexpos ps in
+ let pexp = ctxt "as pexp" parse_or_pexp ps in
+ let rec step accum =
+ match peek ps with
+ AS ->
+ bump ps;
+ let tapos = lexpos ps in
+ let t = parse_ty ps in
+ let bpos = lexpos ps in
+ let t = span ps tapos bpos t in
+ let node =
+ span ps apos bpos
+ (PEXP_unop ((Ast.UNOP_cast t), accum))
+ in
+ step node
+
+ | _ -> accum
+ in
+ step pexp
+
+
and parse_relational_pexp (ps:pstate) : pexp =
let name = "relational pexp" in
let apos = lexpos ps in
- let lhs = ctxt (name ^ " lhs") parse_or_pexp ps in
- let build = binop_build ps name apos parse_or_pexp in
+ let lhs = ctxt (name ^ " lhs") parse_as_pexp ps in
+ let build = binop_build ps name apos parse_as_pexp in
let rec step accum =
match peek ps with
LT -> build accum step Ast.BINOP_lt
@@ -883,30 +905,8 @@ and parse_oror_pexp (ps:pstate) : pexp =
step lhs
-and parse_as_pexp (ps:pstate) : pexp =
- let apos = lexpos ps in
- let pexp = ctxt "as pexp" parse_oror_pexp ps in
- let rec step accum =
- match peek ps with
- AS ->
- bump ps;
- let tapos = lexpos ps in
- let t = parse_ty ps in
- let bpos = lexpos ps in
- let t = span ps tapos bpos t in
- let node =
- span ps apos bpos
- (PEXP_unop ((Ast.UNOP_cast t), accum))
- in
- step node
-
- | _ -> accum
- in
- step pexp
-
-
and parse_pexp (ps:pstate) : pexp =
- parse_as_pexp ps
+ parse_oror_pexp ps
and parse_mutable_and_pexp (ps:pstate) : (Ast.mutability * pexp) =
let mutability = parse_mutability ps in
diff --git a/src/boot/llvm/lltrans.ml b/src/boot/llvm/lltrans.ml
index ee192725..c1ef49af 100644
--- a/src/boot/llvm/lltrans.ml
+++ b/src/boot/llvm/lltrans.ml
@@ -588,7 +588,7 @@ let trans_crate
(* Maps a fn's or block's id to an LLVM metadata node (subprogram or
lexical block) representing it. *)
let (dbg_llscopes:(node_id, Llvm.llvalue) Hashtbl.t) = Hashtbl.create 0 in
- let declare_mod_item
+ let rec declare_mod_item
(name:Ast.ident)
mod_item
: unit =
@@ -616,9 +616,8 @@ let trans_crate
| Ast.MOD_ITEM_type _ ->
() (* Types get translated with their terms. *)
- | Ast.MOD_ITEM_mod _ ->
- () (* Modules simply contain other items that are translated
- on their own. *)
+ | Ast.MOD_ITEM_mod (_, items) ->
+ Hashtbl.iter declare_mod_item items
| _ ->
Common.unimpl (Some id)
@@ -807,6 +806,17 @@ let trans_crate
Ast.sprintf_lval lval)
in
+ let trans_callee (fn:Ast.lval) : (Llvm.llvalue * Ast.ty) =
+ let fty = Hashtbl.find sem_cx.ctxt_all_lval_types (lval_base_id fn) in
+ if lval_base_is_item sem_cx fn then
+ let fn_item = lval_item sem_cx fn in
+ let llfn = Hashtbl.find llitems (fn_item.id) in
+ (llfn, fty)
+ else
+ (* indirect call to computed slot *)
+ trans_lval fn
+ in
+
let trans_atom (atom:Ast.atom) : Llvm.llvalue =
iflog (fun _ -> log sem_cx "trans_atom: %a" Ast.sprintf_atom atom);
match atom with
@@ -959,7 +969,7 @@ let trans_crate
| Ast.STMT_call (dest, fn, args) ->
let llargs = Array.map trans_atom args in
let (lldest, _) = trans_lval dest in
- let (llfn, _) = trans_lval fn in
+ let (llfn, _) = trans_callee fn in
let llallargs = Array.append [| lldest; lltask |] llargs in
let llrv = build_call llfn llallargs "" llbuilder in
Llvm.set_instruction_call_conv Llvm.CallConv.c llrv;
@@ -1072,13 +1082,22 @@ let trans_crate
ignore (Llvm.build_br llbodyblock llinitbuilder)
in
- let trans_mod_item
- (_:Ast.ident)
- { node = { Ast.decl_item = (item:Ast.mod_item') }; id = id }
+ let rec trans_mod_item
+ (name:Ast.ident)
+ mod_item
: unit =
+ let { node = { Ast.decl_item = (item:Ast.mod_item') }; id = id } =
+ mod_item in
match item with
- Ast.MOD_ITEM_fn fn -> trans_fn fn id
- | _ -> ()
+ Ast.MOD_ITEM_type _ ->
+ () (* Types get translated with their terms. *)
+ | Ast.MOD_ITEM_mod (_, items) ->
+ Hashtbl.iter trans_mod_item items
+ | Ast.MOD_ITEM_fn fn -> trans_fn fn id
+ | _ -> Common.unimpl (Some id)
+ "LLVM module declaration for: %a"
+ Ast.sprintf_mod_item (name, mod_item)
+
in
let exit_task_glue =
diff --git a/src/boot/me/trans.ml b/src/boot/me/trans.ml
index f2bb2287..b708bb26 100644
--- a/src/boot/me/trans.ml
+++ b/src/boot/me/trans.ml
@@ -163,7 +163,6 @@ let trans_visitor
abi.Abi.abi_emit_target_specific
vregs_ok fnid
in
- Stack.push (Hashtbl.create 0) e.Il.emit_size_cache;
Stack.push e emitters;
in
@@ -172,16 +171,20 @@ let trans_visitor
let pop_emitter _ = ignore (Stack.pop emitters) in
let emitter _ = Stack.top emitters in
- let emitter_size_cache _ = Stack.top (emitter()).Il.emit_size_cache in
- let push_emitter_size_cache _ =
- Stack.push
- (Hashtbl.copy (emitter_size_cache()))
- (emitter()).Il.emit_size_cache
+ let emitter_size_cache _ = (emitter()).Il.emit_size_cache in
+ let flush_emitter_size_cache _ =
+ Hashtbl.clear (emitter_size_cache())
in
- let pop_emitter_size_cache _ =
- ignore (Stack.pop (emitter()).Il.emit_size_cache)
+
+ let emit q =
+ begin
+ match q with
+ Il.Jmp _ -> flush_emitter_size_cache();
+ | _ -> ()
+ end;
+ Il.emit (emitter()) q
in
- let emit q = Il.emit (emitter()) q in
+
let next_vreg _ = Il.next_vreg (emitter()) in
let next_vreg_cell t = Il.next_vreg_cell (emitter()) t in
let next_spill_cell t =
@@ -190,12 +193,17 @@ let trans_visitor
let spill_ta = (spill_mem, Il.ScalarTy t) in
Il.Mem spill_ta
in
- let mark _ : quad_idx = (emitter()).Il.emit_pc in
+ let mark _ : quad_idx =
+ flush_emitter_size_cache ();
+ (emitter()).Il.emit_pc
+ in
let patch_existing (jmp:quad_idx) (targ:quad_idx) : unit =
- Il.patch_jump (emitter()) jmp targ
+ Il.patch_jump (emitter()) jmp targ;
+ flush_emitter_size_cache ();
in
let patch (i:quad_idx) : unit =
Il.patch_jump (emitter()) i (mark());
+ flush_emitter_size_cache ();
(* Insert a dead quad to ensure there's an otherwise-unused
* jump-target here.
*)
@@ -583,7 +591,13 @@ let trans_visitor
(string_of_size size)));
let sub_sz = calculate_sz ty_params in
match htab_search (emitter_size_cache()) size with
- Some op -> op
+ Some op ->
+ iflog (fun _ -> annotate
+ (Printf.sprintf "cached size %s is %s"
+ (string_of_size size)
+ (oper_str op)));
+ op
+
| _ ->
let res =
match size with
@@ -914,7 +928,8 @@ let trans_visitor
let atop = trans_atom at in
let unit_sz = ty_sz_in_current_frame ty in
let idx = next_vreg_cell word_sty in
- emit (Il.binary Il.UMUL idx atop unit_sz);
+ mov idx atop;
+ emit (Il.binary Il.UMUL idx (Il.Cell idx) unit_sz);
let elt_mem = trans_bounds_check (deref cell) (Il.Cell idx) in
(Il.Mem (elt_mem, referent_type abi ty), ty)
in
@@ -1923,8 +1938,8 @@ let trans_visitor
: quad_idx list =
emit (Il.cmp (Il.Cell (Il.Reg (force_to_reg lhs))) rhs);
let jmp = mark() in
- emit (Il.jmp cjmp Il.CodeNone);
- [ jmp ]
+ emit (Il.jmp cjmp Il.CodeNone);
+ [ jmp ]
and trans_compare
?ty_params:(ty_params=get_ty_params_of_current_frame())
@@ -1943,7 +1958,6 @@ let trans_visitor
| _ -> trans_compare_simple cjmp lhs rhs
and trans_cond (invert:bool) (expr:Ast.expr) : quad_idx list =
-
let anno _ =
iflog
begin
@@ -2075,15 +2089,14 @@ let trans_visitor
trans_atom a
and trans_block (block:Ast.block) : unit =
+ flush_emitter_size_cache();
trace_str cx.ctxt_sess.Session.sess_trace_block
"entering block";
- push_emitter_size_cache ();
emit (Il.Enter (Hashtbl.find cx.ctxt_block_fixups block.id));
Array.iter trans_stmt block.node;
trace_str cx.ctxt_sess.Session.sess_trace_block
"exiting block";
emit Il.Leave;
- pop_emitter_size_cache ();
trace_str cx.ctxt_sess.Session.sess_trace_block
"exited block";
@@ -4395,11 +4408,11 @@ let trans_visitor
let back_jmp =
trans_compare_simple Il.JB (Il.Cell dptr) (Il.Cell dlim)
in
- List.iter
- (fun j -> patch_existing j back_jmp_targ) back_jmp;
- let v = next_vreg_cell word_sty in
- mov v (Il.Cell src_fill);
- add_to dst_fill (Il.Cell v);
+ List.iter
+ (fun j -> patch_existing j back_jmp_targ) back_jmp;
+ let v = next_vreg_cell word_sty in
+ mov v (Il.Cell src_fill);
+ add_to dst_fill (Il.Cell v);
| t ->
begin
bug () "unsupported vector-append type %a" Ast.sprintf_ty t
diff --git a/src/boot/me/type.ml b/src/boot/me/type.ml
index 787855f0..23210ea1 100644
--- a/src/boot/me/type.ml
+++ b/src/boot/me/type.ml
@@ -380,19 +380,20 @@ let check_stmt (cx:Semant.ctxt) : (fn_ctx -> Ast.stmt -> unit) =
sprintf_itype ()
| `Type (Ast.TY_vec ty_vec), Ast.COMP_atom atom ->
- demand Ast.TY_int (check_atom atom);
+ demand_integer (check_atom atom);
LTYPE_mono ty_vec
| `Type (Ast.TY_vec _), _ ->
- Common.err None "the vector type '%a' must be indexed via an int"
+ Common.err None
+ "the vector type '%a' must be indexed by an integral type"
sprintf_itype ()
| `Type Ast.TY_str, Ast.COMP_atom atom ->
- demand Ast.TY_int (check_atom atom);
+ demand_integer (check_atom atom);
LTYPE_mono (Ast.TY_mach Common.TY_u8)
| `Type Ast.TY_str, _ ->
- Common.err None "strings must be indexed via an int"
+ Common.err None "strings must be indexed by an integral type"
| `Type (Ast.TY_box ty_box), Ast.COMP_deref -> LTYPE_mono ty_box
generated by cgit v1.2.3 (git 2.25.1) at 2026-03-12 03:44:12 +0000