Commits

Anonymous committed 8485a66

Got a very simple primitive function (dbl+) generating LLVM code.

Comments (0)

Files changed (6)

blub_environment.ml

   let mkglobal name = Blub_common.mkglobal name ;;
 
   let set_pfn env fn name =
-    bind env (mkglobal name) (Spfn fn)
+    bind env (mkglobal name) (Spfn { prim_bc = fn;
+				     prim_llvm = None;
+				     prim_type = None } )
   ;;
 
   let set_pf0 env fn name =
     let wrapper = function
 	[|  |] -> fn ()
     in
-    bind env (mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn { prim_bc = wrapper;
+				     prim_llvm = None;
+				     prim_type = None } )
   ;;
   let set_pf1 env fn name =
     let wrapper = function
 	[| arg |] -> fn arg
     in
-    bind env (mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn { prim_bc = wrapper;
+				     prim_llvm = None;
+				     prim_type = None } )
   ;;
 
-  let set_pf2 env fn name =
+  let set_pf2 env fn ?type_ ?llvm name =
     let wrapper = function
 	[| arg1; arg2 |] -> fn arg1 arg2
     in
-    bind env (mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn { prim_bc = wrapper;
+				     prim_llvm = llvm;
+				     prim_type = type_ } )
   ;;
 
   let set_pf3 env fn name =
     let wrapper = function
 	[| arg1; arg2; arg3 |] -> fn arg1 arg2 arg3
     in
-    bind env (mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn { prim_bc = wrapper;
+				     prim_llvm = None;
+				     prim_type = None } )
   ;;
 
   let set_pfe env fn name =
 	  Some fn -> fn
 	| None -> assert false
     end
+
   | s ->
       let msg = 
 	fprintf str_formatter "Converting %a to llvalue not supported yet" 
 	      (tmp, builder) exprs 
 	  in
 	  result
+
+      | A_app (A_ref var, args) -> begin
+	  let fn = match Env.find globals env var with
+	      Gbinding idx -> globals.vals.(idx)
+	    | Lbinding (f, idx) -> (List.nth env f).vals.(idx)
+	  in
+	  let args, builder = Array.fold_right 
+	    (fun arg (result, builder) ->
+	       let r, builder = gen_llvm builder arg in
+	       (r :: result, builder))
+	    args ([], builder)
+	  in
+	  let llvalue = match fn with
+	      Spfn { prim_llvm = Some llvm_gen_fn } ->
+		llvm_gen_fn builder args
+	      
+	  in
+	  llvalue, builder
+	  
+
+	end
+	  
   in
   let llvalue, builder = gen_llvm builder body in
   ignore (build_ret llvalue builder);
 ;;
 
 let init e =
+  let mk_dbl_bin op name =
+    let bin_op (Sfloat a) (Sfloat b) = Sfloat (op a b) in
+    set_pf2 e bin_op 
+      ~type_:(Fun ([|Float64; Float64|], Float64)) 
+      ~llvm:(fun builder (arg1 :: arg2 :: []) -> 
+	       Llvm.build_add arg1 arg2 "" builder)
+      name
+  in
+
+  List.iter2 mk_dbl_bin 
+    [(+.); (-.); ( *. ); (/.)]
+    ["dbl+"; "dbl-"; "dbl*"; "dbl/"];
+
   set_pfn e addn "+";
   set_pf1 e add1 "add1";
   set_pfn e subn "-";

blub_typecheck.ml

 	  exprs TypeVarSet.empty
     | A_abs (_, _, body) ->
 	TypeVarSet.union (unsolved type_) (all_unsolved tmap body)
+    | A_app (fn, args) ->
+	let tmp = Array.fold_right (fun expr acc ->
+				      TypeVarSet.union (all_unsolved tmap expr)
+					acc)
+	  args (all_unsolved tmap fn)
+	in
+	TypeVarSet.union (unsolved type_) tmp
 
 ;;
 
 	     (type_of_sval v.(0))
 	     v)
   | Sunbound -> typevar ()
+  | Spfn { prim_type = Some t } -> t
   | x -> 
       printf "Unsupported sval %a\n%!" pp_sval x;
       typevar ()
   | Strue | Sfalse | Snull | Sunbound
   | Sclosure of sclosure
   | Sjitclosure of jitcode
-  | Spfn of (sval array -> sval)
+  | Spfn of sprimitive
   | Spfe of (env_frame -> environment -> sval array -> stack_frame list -> sval)
   | Sstring of string
   | Schar of char
     Dynload of string * string * type_ (* module name; fn name *)
   | Jitcode of Llvm.llvalue * type_ (* code; return type *)
 
+and sprimitive = { prim_bc : sval array -> sval;
+		   prim_type : type_ option;
+		   prim_llvm : (Llvm.llbuilder -> Llvm.llvalue list -> Llvm.llvalue) option }
+
 and ast =
     A_lit of sval
   | A_ref of variable
 		 Blub_closure.VarSet.add var acc)
 	      params Blub_closure.VarSet.empty 
 	    in
-	    let () = try
+
+	    let bound_vars = Array.fold_right Blub_closure.VarSet.add
+	      globals.vars bound_vars
+	    in
+
+	    let () =
 	      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;
 		lambda.lam_jitcode <- ([||], llvm_code) :: lambda.lam_jitcode
 	      end;
 	      ()
-	    with _ -> printf "Something went wrong!\n%!"
 	    in
 	    B_abs (lambda , next)
 
 	  let result = Blub_llvm.execute_function closure rib in
 	  eval result globals env rib stack B_ret
 
-      | Spfn fn ->
+      | Spfn { prim_bc = fn } ->
 	  eval (fn rib) globals env rib stack B_ret
       | Spfe fn -> fn globals env rib stack
       | x ->