Commits

Keigo Imai committed b435769

workaround for DalvikVM object initialization bug http://code.google.com/p/android/issues/detail?id=13832

  • Participants
  • Parent commits 86225d5

Comments (0)

Files changed (3)

File ojacare/src/camlgen/mlClass.ml

   if callback then List.map make (List.filter (fun cl -> not (Ident.is_interface cl.cc_ident) && cl.cc_callback) cl_list)
   else List.map make cl_list
 
-(** Allocation *******************************************)
-let make_alloc cl_list =
-  let make cl acc =
-    if Ident.is_interface cl.cc_ident then
-      acc
-    else
-      let jclazz = Ident.get_class_java_signature cl.cc_ident in
-      <:str_item< value $lid:Ident.get_class_ml_allocator_name cl.cc_ident$ = 
-      let clazz = Jni.find_class $str:jclazz$ in
-      fun () -> ( Jni.alloc_object clazz : $lid:Ident.get_class_ml_jni_type_name cl.cc_ident$) >> :: acc
-  in
-  <:str_item< declare $list:List.fold_right make cl_list [] $ end >>
-
-let make_alloc_stub cl_list =
-  let make cl =
-    let jclazz = Ident.get_class_java_stub_signature cl.cc_ident in
-    let err = "Class not found : "^
-      Ident.get_class_java_qualified_stub_name cl.cc_ident ^"." in
-
-    <:str_item< value $lid:Ident.get_class_ml_stub_allocator_name cl.cc_ident$ = 
-      let clazz = try Jni.find_class $str:jclazz$ 
-      with _ -> failwith $str:err$ in
-        fun () -> ( Jni.alloc_object clazz : $lid:Ident.get_class_ml_jni_type_name cl.cc_ident$) >>
-  in
-  <:str_item< declare $list:List.map make  (List.filter (fun cl -> cl.cc_callback ) cl_list) $ end >>
 
 (** capsule / souche *************************************)
 let make_wrapper ~callback cl_list =
-  let clazz = "clazz"
-  and java_obj = "jni_ref" in
+  let java_obj = "jni_ref" in
   let make cl =
 
     let abstract = callback in
 
-    let jclazz = Ident.get_class_java_signature cl.cc_ident (* si 'callback' aussi, car les appel font du ping-pong *) 
+    let clazz = Ident.get_class_ml_ref cl.cc_ident
+    and jclazz = Ident.get_class_java_signature cl.cc_ident (* si 'callback' aussi, car les appel font du ping-pong *) 
     and class_name = 
       if callback then Ident.get_class_ml_stub_wrapper_name cl.cc_ident
       else Ident.get_class_ml_wrapper_name cl.cc_ident in
     (* m�thode h�rit� *)
     let class_decl = 
         (*   if callback then *)
-      <:class_str_item< inherit JniHierarchy.top $lid:java_obj$ >> :: class_decl 
+      let top = if callback then "top_lazy" else "top" in
+      <:class_str_item< inherit $list:["JniHierarchy";top]$ $lid:java_obj$ >> :: class_decl 
         (* else (match cl.cc_extend with
 	   None -> <:class_str_item< inherit JniHierarchy.top $lid:java_obj$ >>
 	   | Some super -> 
 	   let super_name = Ident.get_class_ml_wrapper_name super.cc_ident in
 	   <:class_str_item< inherit $lid:super_name$ $lid:java_obj$ >>) :: class_decl *) 
     in
+    let forced = if callback then <:expr< Lazy.force $lid:java_obj$ >> else <:expr< $lid:java_obj$ >> in
     let class_decl = 
       (* if callback then   *)
         (* TODO downcast jni *)  
 	List.fold_right (fun cl class_decl -> 
-	  <:class_str_item< method $lid:Ident.get_class_ml_jni_accessor_method_name cl.cc_ident$ = $lid:java_obj$ >> 
+	  <:class_str_item< method $lid:Ident.get_class_ml_jni_accessor_method_name cl.cc_ident$ = $forced$ >> 
 	    :: class_decl)  cl.cc_all_inherited class_decl 
 	(* else List.rev_append 
 	   (List.map (fun interface -> let interface_name = Ident.get_class_ml_wrapper_name interface.cc_ident in 
 
     (* m�thode accesseur Jni *)
     let class_decl = 
-      <:class_str_item< method $lid:Ident.get_class_ml_jni_accessor_method_name cl.cc_ident$ = $lid:java_obj$ >> 
+      <:class_str_item< method $lid:Ident.get_class_ml_jni_accessor_method_name cl.cc_ident$ = $forced$ >> 
 	:: class_decl in
 
     (* m�thodes IDL *)
     let method_ids, methods = 
-     (* if callback then *) MlMethod.make_dyn clazz java_obj ~callback:callback cl.cc_public_methods
+     (* if callback then *) MlMethod.make_dyn clazz forced ~callback:callback cl.cc_public_methods
      (* else MlMethod.make_dyn clazz java_obj ~callback:callback cl.cc_methods *)
     in
     let class_decl = List.rev_append methods class_decl in
       <:class_expr< object (self) $list:class_decl$ end  >> in
     
     (* test si l'objet est nul ... *)
-    let class_body = 
+(*    let class_body = 
       <:class_expr< let _ = 
          if Jni.is_null $lid:java_obj$ 
-	 then raise (JniHierarchy.Null_object $str:jclazz$) else () in $class_body$ >> in
+	 then raise (JniHierarchy.Null_object $str:jclazz$) else () in $class_body$ >> in *)
 
     (* fonction de cr�ation, � partir d'une r�f�rence Jni *)
     let class_body = 
-      <:class_expr< fun ($lid:java_obj$ : $lid:Ident.get_class_ml_jni_type_name cl.cc_ident$) -> $class_body$  >> in 
+      if callback then
+      <:class_expr< 
+        fun ($lid:java_obj$ : lazy_t $lid:Ident.get_class_ml_jni_type_name cl.cc_ident$) -> $class_body$  >>
+      else
+      <:class_expr< 
+        fun ($lid:java_obj$ : $lid:Ident.get_class_ml_jni_type_name cl.cc_ident$) -> $class_body$  >> in 
  
     (* D�claration des id. de m�thode et de champs (captur� dans l'env de la fonction de cr�ation) *)
     let class_body = MlGen.make_class_local_decl method_ids class_body in
 	in
 	<:class_expr< 
 	let _ = if not (Jni.is_assignable_from $lid:clazz$ 
-			(Jni.find_class $str: Ident.get_class_java_signature interface.cc_ident$))
+			$lid: Ident.get_class_ml_ref interface.cc_ident$)
 	then failwith $str:err$
 	else () in $body$ >>) cl.cc_implements class_body in
     
 	  in
 	  <:class_expr< 
 	  let _ = if not (Jni.is_assignable_from $lid:clazz$ 
-			  (Jni.find_class $str: Ident.get_class_java_signature super.cc_ident$))
+			  $lid: Ident.get_class_ml_ref super.cc_ident$)
 	  then failwith $str:err$
 	  else () in $class_body$ >> in
     
-    (* Chargement de l'objet classe Java : qui ne sera pas jamais d�charg� ... *)
-    let class_body = 
-      <:class_expr< let $lid:clazz$ = Jni.find_class $str:jclazz$ in $class_body$ >> in
-    
     (* Retour de 'make' : nom, abstract, body*)
     class_name,abstract,class_body 
   
     let name = Ident.get_class_ml_name cl.cc_ident 
     and tname = Ident.get_class_ml_jni_type_name cl.cc_ident 
     and java_name = Ident.get_class_java_signature cl.cc_ident in 
-    let err = "``cast error'' : "^name^" ("^(java_name)^")" in
-    let body = 
-      <:expr< if not (Jni.is_instance_of $lid:java_obj$ $lid:clazz$)
-      then failwith $str:err$ 
-      else (Obj.magic $lid:java_obj$ : $lid:tname$) >> in
+    let casterr = "``cast error'' : "^name^" ("^(java_name)^")" in
+    let notfounderr = "Class not found : "^
+      Ident.get_class_java_qualified_name cl.cc_ident ^"." in
+    let body =
+      <:expr< if not (Jni.is_instance_of 
+                       $lid:java_obj$ 
+                       $lid:Ident.get_class_ml_ref cl.cc_ident$)
+              then failwith $str:casterr$ 
+              else (Obj.magic $lid:java_obj$ : $lid:tname$) >> in
     let body = <:expr< fun ($lid:java_obj$ : Jni.obj) -> $body$ >> in
-    let err = "Class not found : "^
-      Ident.get_class_java_qualified_name cl.cc_ident ^"." in
-    let body = <:expr< let $lid:clazz$ = 
-      try Jni.find_class $str:java_name$ with
-     _ -> failwith $str:err$ in $body$ >> in
     let name = "_"^tname^"_of_jni_obj" in
     [<:str_item< value $lid:name$ = $body$ >>]
   in
 
 let make_instance_of cl_list =
   let java_obj = "java_obj" 
-  and obj ="o"
-  and clazz ="clazz" in
+  and obj ="o" in
   let make cl =
     let ml_name = Ident.get_class_ml_name cl.cc_ident in
     let body = 
-      <:expr< Jni.is_instance_of $lid:obj$#_get_jniobj $lid:clazz$ >> in
+      <:expr< Jni.is_instance_of $lid:obj$#_get_jniobj $lid:Ident.get_class_ml_ref cl.cc_ident$ >> in
     let body = <:expr< fun ($lid:obj$ : JniHierarchy.top) -> $body$ >> in
-    let body = <:expr< let $lid:clazz$ = Jni.find_class $str:Ident.get_class_java_signature cl.cc_ident$ in $body$ >> in
     let name = "_instance_of_"^ml_name in
     [<:str_item< value $lid:name$ = $body$ >>]
   in
     let obj = <:expr< $lid:"obj"$ >> in
     let body_new = <:expr< 
       fun size -> 
-	let java_obj = Jni.new_object_array size (Jni.find_class $str: Ident.get_class_java_signature cl.cc_ident $) in 
+	let java_obj = Jni.new_object_array size ($lid: Ident.get_class_ml_ref cl.cc_ident $) in 
 	new JniArray._Array 
 	  $lid:"Jni.get_object_array_element"$
 	  $lid:"Jni.set_object_array_element"$
       fun size -> fun f ->
 	let a = $lid:name_new$ size in
 	do { for i = 0 to pred size do { a#set i (f i) }; a } >> in
-     <:str_item< value $lid:name_new$ = $body_new$ >> :: <:str_item< value $lid:name_create$ = $body_create$ >> :: acc
+    let body_create = MlGen.make_local_decl [name_new,body_new] body_create in
+    <:str_item< value $lid:name_create$ = $body_create$ >> :: acc
   in
   <:str_item< declare $list:List.fold_right make cl_list []$ end >>
 
       JniArray.jArray $lid: Ident.get_class_ml_name cl.cc_ident$  >>
   in
   <:sig_item< declare $list:List.map make cl_list$ end >>
+
+let make_classref ~callback cl_list =
+  let make cl =
+    let c = cl.cc_ident in
+    let refname = if callback then Ident.get_class_ml_stub_ref c else Ident.get_class_ml_ref c in
+    let signature = if callback then Ident.get_class_java_stub_signature c else Ident.get_class_java_signature c in
+    <:str_item< 
+      value $lid:refname$ =
+        try Jni.find_class $str:signature$
+            with _ ->
+              failwith ("Class not found : " ^ $str:Ident.get_class_java_qualified_name c$)  >>
+  in
+  let cl_list = 
+    if callback 
+      then List.filter (fun cl -> cl.cc_callback ) cl_list
+      else cl_list in
+  List.map make cl_list
+

File ojacare/src/camlgen/mlClass.mli

 val make_class_type: callback:bool -> Cidl.clazz list -> (string * bool * MLast.class_type) list
 (** G�n�re le 'class type' de la classe : nom, abstract, ast *)
 
-val make_alloc: Cidl.clazz list -> MLast.str_item
-val make_alloc_stub: Cidl.clazz list -> MLast.str_item
 (** G�n�re les fonctions d'allocations d'objet java (interne) *)
 
 val make_wrapper: callback:bool -> Cidl.clazz list -> (string * bool * MLast.class_expr) list
 val make_array_sig: Cidl.clazz list -> MLast.sig_item
 (** Engendre les fonctions de conxtruction de tableaux *)
 
+val make_classref : callback:bool -> Cidl.clazz list -> MLast.str_item list

File ojacare/src/camlgen/mlInit.ml

 (*	$Id: mlInit.ml,v 1.4 2004/07/19 11:22:50 henry Exp $	*)
 
+(* keigoi's memo:
+Due to DalvikVM bug, (http://code.google.com/p/android/issues/detail?id=13832)
+we can't separate allocation and initialization. 
+Instead, we put the constructor-call in the lazy thunk so that 
+we get the (delayed) reference to Java object before initialization
+*)
+
 open Cidl
 
 let loc = Ploc.dummy;;
 let id = "__id"
 
 let make_fun ~callback cl_list =
-  let clazz = "clazz"
-  and java_obj = "java_obj" 
-  and id = "id" in
+  let id = "id" in
   let make_cl cl =   
     if Ident.is_interface cl.cc_ident && callback then
       let ml_name = Ident.get_class_ml_interface_init_name cl.cc_ident
       and java_name = "<init>"
       and targs = [Ccallback cl.cc_ident]
-      and jclazz = Ident.get_class_java_stub_signature cl.cc_ident in
+      and clazz = Ident.get_class_ml_stub_ref cl.cc_ident in
       let sign = MlType.java_signature targs Cvoid in
       
       let args = List.map2 (fun i t -> ("_p"^string_of_int i,t)) 
       let jargs = List.map (fun (narg,targ) -> 
 	<:expr< $lid:MlType.constructor_of_type targ$ $lid:narg$  >>) args in
       
-      let body = <:expr< Jni.call_nonvirtual_void_method 
-	  $lid:java_obj$ $lid:clazz$ $lid:id$ [| $list:jargs$ |] >> in
+      let body = <:expr< Jni.new_object $lid:clazz$ $lid:id$ [| $list:jargs$ |] >> in
       
       let body = MlGen.make_local_decl (MlType.get_args_convertion MlType.convert_to_java args) body in
+
       let body =
 	match args with 
 	  [] -> body
 	| args -> MlGen.make_fun args body in
-      let body = <:expr< fun ($lid:java_obj$ : $lid:Ident.get_class_ml_jni_type_name cl.cc_ident$) -> $body$ >> in
 
-      let id_expr = <:expr< Jni.get_methodID $lid:clazz$ $str:java_name$ $str:sign$ >> in
+      let id_expr = <:expr< (Jni.get_methodID $lid:clazz$ $str:java_name$ $str:sign$) >> in
 	  
-      let body = MlGen.make_local_decl 
-	  [id,id_expr;
-	   clazz, <:expr< Jni.find_class $str:jclazz$ >>] body in
+      let body = MlGen.make_local_decl [id,id_expr] body in
       [<:str_item< value $lid:ml_name$ = $body$>>]
     else 
       let make init acc =
 	  and targs = 	
 	    if callback then (Ccallback init.cmi_class)::init.cmi_args
 	    else init.cmi_args 
-	  and jclazz = 
-	    if callback then Ident.get_class_java_stub_signature init.cmi_class
-	    else Ident.get_class_java_signature init.cmi_class in
+	  and clazz = 
+	    if callback then Ident.get_class_ml_stub_ref init.cmi_class
+	    else Ident.get_class_ml_ref init.cmi_class in
 	  let sign = MlType.java_signature targs Cvoid in
 
 	  let args = List.map2 (fun i t -> ("_p"^string_of_int i,t)) 
 	  let jargs = List.map (fun (narg,targ) -> 
 	    <:expr< $lid:MlType.constructor_of_type targ$ $lid:narg$  >>) args in
 	  
-	  let body = <:expr< Jni.call_nonvirtual_void_method 
-	      $lid:java_obj$ $lid:clazz$ $lid:id$ [| $list:jargs$ |] >> in
+	  let body = <:expr< Jni.new_object $lid:clazz$ $lid:id$ [| $list:jargs$ |] >> in
 
 	  let body = MlGen.make_local_decl (MlType.get_args_convertion MlType.convert_to_java args) body in
+
+          let body = if callback then body else <:expr< fun ()-> $body$ >> in
+
 	  let body =
 	    match args with 
 	      [] -> body
 	    | args -> MlGen.make_fun args body in
-	  let body = <:expr< fun ($lid:java_obj$ : $lid:Ident.get_class_ml_jni_type_name init.cmi_class$)-> $body$ >> in
 
 	  let id_expr = <:expr< Jni.get_methodID $lid:clazz$ $str:java_name$ $str:sign$ >> in
 	  let err = "Unknown constructor from IDL in class \\\""^
 	    <:expr<try $id_expr$ with _ -> failwith $str:err$>> in
 
 	  let body = MlGen.make_local_decl 
-	      [id,safe_id_expr;
-	       clazz, <:expr< Jni.find_class $str:jclazz$ >>] body in
+	      [id,safe_id_expr] body in
 	  <:str_item< value $lid:ml_name$ = $body$>> :: acc
       in
       List.fold_right make cl.cc_inits []
   <:str_item< declare $list:init_funs$ end >>
 
 let make_class ~callback cl_list = 
-  let clazz = "clazz"
-  and java_obj = "java_obj" 
+  let java_obj = "java_obj" 
   and id = "id" in
   let make_cl cl =
     if Ident.is_interface cl.cc_ident && callback then 
       and targs = [] in
       let ml_init_name = Ident.get_class_ml_interface_init_name cl.cc_ident
       and class_wrapper_name = Ident.get_class_ml_stub_wrapper_name cl.cc_ident
-      and class_allocator_name = Ident.get_class_ml_stub_allocator_name cl.cc_ident
       in
       
-      let class_decl = [<:class_str_item< inherit $list:[class_wrapper_name]$ $lid:java_obj$ >>] in
-      let finit = <:expr< $lid:ml_init_name$ >> in
-      let class_decl =  
-	<:class_str_item< initializer $MlGen.make_call finit [java_obj;"(self :> "^ ml_name ^"(* not so good*) )"]$ >>
-	  :: class_decl
-      in
-      
+      let self = "self"
+      and self_ref = "rself" in
+      let class_decl = 
+	[ <:class_str_item< 
+          initializer ($lid:self_ref$.val := Some ($lid:ml_init_name$ ($lid:self$ :> $lid:Ident.get_class_ml_stub_name cl.cc_ident$)))
+          >> ] in
+
+      let class_decl = <:class_str_item< inherit $list:[class_wrapper_name]$ $lid:java_obj$ >> :: class_decl in
+
       let body = 
 	<:class_expr< 
-	object (self) $list:class_decl$
+	object ($lid:self$) $list:class_decl$
 	end >> in
       
+      let finit = <:expr< 
+           lazy (match $lid:self_ref$.val with 
+             [ Some self -> self 
+             | None -> failwith "ojacare2 : impossible" ] ) 
+         >> in
       let body = MlGen.make_class_local_decl 
-	  [java_obj,<:expr< $lid:class_allocator_name$ () >>] body in
+	  [java_obj, finit;
+           self_ref, <:expr< ref None >>;] body in
       
       let body = MlGen.make_class_fun [] body in
       [<:str_item< class virtual $lid:ml_name$ = $body$ >>]
  	    if callback then Ident.get_method_ml_stub_name init.cmi_ident
 	    else Ident.get_method_ml_name init.cmi_ident 
 	  and targs = init.cmi_args in
-	  let ml_init_name = Ident.get_method_ml_init_name init.cmi_ident 
-	  and class_wrapper_name = 
+	  let class_wrapper_name = 
 	    if callback then Ident.get_class_ml_stub_wrapper_name init.cmi_class 
-	    else Ident.get_class_ml_wrapper_name init.cmi_class 
-	  and class_allocator_name = 
-	    if callback then Ident.get_class_ml_stub_allocator_name init.cmi_class 
-	    else Ident.get_class_ml_allocator_name init.cmi_class in
+	    else Ident.get_class_ml_wrapper_name init.cmi_class in
 
 	  let nargs = List.map (fun i -> ("_p"^string_of_int i)) 
 	      (Utilities.interval 0 (List.length targs)) in
 	  let args = List.combine nargs targs in
 
-	  let class_decl = [<:class_str_item< inherit $list:[class_wrapper_name]$ $lid:java_obj$ >>] in
-	  let class_decl =  
-	    if callback then
-	      let finit = <:expr< $lid:Ident.get_method_ml_init_stub_name init.cmi_ident$ >> in
-	      <:class_str_item< initializer $MlGen.make_call finit (java_obj::("(self :> "^ ml_name ^")")::nargs)$ >>
-		:: class_decl
-	    else
-	      class_decl      
-	  in
+          let self = "self"
+          and self_ref = "rself" in
+          let class_decl = 
+            if callback then
+              let cstr = <:expr< $lid:Ident.get_method_ml_init_stub_name init.cmi_ident$ >> in
+              let call = MlGen.make_call cstr (<:expr< ($lid:self$ :> $lid:Ident.get_class_ml_stub_name cl.cc_ident$) >> :: List.map (fun s -> <:expr< $lid:s$ >>) nargs) in
+	      [ <:class_str_item< 
+                  initializer 
+                    ($lid:self_ref$.val := Some $call$)
+                >> ]
+            else [] in
+
+          let class_decl = <:class_str_item< inherit $list:[class_wrapper_name]$ $lid:java_obj$ >> :: class_decl in
 
 	  let body = 
 	    <:class_expr< 
-	    object (self) $list:class_decl$
+	    object ($lid:self$) $list:class_decl$
 	    end >> in
 
-	  let init_expr = MlGen.make_call <:expr< $lid:ml_init_name$>> (java_obj::nargs) in 
-	  let body = if callback then body else <:class_expr< let _ = $init_expr$ in $body$>> in 
-	  let body = MlGen.make_class_local_decl 
-	      [java_obj,<:expr< $lid:class_allocator_name$ () >>] body in
+	  let body = 
+            if callback then
+              let cstr_call = <:expr< 
+                   lazy (match $lid:self_ref$.val with 
+                     [ Some self -> self 
+                     | None -> failwith "ojacare2 : impossible" ] ) 
+                 >> in
+              MlGen.make_class_local_decl 
+	          [java_obj, cstr_call;
+                   self_ref, <:expr< ref None >>;] body 
+	    else
+	      let finit = <:expr< $lid:Ident.get_method_ml_init_name init.cmi_ident$ >> in
+              let cstr_call = MlGen.make_call finit ((List.map (fun s-> <:expr< $lid:s$ >>) nargs) @ [<:expr< ()>>]) in
+              MlGen.make_class_local_decl [java_obj, cstr_call] body 
+          in
 
 	  let body = MlGen.make_class_fun nargs body in