Commits

Anonymous committed 591a151

Getting the closure type more coherent; a few cleanups to prettify things.

  • Participants
  • Parent commits 5765237

Comments (0)

Files changed (4)

File blub_common.ml

 
 
 let rec pp_type f = function
-    Int -> fprintf f "Int"
-  | Bool -> fprintf f "Bool"
-  | Symbol -> fprintf f "Symbol"
-  | Float64 -> fprintf f "Float"
+    Int -> fprintf f "int"
+  | Bool -> fprintf f "bool"
+  | Symbol -> fprintf f "symbol"
+  | Float64 -> fprintf f "double"
   | VarArray t -> fprintf f "[%a]" pp_type t
   | Typevar (tv, id) -> begin
       match !tv with
 	  None -> fprintf f "'tv%d" id
 	| Some t -> pp_type f t
     end
-  | Fun (params, ret) -> fprintf f "Fun" (*FIXME*)
+  | Fun (params, ret) -> 
+      let params = Array.to_list params in
+      fprintf f "%a" (pp_list pp_type) (ret :: params)
 ;;
 
 let pp_var f var =
   | A_cnd (e1, e2, e3) -> 
       fprintf f "(if %a %a %a)" pp_ast e1 pp_ast e2 pp_ast e3;
   | A_seq exprs ->
-      (* FIXME *)
       let exprs = Array.to_list exprs in
-      fprintf f "(begin %a)" (pp_list pp_ast) exprs
+      fprintf f "(begin %a)" (_pp_list pp_ast) exprs
   | A_abs (vars, varargs, body) ->
       (* FIXME ; and what about varargs? *)
       let vars = Array.to_list vars in
-      fprintf f "(lambda (%a) %a)" (pp_list pp_var) vars pp_ast body
+      fprintf f "(lambda %a %a)" (pp_list pp_var) vars pp_ast body
   | A_app (fn, params) ->
-      (* FIXME *)
       let params = Array.to_list params in
-      fprintf f "(%a %a)" pp_ast fn (pp_list pp_ast) params
+      fprintf f "%a" (pp_list pp_ast) (fn :: params)
   | A_let (bindings, body, lettype) ->
       let txt = match lettype with
 	  LT_let -> "let"
       let pp_binding f (var, expr) =
 	fprintf f "(%a %a)" pp_var var pp_ast expr
       in
-      (* FIXME *)
       let bindings = Array.to_list bindings in
-      fprintf f "(%s (%a) %a)" txt (pp_list pp_binding) bindings pp_ast body
+      fprintf f "(%s %a %a)" txt (pp_list pp_binding) bindings pp_ast body
   | A_callcc expr ->
       fprintf f "(call/cc %a)" pp_ast expr
   | A_set (var, expr) ->

File blub_llvm.ml

   | Sint x -> const_int lltype x
   | Sfloat x -> const_float lltype x
   | Ssymbol s -> const_array i8_type (convert_string s)
-  | Sclosure (_, { lam_body = Some Jitcode (typ, fn_name) } ) -> begin
+  | Sjitclosure (Jitcode fn_name) -> begin
       match lookup_function fn_name m with
 	  Some fn -> fn
 	| None -> assert false

File blub_types.mli

 and lambda = { lam_params : variable array;
 	       lam_varargs : bool;
 	       lam_ast : ast;  (* AST of the lambda body *)
-	       mutable lam_body : code option }
-
-and code = 
-    Bytecode of bytecode
-  | Jitcode of type_ * string
+	       lam_bytecode : bytecode;
+	       mutable lam_jitcode : (type_ array, string) PMap.t }
 
 and sval =
     Ssymbol of string
   | Spair of spair
   | Strue | Sfalse | Snull | Sunbound
   | Sclosure of sclosure
+  | Sjitclosure of sjitclosure
   | 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 ast =
     A_lit of sval
   | A_ref of variable
 
   let compile (globals:env_frame) (env:environment) (ast:ast) (next:bytecode) : bytecode =
     let rec bc_compile env ast next =
-      printf "bc-compile: %a\n%!" pp_env env;
+      printf "bc-compile: %a  in env: %a\n%!" pp_ast ast pp_env env;
       match ast with
 	  A_lit l -> B_lit (l, next)
 	| A_ref r -> 
 	    with _ -> Blub_closure.VarSet.empty
 	    in
 
+	    (* 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
 	    B_abs ( { lam_params = params;
 		      lam_varargs = varargs;
 		      lam_ast = body;
-		      lam_body = None }, next)
+		      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
 	  let next = if acc == Sfalse then falseb else trueb in
 	  eval acc globals env rib stack next
       | B_abs (abs, next) -> begin
-	  let () = match abs.lam_body with
-	      Some _ -> ()
-	    | None -> ()
-		(* This compiles the lambda abstraction in order to create the
-		   closure; I believe it would be possible to delay the
-		   compilation even longer, under the application of the
-		   function, if that was beneficial. 
-		let frame = 
-		  { vars = abs.lam_params;
-		    vals = Array.map (fun _ -> Sunbound) abs.lam_params } in
-		let env = frame :: env in
-		let body = bc_compile env abs.lam_ast B_ret in
-		abs.lam_body <- Some body*)
-	  in
 	  let closure = Sclosure (env, abs) in
 	  eval closure globals env rib stack next
 		
 	  let abs = { lam_params = [| var |];
 		      lam_varargs = false;
 		      lam_ast = A_lit (Sunbound);
-		      lam_body = Some (Bytecode body) } in
+		      lam_bytecode = body;
+		      lam_jitcode = PMap.empty } in
 	  let acc = Sclosure ([], abs) in
 	  eval acc globals env rib stack x
 	    
 	Sclosure (env, abs) ->
 	  let { lam_params = params;
 		lam_varargs = varargs;
-		lam_body = body } = abs in
+		lam_bytecode = body } = abs in
 	  let frame = if varargs then
 	    (* one param (the last) is the varargs, the rest are the
 	       regular args *)
 	    { vars = params; vals = rib }
 	  in
 	  let env = frame :: env in
-	  let body = match body with
-	      None -> 
-		(* This is playing around with deferring compilation of a 
-		   function until it is applied.  However, we can't memoize
-		   it since it is compiled with values of the params
-		   bound in the environment *)
-		let body = compile globals env abs.lam_ast B_ret in
-		(* abs.lam_body <- Some body; *)
-		body
-	    | Some Bytecode body -> body
-	  in
 	  eval acc globals env rib stack body
 
       | Spfn fn ->