Commits

Anonymous committed b3f4334

The first little bit of LLVM compiling. Can compile ((lambda (x) x) 3.4)

Comments (0)

Files changed (2)

 ;;
 
 let get_type typeinfo (ast:ast) =
-  simplify_type (List.assq ast typeinfo)
+  simplify_type (PMap.find ast typeinfo)
 ;;
 
 
 (* NOTE env probably needs to be passed through gen_llvm *)
-let jit_compile name globals env abstraction typeinfo =
+let jit_compile name globals env ast typeinfo =
   let current_module = m in
-  let type_ = get_type typeinfo abstraction.lam_ast in
+  let type_ = get_type typeinfo ast in
   let current_function = define_function name (function_sig type_) 
     current_module 
   in
   set_function_call_conv CallConv.fast current_function;
   let builder = builder_at_end (entry_block current_function) in
+
+  (* probably need to do some stuff for the function header *)
+  let A_abs (params, false, body) = ast in
   
   let rec gen_llvm (builder:llbuilder) (ast:ast) : (llvalue * llbuilder) = 
     let type_ = get_type typeinfo ast in
-    printf "compiling %a" pp_ast ast;
-    printf " --> type %a\n%!" pp_type type_;
+    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";
 
     match ast with
 	A_lit l -> (llvalue_of_sval type_ l, builder)
 
+      | A_ref var when ExtArray.Array.mem var params ->
+	  let idx = ExtArray.Array.findi ((==) var) params in
+	  printf "GOT TO THIS POINT %d\n%!" idx;
+	  let llvalue = param current_function idx in
+	  llvalue, builder
+
       | A_ref var -> 
 	  (* In this case, we really hope the variable is not unbound right
 	     now, because that would be a problem... *)
 	  let return = build_phi [(v1, cons_block); (v2, alt_block)] 
 	    (label "phi") join_builder in
 	  (return, join_builder)
+
+      | A_seq exprs ->
+	  let tmp = undef i32_type in
+	  let result = 
+	    Array.fold_left (fun (last, builder) expr -> 
+			       gen_llvm builder expr) 
+	      (tmp, builder) exprs 
+	  in
+	  result
   in
-  gen_llvm builder abstraction.lam_ast
+  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%!"
 ;;
 
 (*
 	| A_seq exprs ->
 	    Array.fold_right (bc_compile env) exprs next
 	| A_abs (params, varargs, body) ->
+	    (* We will definitely compile the bytecode version of the function
+	       now.  If conditions are right, we might compile the native
+	       code version here as well. *)
+
+	    let frame = 
+	      { vars = params;
+		vals = Array.map (fun _ -> Sunbound) params } in
+	    let env = frame :: env in
+	    let code = bc_compile env body B_ret in
+	    let lambda = { lam_params = params;
+			   lam_varargs = varargs;
+			   lam_ast = body;
+			   lam_bytecode = code;
+			   lam_jitcode = PMap.empty } in
+
 	    (* Gather up all the free variables... not currently used for
 	       anything, and this stage maybe should be deferred. *)
 	    (* FIXME this is far from the full, true set of bound variables *)
 	    in
 	    let () = try
 	      let free_vars = Blub_closure.find_free bound_vars body in
-	      printf "Function has %d free variables\n%!" (Blub_closure.VarSet.cardinal free_vars);
+	      let num_free = Blub_closure.VarSet.cardinal free_vars in
+	      printf "Function has %d free variables\n%!" num_free;
+
 	      (* 
 		 Conditions for invoking LLVM right now:
 		 [1] no free variables
 		 [2] all type variables are bound to concrete types 
 	      *)
+
 	      let unsolved_typevars = Blub_typecheck.all_unsolved tmap ast in
-	      printf "Function has %d unsolved type variables\n%!" (Blub_typecheck.TypeVarSet.cardinal unsolved_typevars);
+	      let num_unsolved = Blub_typecheck.TypeVarSet.cardinal unsolved_typevars in
+	      printf "Function has %d unsolved type variables\n%!" num_unsolved;
+
+	      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
+	      end;
 	      ()
-	    with _ -> ()
+	    with _ -> printf "Something went wrong!\n%!"
 	    in
+	    B_abs (lambda , next)
 
-	    (* We will definitely compile the bytecode version of the function
-	       now.  If conditions are right, we might compile the native
-	       code version here as well. *)
-
-	    let frame = 
-	      { vars = params;
-		vals = Array.map (fun _ -> Sunbound) params } in
-	    let env = frame :: env in
-	    let code = bc_compile env body B_ret in
-
-	    (* NOTE that this is a completely deferred compilation, which will
-	       allow us to compile it in terms of the *live* environment rather
-	       than with everything unbound.  However, there are many cases
-	       where we would not gain any benefit from deferred compilation *)
-	    B_abs ( { lam_params = params;
-		      lam_varargs = varargs;
-		      lam_ast = body;
-		      lam_bytecode = code;
-		      lam_jitcode = PMap.empty }, next)
 	| A_app (fn, args) -> begin
 	    let c = bc_compile env fn B_apply in
 	    let _, n = Array.fold_left