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_fadd lhs_val rhs_val "addtmp" builder 26 | '-' -> build_fsub lhs_val rhs_val "subtmp" builder 27 | '*' -> build_fmul 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 | Ast.If (cond, then_, else_) -> 49 let cond = codegen_expr cond in 50 51 (* Convert condition to a bool by comparing equal to 0.0 *) 52 let zero = const_float double_type 0.0 in 53 let cond_val = build_fcmp Fcmp.One cond zero "ifcond" builder in 54 55 (* Grab the first block so that we might later add the conditional branch 56 * to it at the end of the function. *) 57 let start_bb = insertion_block builder in 58 let the_function = block_parent start_bb in 59 60 let then_bb = append_block context "then" the_function in 61 62 (* Emit 'then' value. *) 63 position_at_end then_bb builder; 64 let then_val = codegen_expr then_ in 65 66 (* Codegen of 'then' can change the current block, update then_bb for the 67 * phi. We create a new name because one is used for the phi node, and the 68 * other is used for the conditional branch. *) 69 let new_then_bb = insertion_block builder in 70 71 (* Emit 'else' value. *) 72 let else_bb = append_block context "else" the_function in 73 position_at_end else_bb builder; 74 let else_val = codegen_expr else_ in 75 76 (* Codegen of 'else' can change the current block, update else_bb for the 77 * phi. *) 78 let new_else_bb = insertion_block builder in 79 80 (* Emit merge block. *) 81 let merge_bb = append_block context "ifcont" the_function in 82 position_at_end merge_bb builder; 83 let incoming = [(then_val, new_then_bb); (else_val, new_else_bb)] in 84 let phi = build_phi incoming "iftmp" builder in 85 86 (* Return to the start block to add the conditional branch. *) 87 position_at_end start_bb builder; 88 ignore (build_cond_br cond_val then_bb else_bb builder); 89 90 (* Set a unconditional branch at the end of the 'then' block and the 91 * 'else' block to the 'merge' block. *) 92 position_at_end new_then_bb builder; ignore (build_br merge_bb builder); 93 position_at_end new_else_bb builder; ignore (build_br merge_bb builder); 94 95 (* Finally, set the builder to the end of the merge block. *) 96 position_at_end merge_bb builder; 97 98 phi 99 | Ast.For (var_name, start, end_, step, body) -> 100 (* Emit the start code first, without 'variable' in scope. *) 101 let start_val = codegen_expr start in 102 103 (* Make the new basic block for the loop header, inserting after current 104 * block. *) 105 let preheader_bb = insertion_block builder in 106 let the_function = block_parent preheader_bb in 107 let loop_bb = append_block context "loop" the_function in 108 109 (* Insert an explicit fall through from the current block to the 110 * loop_bb. *) 111 ignore (build_br loop_bb builder); 112 113 (* Start insertion in loop_bb. *) 114 position_at_end loop_bb builder; 115 116 (* Start the PHI node with an entry for start. *) 117 let variable = build_phi [(start_val, preheader_bb)] var_name builder in 118 119 (* Within the loop, the variable is defined equal to the PHI node. If it 120 * shadows an existing variable, we have to restore it, so save it 121 * now. *) 122 let old_val = 123 try Some (Hashtbl.find named_values var_name) with Not_found -> None 124 in 125 Hashtbl.add named_values var_name variable; 126 127 (* Emit the body of the loop. This, like any other expr, can change the 128 * current BB. Note that we ignore the value computed by the body, but 129 * don't allow an error *) 130 ignore (codegen_expr body); 131 132 (* Emit the step value. *) 133 let step_val = 134 match step with 135 | Some step -> codegen_expr step 136 (* If not specified, use 1.0. *) 137 | None -> const_float double_type 1.0 138 in 139 140 let next_var = build_add variable step_val "nextvar" builder in 141 142 (* Compute the end condition. *) 143 let end_cond = codegen_expr end_ in 144 145 (* Convert condition to a bool by comparing equal to 0.0. *) 146 let zero = const_float double_type 0.0 in 147 let end_cond = build_fcmp Fcmp.One end_cond zero "loopcond" builder in 148 149 (* Create the "after loop" block and insert it. *) 150 let loop_end_bb = insertion_block builder in 151 let after_bb = append_block context "afterloop" the_function in 152 153 (* Insert the conditional branch into the end of loop_end_bb. *) 154 ignore (build_cond_br end_cond loop_bb after_bb builder); 155 156 (* Any new code will be inserted in after_bb. *) 157 position_at_end after_bb builder; 158 159 (* Add a new entry to the PHI node for the backedge. *) 160 add_incoming (next_var, loop_end_bb) variable; 161 162 (* Restore the unshadowed variable. *) 163 begin match old_val with 164 | Some old_val -> Hashtbl.add named_values var_name old_val 165 | None -> () 166 end; 167 168 (* for expr always returns 0.0. *) 169 const_null double_type 170 171let codegen_proto = function 172 | Ast.Prototype (name, args) -> 173 (* Make the function type: double(double,double) etc. *) 174 let doubles = Array.make (Array.length args) double_type in 175 let ft = function_type double_type doubles in 176 let f = 177 match lookup_function name the_module with 178 | None -> declare_function name ft the_module 179 180 (* If 'f' conflicted, there was already something named 'name'. If it 181 * has a body, don't allow redefinition or reextern. *) 182 | Some f -> 183 (* If 'f' already has a body, reject this. *) 184 if block_begin f <> At_end f then 185 raise (Error "redefinition of function"); 186 187 (* If 'f' took a different number of arguments, reject. *) 188 if element_type (type_of f) <> ft then 189 raise (Error "redefinition of function with different # args"); 190 f 191 in 192 193 (* Set names for all arguments. *) 194 Array.iteri (fun i a -> 195 let n = args.(i) in 196 set_value_name n a; 197 Hashtbl.add named_values n a; 198 ) (params f); 199 f 200 201let codegen_func the_fpm = function 202 | Ast.Function (proto, body) -> 203 Hashtbl.clear named_values; 204 let the_function = codegen_proto proto in 205 206 (* Create a new basic block to start insertion into. *) 207 let bb = append_block context "entry" the_function in 208 position_at_end bb builder; 209 210 try 211 let ret_val = codegen_expr body in 212 213 (* Finish off the function. *) 214 let _ = build_ret ret_val builder in 215 216 (* Validate the generated code, checking for consistency. *) 217 Llvm_analysis.assert_valid_function the_function; 218 219 (* Optimize the function. *) 220 let _ = PassManager.run_function the_function the_fpm in 221 222 the_function 223 with e -> 224 delete_function the_function; 225 raise e 226