Commits

Anonymous committed 793e1f5

Broke out the LLVM-compilation code; fixed some bugs in the revised typechecker; for some reason the 'fast' CallConv not working properly, so I disabled it for now.

  • Participants
  • Parent commits d667551

Comments (0)

Files changed (3)

File blub_llvm.ml

   let current_function = define_function "lambda" (function_sig type_) 
     current_module 
   in
-  set_function_call_conv CallConv.fast current_function;
+  (* 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 *)

File blub_typecheck.ml

 (* Not used by the typechecker itself, but for later; does this AST
    contain any unsolved type variables anywhere in it? *)
 let rec all_unsolved (tmap:(ast, type_) PMap.t) ast : TypeVarSet.t =
-  let type_ = PMap.find ast tmap in
+  let type_ = try
+    PMap.find ast tmap 
+  with Not_found ->
+    printf "Couldn't find the type of ast node: %a\n%!" pp_ast ast;
+    raise Not_found
+  in
   match ast with
       A_lit _ | A_ref _ -> unsolved type_
     | A_cnd (e1, e2, e3) ->
 	  let arg_typeinfo = Array.map (tcheck r) args in
 	  let fn_type, tmap = tcheck r fn in
 
-	  let () = match fn_type with
+	  let app_type = match fn_type with
 	      Fun (tparams, tret) -> 
 		assert ((Array.length tparams) = (Array.length args));
 		Array.iteri 
 		  (fun i (arg_type, _) -> 
 		     unify tparams.(i) arg_type) 
-		  arg_typeinfo
+		  arg_typeinfo;
+		tret
 
 	    | t ->
 		printf "App on unexpected type: %a" pp_type t;
 
 	  let tmap = Array.fold_right (fun (_, tmap) acc -> 
 					 tmap_union tmap acc)
-	    arg_typeinfo PMap.empty
+	    arg_typeinfo tmap
 	  in
-	  fn_type, tmap
+	  app_type, tmap
 	end
 
       | A_seq exprs ->
     | B_conti _ -> fprintf f "conti"
     | B_nuate _ -> fprintf f "nuate"
     | B_halt -> fprintf f "halt"
+  ;;
 
+  (* TODO need to be able to invoke this from the eval loop; the main
+     problem is the typechecking which has to be worked out.  Sometimes
+     you do better with the full program; sometimes you do better with
+     having local variables bound to values.  Is it possible to do an
+     incrementally improving type inference? *)
+
+  let llvm_compile tmap globals env lambda = 
+    let ast = A_abs (lambda.lam_params, lambda.lam_varargs, lambda.lam_ast) in
+
+    (* Gather up all the free variables. *)
+
+    (* Parameters will be bound when the function is called, of course. *)
+    let bound_vars = Array.fold_right 
+      (fun var acc ->
+	 Blub_closure.VarSet.add var acc)
+      lambda.lam_params Blub_closure.VarSet.empty 
+    in
+
+    (* Should only add other vars if bound to values *)
+    let add_bound_vars bound vars vals =
+      let rec iterate idx =
+	if idx < 0 then 
+          bound
+	else
+          if vals.(idx) != Sunbound then
+            Blub_closure.VarSet.add vars.(idx) (iterate (idx-1))
+          else
+            iterate (idx-1)
+      in
+      iterate (Array.length vars - 1)
+    in
+    
+    let bound_vars = add_bound_vars bound_vars globals.vars globals.vals in
+
+    let bound_vars = List.fold_right 
+      (fun frame bnd ->
+         add_bound_vars bnd frame.vars frame.vals)
+      env bound_vars
+    in  
+
+    let () = try
+      let free_vars = Blub_closure.find_free bound_vars lambda.lam_ast in
+      let num_free = Blub_closure.VarSet.cardinal free_vars in
+      printf "Function has %d free variables: %a\n%!" 
+	num_free (pp_list pp_var) (Blub_closure.VarSet.elements free_vars);
+      
+      (* 
+	 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
+      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 globals env ast tmap in
+	let Fun (argtypes, _) = PMap.find ast tmap in
+	
+	let argtypes = Array.map Blub_typecheck.simplify argtypes in
+	printf "Adding JITcode for argtypes %a\n%!"
+	  (pp_array pp_type) argtypes;
+
+	lambda.lam_jitcode <- 
+	  (argtypes, llvm_code) :: lambda.lam_jitcode
+      end;
+      ()
+    with 
+	Assert_failure (filename, line, _) ->
+	  printf "ASSERT FAILED in LLVM compile: %s:%d\n%!" 
+	    filename line
+      |	Not_found ->
+	  printf "Llvm compilation not successful\n%!"
+    in
+    ()
+  ;;
 
   let compile (globals:env_frame) (env:environment) (ast:ast) (next:bytecode) : bytecode =
     let tmap = try
 			   lam_bytecode = code;
 			   lam_jitcode = [] } 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 *)
-	    let bound_vars = Array.fold_right 
-	      (fun var acc ->
-		 Blub_closure.VarSet.add var acc)
-	      params Blub_closure.VarSet.empty 
-	    in
-
-	    let bound_vars = Array.fold_right Blub_closure.VarSet.add
-	      globals.vars bound_vars
-	    in
-
-	    let () = try
-	      let free_vars = Blub_closure.find_free bound_vars body in
-	      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
-	      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 globals env ast tmap in
-		let Fun (argtypes, _) = PMap.find ast tmap in
-
-		let argtypes = Array.map Blub_typecheck.simplify argtypes in
-		printf "Adding JITcode for argtypes %a\n%!"
-		  (pp_array pp_type) argtypes;
-
-		lambda.lam_jitcode <- 
-		  (argtypes, llvm_code) :: lambda.lam_jitcode
-	      end;
-	      ()
-	    with 
-		Assert_failure (filename, line, _) ->
-		  printf "ASSERT FAILED in LLVM compile: %s:%d\n%!" 
-		    filename line
-	      |	Not_found ->
-		  printf "Llvm compilation not successful\n%!"
-	    in
+	    llvm_compile tmap globals env lambda;
 	    B_abs (lambda , next)
 
 	| A_app (fn, args) -> begin