diff options
Diffstat (limited to 'bytecomp/translcore.ml')
| -rw-r--r-- | bytecomp/translcore.ml | 88 |
1 files changed, 57 insertions, 31 deletions
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 392a9afe6d..bff8a5dcce 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -65,8 +65,9 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Clt, Pfloatcomp Clt, - Pccall{prim_name = "lessthan"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_lessthan"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Clt), Pbintcomp(Pint32, Clt), Pbintcomp(Pint64, Clt)); @@ -75,8 +76,9 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Cgt, Pfloatcomp Cgt, - Pccall{prim_name = "greaterthan"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_greaterthan"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Cgt), Pbintcomp(Pint32, Cgt), Pbintcomp(Pint64, Cgt)); @@ -85,8 +87,9 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Cle, Pfloatcomp Cle, - Pccall{prim_name = "lessequal"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_lessequal"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Cle), Pbintcomp(Pint32, Cle), Pbintcomp(Pint64, Cle)); @@ -95,11 +98,33 @@ let comparisons_table = create_hashtable 11 [ prim_native_name = ""; prim_native_float = false}, Pintcomp Cge, Pfloatcomp Cge, - Pccall{prim_name = "greaterequal"; prim_arity = 2; prim_alloc = false; - prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "string_greaterequal"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, Pbintcomp(Pnativeint, Cge), Pbintcomp(Pint32, Cge), - Pbintcomp(Pint64, Cge)) + Pbintcomp(Pint64, Cge)); + "%compare", + (Pccall{prim_name = "compare"; prim_arity = 2; prim_alloc = true; + prim_native_name = ""; prim_native_float = false}, + Pccall{prim_name = "int_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "float_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "string_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "nativeint_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "int32_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}, + Pccall{prim_name = "int64_compare"; prim_arity = 2; + prim_alloc = false; prim_native_name = ""; + prim_native_float = false}) ] let primitives_table = create_hashtable 57 [ @@ -300,6 +325,8 @@ let transl_primitive p = let check_recursive_lambda idlist lam = let rec check_top idlist = function | Lvar v -> not (List.mem v idlist) + | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + true | Llet(str, id, arg, body) -> check idlist arg && check_top (add_let id arg idlist) body | Lletrec(bindings, body) -> @@ -313,6 +340,8 @@ let check_recursive_lambda idlist lam = and check idlist = function | Lvar _ -> true | Lfunction(kind, params, body) -> true + | Llet (_, _, _, _) as lam when check_recursive_recordwith idlist lam -> + true | Llet(str, id, arg, body) -> check idlist arg && check (add_let id arg idlist) body | Lletrec(bindings, body) -> @@ -339,6 +368,20 @@ let check_recursive_lambda idlist lam = List.fold_right (fun (id, arg) idl -> add_let id arg idl) bindings idlist + (* reverse-engineering the code generated by transl_record case 2 *) + and check_recursive_recordwith idlist = function + | Llet (Strict, id1, Lprim (Pccall prim, [e1]), body) -> + prim = prim_obj_dup && check_top idlist e1 + && check_recordwith_updates idlist id1 body + | _ -> false + + and check_recordwith_updates idlist id1 = function + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; e1]), cont) + -> id2 = id1 && check idlist e1 + && check_recordwith_updates idlist id1 cont + | Lvar id2 -> id2 = id1 + | _ -> false + in check_top idlist lam (* To propagate structured constants *) @@ -538,7 +581,8 @@ let rec transl_exp e = end | Texp_record ((lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr - | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" + | Texp_record ([], _) -> + fatal_error "Translcore.transl_exp: bad Texp_record" | Texp_field(arg, lbl) -> let access = match lbl.lbl_repres with @@ -552,27 +596,7 @@ let rec transl_exp e = | Record_float -> Psetfloatfield lbl.lbl_pos in Lprim(access, [transl_exp arg; transl_exp newval]) | Texp_array expr_list -> - let kind = array_kind e in - let len = List.length expr_list in - if len <= Config.max_young_wosize then - Lprim(Pmakearray kind, transl_list expr_list) - else begin - let v = Ident.create "makearray" in - let rec fill_fields pos = function - [] -> - Lvar v - | arg :: rem -> - Lsequence(Lprim(Parraysetu kind, - [Lvar v; - Lconst(Const_base(Const_int pos)); - transl_exp arg]), - fill_fields (pos+1) rem) in - Llet(Strict, v, - Lprim(Pccall prim_makearray, - [Lconst(Const_base(Const_int len)); - transl_exp (List.hd expr_list)]), - fill_fields 1 (List.tl expr_list)) - end + Lprim(Pmakearray (array_kind e), transl_list expr_list) | Texp_ifthenelse(cond, ifso, Some ifnot) -> Lifthenelse(transl_exp cond, event_before ifso (transl_exp ifso), @@ -818,6 +842,8 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = end else begin (* Take a shallow copy of the init record, then mutate the fields of the copy *) + (* If you change anything here, you will likely have to change + [check_recursive_recordwith] in this file. *) let copy_id = Ident.create "newrecord" in let rec update_field (lbl, expr) cont = let upd = |