WIP: back port a escape bug fix from trunk and patch [+2 primitive caml_blit_bytes, caml_is_js ]

Author: bobzhang

.depend

@@ -19,7 +19,7 @@ include stdlib/StdlibModules
 
 CAMLC=$(CAMLRUN) boot/ocamlc -nostdlib -I boot
 CAMLOPT=$(CAMLRUN) ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
-COMPFLAGS=-strict-sequence -w +33..39+48+50 -warn-error A -bin-annot \
+COMPFLAGS=-strict-sequence -w +33..39+48+50 -w -40 -warn-error A -bin-annot \
           -safe-string $(INCLUDES)
 LINKFLAGS=
 
@@ -64,12 +64,12 @@ TYPING=typing/ident.cmo typing/path.cmo \
   typing/typemod.cmo
 
 COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
-  bytecomp/typeopt.cmo bytecomp/switch.cmo bytecomp/matching.cmo \
+  bytecomp/typeopt.cmo bytecomp/switch.cmo  bytecomp/matching.cmo \
   bytecomp/translobj.cmo bytecomp/translcore.cmo \
   bytecomp/translclass.cmo bytecomp/translmod.cmo \
   bytecomp/simplif.cmo bytecomp/runtimedef.cmo \
   driver/pparse.cmo driver/main_args.cmo \
-  driver/compenv.cmo driver/compmisc.cmo
+  driver/compenv.cmo driver/compmisc.cmo 
 
 COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP)
 

Makefile

@@ -119,7 +119,7 @@ let split_default_wrapper fun_id kind params body =
         let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in
         let map_param p = try List.assoc p map with Not_found -> p in
         let args = List.map (fun p -> Lvar (map_param p)) params in
-        let wrapper_body = Lapply (Lvar inner_id, args, Location.none) in
+        let wrapper_body = Lapply (Lvar inner_id, args, Lambda.default_apply_info ()) in
 
         let inner_params = List.map map_param params in
         let new_ids = List.map Ident.rename inner_params in
@@ -144,19 +144,19 @@ let split_default_wrapper fun_id kind params body =
 
 let prim_size prim args =
   match prim with
-    Pidentity -> 0
+  | (Pidentity | Pbytes_to_string | Pbytes_of_string | Pchar_to_int | Pchar_of_int | Pmark_ocaml_object) -> 0
   | Pgetglobal id -> 1
   | Psetglobal id -> 1
-  | Pmakeblock(tag, mut) -> 5 + List.length args
+  | Pmakeblock(tag, _, mut) -> 5 + List.length args
   | Pfield f -> 1
   | Psetfield(f, isptr) -> if isptr then 4 else 1
   | Pfloatfield f -> 1
   | Psetfloatfield f -> 1
   | Pduprecord _ -> 10 + List.length args
   | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
   | Praise _ -> 4
-  | Pstringlength -> 5
-  | Pstringrefs | Pstringsets -> 6
+  | Pstringlength | Pbyteslength -> 5
+  | Pstringrefs | Pstringsets | Pbytesrefs | Pbytessets -> 6
   | Pmakearray kind -> 5 + List.length args
   | Parraylength kind -> if kind = Pgenarray then 6 else 2
   | Parrayrefu kind -> if kind = Pgenarray then 12 else 2
@@ -241,6 +241,7 @@ let rec is_pure_clambda = function
   | Uconst _ -> true
   | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
            Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
+           Pbytessetu | Pbytessets |
            Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
   | Uprim(p, args, _) -> List.for_all is_pure_clambda args
   | _ -> false
@@ -453,7 +454,7 @@ let field_approx n = function
 let simplif_prim_pure fpc p (args, approxs) dbg =
   match p, args, approxs with
   (* Block construction *)
-  | Pmakeblock(tag, Immutable), _, _ ->
+  | Pmakeblock(tag, _, Immutable), _, _ ->
       let field = function
         | Value_const c -> c
         | _ -> raise Exit
@@ -475,10 +476,10 @@ let simplif_prim_pure fpc p (args, approxs) dbg =
     when n < List.length ul ->
       (List.nth ul n, field_approx n approx)
   (* Strings *)
-  | Pstringlength, _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] ->
+  | (Pstringlength | Pbyteslength), _, [ Value_const(Uconst_ref(_, Uconst_string s)) ] ->
       make_const_int (String.length s)
   (* Identity *)
-  | Pidentity, [arg1], [app1] ->
+  | (Pidentity | Pbytes_of_string | Pbytes_to_string | Pchar_to_int | Pchar_of_int | Pmark_ocaml_object), [arg1], [app1] ->
       (arg1, app1)
   (* Kind test *)
   | Pisint, _, [a1] ->
@@ -508,7 +509,7 @@ let simplif_prim fpc p (args, approxs as args_approxs) dbg =
     (* XXX : always return the same approxs as simplif_prim_pure? *)
     let approx =
       match p with
-      | Pmakeblock(_, Immutable) ->
+      | Pmakeblock(_, _, Immutable) ->
           Value_tuple (Array.of_list approxs)
       | _ ->
           Value_unknown
@@ -640,8 +641,8 @@ let rec bind_params_rec fpc subst params args body =
         let p1' = Ident.rename p1 in
         let u1, u2 =
           match Ident.name p1, a1 with
-          | "*opt*", Uprim(Pmakeblock(0, Immutable), [a], dbg) ->
-              a, Uprim(Pmakeblock(0, Immutable), [Uvar p1'], dbg)
+          | "*opt*", Uprim(Pmakeblock(0, tag_info, Immutable), [a], dbg) ->
+              a, Uprim(Pmakeblock(0, tag_info, Immutable), [Uvar p1'], dbg)
           | _ ->
               a1, Uvar p1'
         in
@@ -666,6 +667,7 @@ let rec is_pure = function
   | Lconst cst -> true
   | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
            Pccall _ | Praise _ | Poffsetref _ | Pstringsetu | Pstringsets |
+           Pbytessetu | Pbytessets |
            Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false
   | Lprim(p, args) -> List.for_all is_pure args
   | Levent(lam, ev) -> is_pure lam
@@ -791,8 +793,8 @@ let rec close fenv cenv = function
       let rec transl = function
         | Const_base(Const_int n) -> Uconst_int n
         | Const_base(Const_char c) -> Uconst_int (Char.code c)
-        | Const_pointer n -> Uconst_ptr n
-        | Const_block (tag, fields) ->
+        | Const_pointer (n,_) -> Uconst_ptr n
+        | Const_block (tag, _, fields) ->
             str (Uconst_block (tag, List.map transl fields))
         | Const_float_array sl ->
             (* constant float arrays are really immutable *)
@@ -818,7 +820,7 @@ let rec close fenv cenv = function
       let nargs = List.length args in
       begin match (close fenv cenv funct, close_list fenv cenv args) with
         ((ufunct, Value_closure(fundesc, approx_res)),
-         [Uprim(Pmakeblock(_, _), uargs, _)])
+         [Uprim(Pmakeblock(_,_,  _), uargs, _)])
         when List.length uargs = - fundesc.fun_arity ->
           let app = direct_apply fundesc funct ufunct uargs in
           (app, strengthen_approx app approx_res)
@@ -913,7 +915,7 @@ let rec close fenv cenv = function
       end
   | Lprim(Pdirapply loc,[funct;arg])
   | Lprim(Prevapply loc,[arg;funct]) ->
-      close fenv cenv (Lapply(funct, [arg], loc))
+      close fenv cenv (Lapply(funct, [arg], Lambda.default_apply_info ~loc ()))
   | Lprim(Pgetglobal id, []) as lam ->
       check_constant_result lam
                             (getglobal id)

asmcomp/closure.ml

@@ -635,7 +635,7 @@ let rec expr_size env = function
       expr_size (Ident.add id (expr_size env exp) env) body
   | Uletrec(bindings, body) ->
       expr_size env body
-  | Uprim(Pmakeblock(tag, mut), args, _) ->
+  | Uprim(Pmakeblock(tag,_,  mut), args, _) ->
       RHS_block (List.length args)
   | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) ->
       RHS_block (List.length args)
@@ -1020,7 +1020,7 @@ let check_bound unsafe dbg a1 a2 k =
 
 let default_prim name =
   { prim_name = name; prim_arity = 0 (*ignored*);
-    prim_alloc = true; prim_native_name = ""; prim_native_float = false }
+    prim_alloc = true; prim_native_name = ""; prim_native_float = false ; prim_attributes = [] ; prim_ty = None}
 
 let simplif_primitive_32bits = function
     Pbintofint Pint64 -> Pccall (default_prim "caml_int64_of_int")
@@ -1385,9 +1385,9 @@ let rec transl = function
       begin match (simplif_primitive prim, args) with
         (Pgetglobal id, []) ->
           Cconst_symbol (Ident.name id)
-      | (Pmakeblock(tag, mut), []) ->
+      | (Pmakeblock(tag, _, mut), []) ->
           assert false
-      | (Pmakeblock(tag, mut), args) ->
+      | (Pmakeblock(tag,_, mut), args) ->
           make_alloc tag (List.map transl args)
       | (Pccall prim, args) ->
           if prim.prim_native_float then
@@ -1555,7 +1555,7 @@ let rec transl = function
 and transl_prim_1 p arg dbg =
   match p with
   (* Generic operations *)
-    Pidentity ->
+  | (Pidentity | Pbytes_to_string | Pbytes_of_string | Pchar_to_int | Pchar_of_int | Pmark_ocaml_object) ->
       transl arg
   | Pignore ->
       return_unit(remove_unit (transl arg))
@@ -1607,7 +1607,7 @@ and transl_prim_1 p arg dbg =
   | Pabsfloat ->
       box_float(Cop(Cabsf, [transl_unbox_float arg]))
   (* String operations *)
-  | Pstringlength ->
+  | (Pstringlength | Pbyteslength) ->
       tag_int(string_length (transl arg))
   (* Array operations *)
   | Parraylength kind ->
@@ -1732,10 +1732,10 @@ and transl_prim_2 p arg1 arg2 dbg =
                   [transl_unbox_float arg1; transl_unbox_float arg2]))
 
   (* String operations *)
-  | Pstringrefu ->
+  | (Pstringrefu | Pbytesrefu) ->
       tag_int(Cop(Cload Byte_unsigned,
                   [add_int (transl arg1) (untag_int(transl arg2))]))
-  | Pstringrefs ->
+  | (Pstringrefs | Pbytesrefs) ->
       tag_int
         (bind "str" (transl arg1) (fun str ->
           bind "index" (untag_int (transl arg2)) (fun idx ->
@@ -1892,11 +1892,11 @@ and transl_prim_2 p arg1 arg2 dbg =
 and transl_prim_3 p arg1 arg2 arg3 dbg =
   match p with
   (* String operations *)
-    Pstringsetu ->
+  | (Pstringsetu | Pbytessetu) ->
       return_unit(Cop(Cstore Byte_unsigned,
                       [add_int (transl arg1) (untag_int(transl arg2));
                         untag_int(transl arg3)]))
-  | Pstringsets ->
+  | (Pstringsets | Pbytessets) ->
       return_unit
         (bind "str" (transl arg1) (fun str ->
           bind "index" (untag_int (transl arg2)) (fun idx ->

asmcomp/cmmgen.ml

@@ -149,7 +149,7 @@ let rec size_of_lambda = function
       end
   | Llet(str, id, arg, body) -> size_of_lambda body
   | Lletrec(bindings, body) -> size_of_lambda body
-  | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args)
+  | Lprim(Pmakeblock(tag, _, mut), args) -> RHS_block (List.length args)
   | Lprim (Pmakearray (Paddrarray|Pintarray), args) ->
       RHS_block (List.length args)
   | Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args)
@@ -300,7 +300,7 @@ let comp_primitive p args =
     Pgetglobal id -> Kgetglobal id
   | Psetglobal id -> Ksetglobal id
   | Pintcomp cmp -> Kintcomp cmp
-  | Pmakeblock(tag, mut) -> Kmakeblock(List.length args, tag)
+  | Pmakeblock(tag, _, mut) -> Kmakeblock(List.length args, tag)
   | Pfield n -> Kgetfield n
   | Psetfield(n, ptr) -> Ksetfield n
   | Pfloatfield n -> Kgetfloatfield n
@@ -335,11 +335,11 @@ let comp_primitive p args =
   | Pfloatcomp Cgt -> Kccall("caml_gt_float", 2)
   | Pfloatcomp Cle -> Kccall("caml_le_float", 2)
   | Pfloatcomp Cge -> Kccall("caml_ge_float", 2)
-  | Pstringlength -> Kccall("caml_ml_string_length", 1)
-  | Pstringrefs -> Kccall("caml_string_get", 2)
-  | Pstringsets -> Kccall("caml_string_set", 3)
-  | Pstringrefu -> Kgetstringchar
-  | Pstringsetu -> Ksetstringchar
+  | Pstringlength | Pbyteslength  -> Kccall("caml_ml_string_length", 1)
+  | Pstringrefs | Pbytesrefs -> Kccall("caml_string_get", 2)
+  | Pstringsets | Pbytessets -> Kccall("caml_string_set", 3)
+  | Pstringrefu | Pbytesrefu -> Kgetstringchar
+  | Pstringsetu | Pbytessetu -> Ksetstringchar
   | Pstring_load_16(_) -> Kccall("caml_string_get16", 2)
   | Pstring_load_32(_) -> Kccall("caml_string_get32", 2)
   | Pstring_load_64(_) -> Kccall("caml_string_get64", 2)
@@ -555,13 +555,13 @@ let rec comp_expr env exp sz cont =
         in
         comp_init env sz decl_size
       end
-  | Lprim(Pidentity, [arg]) ->
+  | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string | Pchar_to_int | Pchar_of_int | Pmark_ocaml_object), [arg]) ->
       comp_expr env arg sz cont
   | Lprim(Pignore, [arg]) ->
       comp_expr env arg sz (add_const_unit cont)
   | Lprim(Pdirapply loc, [func;arg])
   | Lprim(Prevapply loc, [arg;func]) ->
-      let exp = Lapply(func, [arg], loc) in
+      let exp = Lapply(func, [arg], Lambda.default_apply_info ~loc ()) in
       comp_expr env exp sz cont
   | Lprim(Pnot, [arg]) ->
       let newcont =

boot/ocamlc

@@ -50,7 +50,7 @@ exception AsInt
 let const_as_int = function
   | Const_base(Const_int i) -> i
   | Const_base(Const_char c) -> Char.code c
-  | Const_pointer i -> i
+  | Const_pointer (i,_) -> i
   | _ -> raise AsInt
 
 let is_immed i = immed_min <= i && i <= immed_max
@@ -210,11 +210,11 @@ let emit_instr = function
           else (out opCONSTINT; out_int i)
       | Const_base(Const_char c) ->
           out opCONSTINT; out_int (Char.code c)
-      | Const_pointer i ->
+      | Const_pointer (i,_) ->
           if i >= 0 && i <= 3
           then out (opCONST0 + i)
           else (out opCONSTINT; out_int i)
-      | Const_block(t, []) ->
+      | Const_block(t,_, []) ->
           if t = 0 then out opATOM0 else (out opATOM; out_int t)
       | _ ->
           out opGETGLOBAL; slot_for_literal sc
@@ -336,11 +336,11 @@ let rec emit = function
           else (out opPUSHCONSTINT; out_int i)
       | Const_base(Const_char c) ->
           out opPUSHCONSTINT; out_int(Char.code c)
-      | Const_pointer i ->
+      | Const_pointer (i,_) ->
           if i >= 0 && i <= 3
           then out (opPUSHCONST0 + i)
           else (out opPUSHCONSTINT; out_int i)
-      | Const_block(t, []) ->
+      | Const_block(t,_, []) ->
           if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
       | _ ->
           out opPUSHGETGLOBAL; slot_for_literal sc