Members/tobaru/cbc/CbC_llvm: examples/OCaml-Kaleidoscope/Chapter7/codegen.ml comparison

comparison examples/OCaml-Kaleidoscope/Chapter7/codegen.ml @ 0:95c75e76d11b

LLVM 3.4

author	Kaito Tokumori <e105711@ie.u-ryukyu.ac.jp>
date	Thu, 12 Dec 2013 13:56:28 +0900
parents
children

comparison

equal deleted inserted replaced

--1:000000000000
+:95c75e76d11b
+(*===----------------------------------------------------------------------===
+* Code Generation
+*===----------------------------------------------------------------------===*)
+open Llvm
+exception Error of string
+let context = global_context ()
+let the_module = create_module context "my cool jit"
+let builder = builder context
+let named_values:(string, llvalue) Hashtbl.t = Hashtbl.create 10
+let double_type = double_type context
+(* Create an alloca instruction in the entry block of the function. This
+* is used for mutable variables etc. *)
+let create_entry_block_alloca the_function var_name =
+let builder = builder_at context (instr_begin (entry_block the_function)) in
+build_alloca double_type var_name builder
+let rec codegen_expr = function
+| Ast.Number n -> const_float double_type n
+| Ast.Variable name ->
+let v = try Hashtbl.find named_values name with
+| Not_found -> raise (Error "unknown variable name")
+in
+(* Load the value. *)
+build_load v name builder
+| Ast.Unary (op, operand) ->
+let operand = codegen_expr operand in
+let callee = "unary" ^ (String.make 1 op) in
+let callee =
+match lookup_function callee the_module with
+| Some callee -> callee
+| None -> raise (Error "unknown unary operator")
+in
+build_call callee [|operand|] "unop" builder
+| Ast.Binary (op, lhs, rhs) ->
+begin match op with
+| '=' ->
+(* Special case '=' because we don't want to emit the LHS as an
+* expression. *)
+let name =
+match lhs with
+| Ast.Variable name -> name
+| _ -> raise (Error "destination of '=' must be a variable")
+in
+(* Codegen the rhs. *)
+let val_ = codegen_expr rhs in
+(* Lookup the name. *)
+let variable = try Hashtbl.find named_values name with
+| Not_found -> raise (Error "unknown variable name")
+in
+ignore(build_store val_ variable builder);
+val_
+| _ ->
+let lhs_val = codegen_expr lhs in
+let rhs_val = codegen_expr rhs in
+begin
+match op with
+| '+' -> build_fadd lhs_val rhs_val "addtmp" builder
+| '-' -> build_fsub lhs_val rhs_val "subtmp" builder
+| '*' -> build_fmul lhs_val rhs_val "multmp" builder
+| '<' ->
+(* Convert bool 0/1 to double 0.0 or 1.0 *)
+let i = build_fcmp Fcmp.Ult lhs_val rhs_val "cmptmp" builder in
+build_uitofp i double_type "booltmp" builder
+| _ ->
+(* If it wasn't a builtin binary operator, it must be a user defined
+* one. Emit a call to it. *)
+let callee = "binary" ^ (String.make 1 op) in
+let callee =
+match lookup_function callee the_module with
+| Some callee -> callee
+| None -> raise (Error "binary operator not found!")
+in
+build_call callee [|lhs_val; rhs_val|] "binop" builder
+end
+end
+| Ast.Call (callee, args) ->
+(* Look up the name in the module table. *)
+let callee =
+match lookup_function callee the_module with
+| Some callee -> callee
+| None -> raise (Error "unknown function referenced")
+in
+let params = params callee in
+(* If argument mismatch error. *)
+if Array.length params == Array.length args then () else
+raise (Error "incorrect # arguments passed");
+let args = Array.map codegen_expr args in
+build_call callee args "calltmp" builder
+| Ast.If (cond, then_, else_) ->
+let cond = codegen_expr cond in
+(* Convert condition to a bool by comparing equal to 0.0 *)
+let zero = const_float double_type 0.0 in
+let cond_val = build_fcmp Fcmp.One cond zero "ifcond" builder in
+(* Grab the first block so that we might later add the conditional branch
+* to it at the end of the function. *)
+let start_bb = insertion_block builder in
+let the_function = block_parent start_bb in
+let then_bb = append_block context "then" the_function in
+(* Emit 'then' value. *)
+position_at_end then_bb builder;
+let then_val = codegen_expr then_ in
+(* Codegen of 'then' can change the current block, update then_bb for the
+* phi. We create a new name because one is used for the phi node, and the
+* other is used for the conditional branch. *)
+let new_then_bb = insertion_block builder in
+(* Emit 'else' value. *)
+let else_bb = append_block context "else" the_function in
+position_at_end else_bb builder;
+let else_val = codegen_expr else_ in
+(* Codegen of 'else' can change the current block, update else_bb for the
+* phi. *)
+let new_else_bb = insertion_block builder in
+(* Emit merge block. *)
+let merge_bb = append_block context "ifcont" the_function in
+position_at_end merge_bb builder;
+let incoming = [(then_val, new_then_bb); (else_val, new_else_bb)] in
+let phi = build_phi incoming "iftmp" builder in
+(* Return to the start block to add the conditional branch. *)
+position_at_end start_bb builder;
+ignore (build_cond_br cond_val then_bb else_bb builder);
+(* Set a unconditional branch at the end of the 'then' block and the
+* 'else' block to the 'merge' block. *)
+position_at_end new_then_bb builder; ignore (build_br merge_bb builder);
+position_at_end new_else_bb builder; ignore (build_br merge_bb builder);
+(* Finally, set the builder to the end of the merge block. *)
+position_at_end merge_bb builder;
+phi
+| Ast.For (var_name, start, end_, step, body) ->
+(* Output this as:
+*   var = alloca double
+*   ...
+*   start = startexpr
+*   store start -> var
+*   goto loop
+* loop:
+*   ...
+*   bodyexpr
+*   ...
+* loopend:
+*   step = stepexpr
+*   endcond = endexpr
+*
+*   curvar = load var
+*   nextvar = curvar + step
+*   store nextvar -> var
+*   br endcond, loop, endloop
+* outloop: *)
+let the_function = block_parent (insertion_block builder) in
+(* Create an alloca for the variable in the entry block. *)
+let alloca = create_entry_block_alloca the_function var_name in
+(* Emit the start code first, without 'variable' in scope. *)
+let start_val = codegen_expr start in
+(* Store the value into the alloca. *)
+ignore(build_store start_val alloca builder);
+(* Make the new basic block for the loop header, inserting after current
+* block. *)
+let loop_bb = append_block context "loop" the_function in
+(* Insert an explicit fall through from the current block to the
+* loop_bb. *)
+ignore (build_br loop_bb builder);
+(* Start insertion in loop_bb. *)
+position_at_end loop_bb builder;
+(* Within the loop, the variable is defined equal to the PHI node. If it
+* shadows an existing variable, we have to restore it, so save it
+* now. *)
+let old_val =
+try Some (Hashtbl.find named_values var_name) with Not_found -> None
+in
+Hashtbl.add named_values var_name alloca;
+(* Emit the body of the loop.  This, like any other expr, can change the
+* current BB.  Note that we ignore the value computed by the body, but
+* don't allow an error *)
+ignore (codegen_expr body);
+(* Emit the step value. *)
+let step_val =
+match step with
+| Some step -> codegen_expr step
+(* If not specified, use 1.0. *)
+| None -> const_float double_type 1.0
+in
+(* Compute the end condition. *)
+let end_cond = codegen_expr end_ in
+(* Reload, increment, and restore the alloca. This handles the case where
+* the body of the loop mutates the variable. *)
+let cur_var = build_load alloca var_name builder in
+let next_var = build_add cur_var step_val "nextvar" builder in
+ignore(build_store next_var alloca builder);
+(* Convert condition to a bool by comparing equal to 0.0. *)
+let zero = const_float double_type 0.0 in
+let end_cond = build_fcmp Fcmp.One end_cond zero "loopcond" builder in
+(* Create the "after loop" block and insert it. *)
+let after_bb = append_block context "afterloop" the_function in
+(* Insert the conditional branch into the end of loop_end_bb. *)
+ignore (build_cond_br end_cond loop_bb after_bb builder);
+(* Any new code will be inserted in after_bb. *)
+position_at_end after_bb builder;
+(* Restore the unshadowed variable. *)
+begin match old_val with
+| Some old_val -> Hashtbl.add named_values var_name old_val
+| None -> ()
+end;
+(* for expr always returns 0.0. *)
+const_null double_type
+| Ast.Var (var_names, body) ->
+let old_bindings = ref [] in
+let the_function = block_parent (insertion_block builder) in
+(* Register all variables and emit their initializer. *)
+Array.iter (fun (var_name, init) ->
+(* Emit the initializer before adding the variable to scope, this
+* prevents the initializer from referencing the variable itself, and
+* permits stuff like this:
+*   var a = 1 in
+*     var a = a in ...   # refers to outer 'a'. *)
+let init_val =
+match init with
+| Some init -> codegen_expr init
+(* If not specified, use 0.0. *)
+| None -> const_float double_type 0.0
+in
+let alloca = create_entry_block_alloca the_function var_name in
+ignore(build_store init_val alloca builder);
+(* Remember the old variable binding so that we can restore the binding
+* when we unrecurse. *)
+begin
+try
+let old_value = Hashtbl.find named_values var_name in
+old_bindings := (var_name, old_value) :: !old_bindings;
+with Not_found -> ()
+end;
+(* Remember this binding. *)
+Hashtbl.add named_values var_name alloca;
+) var_names;
+(* Codegen the body, now that all vars are in scope. *)
+let body_val = codegen_expr body in
+(* Pop all our variables from scope. *)
+List.iter (fun (var_name, old_value) ->
+Hashtbl.add named_values var_name old_value
+) !old_bindings;
+(* Return the body computation. *)
+body_val
+let codegen_proto = function
+| Ast.Prototype (name, args) | Ast.BinOpPrototype (name, args, _) ->
+(* Make the function type: double(double,double) etc. *)
+let doubles = Array.make (Array.length args) double_type in
+let ft = function_type double_type doubles in
+let f =
+match lookup_function name the_module with
+| None -> declare_function name ft the_module
+(* If 'f' conflicted, there was already something named 'name'. If it
+* has a body, don't allow redefinition or reextern. *)
+| Some f ->
+(* If 'f' already has a body, reject this. *)
+if block_begin f <> At_end f then
+raise (Error "redefinition of function");
+(* If 'f' took a different number of arguments, reject. *)
+if element_type (type_of f) <> ft then
+raise (Error "redefinition of function with different # args");
+f
+in
+(* Set names for all arguments. *)
+Array.iteri (fun i a ->
+let n = args.(i) in
+set_value_name n a;
+Hashtbl.add named_values n a;
+) (params f);
+f
+(* Create an alloca for each argument and register the argument in the symbol
+* table so that references to it will succeed. *)
+let create_argument_allocas the_function proto =
+let args = match proto with
+| Ast.Prototype (_, args) | Ast.BinOpPrototype (_, args, _) -> args
+in
+Array.iteri (fun i ai ->
+let var_name = args.(i) in
+(* Create an alloca for this variable. *)
+let alloca = create_entry_block_alloca the_function var_name in
+(* Store the initial value into the alloca. *)
+ignore(build_store ai alloca builder);
+(* Add arguments to variable symbol table. *)
+Hashtbl.add named_values var_name alloca;
+) (params the_function)
+let codegen_func the_fpm = function
+| Ast.Function (proto, body) ->
+Hashtbl.clear named_values;
+let the_function = codegen_proto proto in
+(* If this is an operator, install it. *)
+begin match proto with
+| Ast.BinOpPrototype (name, args, prec) ->
+let op = name.[String.length name - 1] in
+Hashtbl.add Parser.binop_precedence op prec;
+| _ -> ()
+end;
+(* Create a new basic block to start insertion into. *)
+let bb = append_block context "entry" the_function in
+position_at_end bb builder;
+try
+(* Add all arguments to the symbol table and create their allocas. *)
+create_argument_allocas the_function proto;
+let ret_val = codegen_expr body in
+(* Finish off the function. *)
+let _ = build_ret ret_val builder in
+(* Validate the generated code, checking for consistency. *)
+Llvm_analysis.assert_valid_function the_function;
+(* Optimize the function. *)
+let _ = PassManager.run_function the_function the_fpm in
+the_function
+with e ->
+delete_function the_function;
+raise e

Mercurial > hg > Members > tobaru > cbc > CbC_llvm

comparison examples/OCaml-Kaleidoscope/Chapter7/codegen.ml @ 0:95c75e76d11b