Commits

Anonymous committed 8943efc

Hacked up a version that will actually invoke the LLVM execution engine. Identity function lives!

  • Participants
  • Parent commits b3f4334

Comments (0)

Files changed (4)

File blub_common.ml

       in
       fprintf f "(%a)" pp_pair p
     end
+  | Sjitclosure _ -> fprintf f "<#llvm>"
   | Snull -> fprintf f "<#null>"
   | Svector _ -> fprintf f "<#vector>"
   | Sstring s -> fprintf f "\"%s\"" s

File blub_llvm.ml

 let gval_of_sval = function
     Sfalse -> GenericValue.of_int (lltype_of_type Bool) 0
   | Sint x -> GenericValue.of_int (lltype_of_type Int) x
+  | Sfloat x -> GenericValue.of_float (lltype_of_type Float64) x
   | _ -> assert false (* TODO no others supported yet *)
 ;;
 
   | Sint x -> const_int lltype x
   | Sfloat x -> const_float lltype x
   | Ssymbol s -> const_array i8_type (convert_string s)
-  | Sjitclosure (Jitcode fn_name) -> begin
+  | Sjitclosure Jitcode (code, t) -> 
+      (* TODO unify t and type_ *)
+      code
+  | Sjitclosure Dynload (_, fn_name, t) -> begin
+      (* TODO unify t and type_ *)
       match lookup_function fn_name m with
 	  Some fn -> fn
 	| None -> assert false
 let jit_compile name globals env ast typeinfo =
   let current_module = m in
   let type_ = get_type typeinfo ast in
+
+  let rettype = match type_ with
+      Fun (_, tret) -> tret
+    | _ -> assert false
+  in
+
   let current_function = define_function name (function_sig type_) 
     current_module 
   in
   let rec gen_llvm (builder:llbuilder) (ast:ast) : (llvalue * llbuilder) = 
     let type_ = get_type typeinfo ast in
     printf "compiling %a => type %a\n%!" pp_ast ast pp_type type_;
+
     (* NOTE shouldn't really do this every time through the loop *)
     Llvm_bitwriter.write_bitcode_file current_module "bitcode.bc";
 
   let llvalue, builder = gen_llvm builder body in
   ignore (build_ret llvalue builder);
   Llvm_bitwriter.write_bitcode_file m "bitcode.bc";
-  printf "FINISHED LLVM COMPILING\n%!"
+  printf "FINISHED LLVM COMPILING\n%!";
+  Jitcode (current_function, rettype)
 ;;
 
 (*
   ExecutionEngine.run_static_ctors jit
 
 
-let execute_function fn_type fn_name (args:sval array) =
+let execute_function closure (args:sval array) =
   (* Execute the function and convert the result *)
-  match fn_type with
-      Fun (arg_types, ret_type) ->
+  let fn, ret_type = match closure with
+      Jitcode (fn, ret_type) -> fn, ret_type
+    | Dynload (_, fn_name, ret_type) ->
 	let Some f = ExecutionEngine.find_function fn_name jit in
-	let args = Array.map gval_of_sval args in
-	let result = ExecutionEngine.run_function f args jit in
-	construct_sval ret_type result
-    | t ->
-	printf "Trying to jit-invoke other than a function %a" pp_type t;
-	assert false
+	f, ret_type
+  in
+
+  let args = Array.map gval_of_sval args in
+  let result = ExecutionEngine.run_function fn args jit in
+  let result = construct_sval ret_type result in
+  printf "LLVM COMPLETED EXECUTION: %a\n%!" pp_sval result;
+  result
 	
 
    (* Tear down the JIT.

File blub_types.mli

 	       lam_varargs : bool;
 	       lam_ast : ast;  (* AST of the lambda body *)
 	       lam_bytecode : bytecode;
-	       mutable lam_jitcode : (type_ array, string) PMap.t }
+	       mutable lam_jitcode : (type_ array * jitcode) list }
 
 and sval =
     Ssymbol of string
   | Spair of spair
   | Strue | Sfalse | Snull | Sunbound
   | Sclosure of sclosure
-  | Sjitclosure of sjitclosure
+  | Sjitclosure of jitcode
   | Spfn of (sval array -> sval)
   | Spfe of (env_frame -> environment -> sval array -> stack_frame list -> sval)
   | Sstring of string
 
 and sclosure = environment * lambda
 
-and sjitclosure = Jitcode of string  (* fn name *)
+and jitcode = 
+    Dynload of string * string * type_ (* module name; fn name *)
+  | Jitcode of Llvm.llvalue * type_ (* code; return type *)
 
 and ast =
     A_lit of sval
 			   lam_varargs = varargs;
 			   lam_ast = body;
 			   lam_bytecode = code;
-			   lam_jitcode = PMap.empty } in
+			   lam_jitcode = [] } in
 
 	    (* Gather up all the free variables... not currently used for
 	       anything, and this stage maybe should be deferred. *)
 
 	      if (num_free = 0) && (num_unsolved = 0) then begin
 		let llvm_code = Blub_llvm.jit_compile "foofoo" globals env ast tmap in
-		lambda.lam_jitcode <- 
-		  PMap.add [||] "foofoo" lambda.lam_jitcode
+		lambda.lam_jitcode <- ([||], llvm_code) :: lambda.lam_jitcode
 	      end;
 	      ()
 	    with _ -> printf "Something went wrong!\n%!"
 	  let next = if acc == Sfalse then falseb else trueb in
 	  eval acc globals env rib stack next
       | B_abs (abs, next) -> begin
-	  let closure = Sclosure (env, abs) in
-	  eval closure globals env rib stack next
-		
+	  if abs.lam_jitcode = [] then
+	    let closure = Sclosure (env, abs) in
+	    eval closure globals env rib stack next
+	  else
+	    (* choose some jitcode at random :-) *)
+	    let (_, tmp) :: _ = abs.lam_jitcode in
+	    let closure = Sjitclosure tmp in
+	    eval closure globals env rib stack next
 	end
       | B_ret ->
 	  let frame :: stack = stack in
 		      lam_varargs = false;
 		      lam_ast = A_lit (Sunbound);
 		      lam_bytecode = body;
-		      lam_jitcode = PMap.empty } in
+		      lam_jitcode = [] } in
 	  let acc = Sclosure ([], abs) in
 	  eval acc globals env rib stack x
 	    
 	  let env = frame :: env in
 	  eval acc globals env rib stack body
 
+      | Sjitclosure closure ->
+	  let result = Blub_llvm.execute_function closure rib in
+	  eval result globals env rib stack B_ret
+
       | Spfn fn ->
 	  eval (fn rib) globals env rib stack B_ret
       | Spfe fn -> fn globals env rib stack