1(*===----------------------------------------------------------------------===
2 * Code Generation
3 *===----------------------------------------------------------------------===*)
4
5open Llvm
6
7exception Error of string
8
9let context = global_context ()
10let the_module = create_module context "my cool jit"
11let builder = builder context
12let named_values:(string, llvalue) Hashtbl.t = Hashtbl.create 10
13let double_type = double_type context
14
15let rec codegen_expr = function
16  | Ast.Number n -> const_float double_type n
17  | Ast.Variable name ->
18      (try Hashtbl.find named_values name with
19        | Not_found -> raise (Error "unknown variable name"))
20  | Ast.Binary (op, lhs, rhs) ->
21      let lhs_val = codegen_expr lhs in
22      let rhs_val = codegen_expr rhs in
23      begin
24        match op with
25        | '+' -> build_add lhs_val rhs_val "addtmp" builder
26        | '-' -> build_sub lhs_val rhs_val "subtmp" builder
27        | '*' -> build_mul lhs_val rhs_val "multmp" builder
28        | '<' ->
29            (* Convert bool 0/1 to double 0.0 or 1.0 *)
30            let i = build_fcmp Fcmp.Ult lhs_val rhs_val "cmptmp" builder in
31            build_uitofp i double_type "booltmp" builder
32        | _ -> raise (Error "invalid binary operator")
33      end
34  | Ast.Call (callee, args) ->
35      (* Look up the name in the module table. *)
36      let callee =
37        match lookup_function callee the_module with
38        | Some callee -> callee
39        | None -> raise (Error "unknown function referenced")
40      in
41      let params = params callee in
42
43      (* If argument mismatch error. *)
44      if Array.length params == Array.length args then () else
45        raise (Error "incorrect # arguments passed");
46      let args = Array.map codegen_expr args in
47      build_call callee args "calltmp" builder
48
49let codegen_proto = function
50  | Ast.Prototype (name, args) ->
51      (* Make the function type: double(double,double) etc. *)
52      let doubles = Array.make (Array.length args) double_type in
53      let ft = function_type double_type doubles in
54      let f =
55        match lookup_function name the_module with
56        | None -> declare_function name ft the_module
57
58        (* If 'f' conflicted, there was already something named 'name'. If it
59         * has a body, don't allow redefinition or reextern. *)
60        | Some f ->
61            (* If 'f' already has a body, reject this. *)
62            if block_begin f <> At_end f then
63              raise (Error "redefinition of function");
64
65            (* If 'f' took a different number of arguments, reject. *)
66            if element_type (type_of f) <> ft then
67              raise (Error "redefinition of function with different # args");
68            f
69      in
70
71      (* Set names for all arguments. *)
72      Array.iteri (fun i a ->
73        let n = args.(i) in
74        set_value_name n a;
75        Hashtbl.add named_values n a;
76      ) (params f);
77      f
78
79let codegen_func = function
80  | Ast.Function (proto, body) ->
81      Hashtbl.clear named_values;
82      let the_function = codegen_proto proto in
83
84      (* Create a new basic block to start insertion into. *)
85      let bb = append_block context "entry" the_function in
86      position_at_end bb builder;
87
88      try
89        let ret_val = codegen_expr body in
90
91        (* Finish off the function. *)
92        let _ = build_ret ret_val builder in
93
94        (* Validate the generated code, checking for consistency. *)
95        Llvm_analysis.assert_valid_function the_function;
96
97        the_function
98      with e ->
99        delete_function the_function;
100        raise e
101