ocaml-llvm-phantom / lib / build.ml

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
open Spotlib.Spot
module P = Phantom
open P.Open

module Builder = struct
  type 'a t = Llvm.llbuilder -> 'a
  include Monad.Make(struct
    type 'a t = Llvm.llbuilder -> 'a
    let bind a f = fun builder ->
      let a = a builder in
      f a builder
    let return a = fun _builder -> a
  end)
end
open Builder.Open

module Make(Module : Module_intf.S) = struct
  module Type = Type_ctxt.Make(Module)
  module Value = Value_ctxt.Make(Module)
  open Type
  open Value

  module Module = Module

  (** Builder monad *)

  (* CR jfuruse: Builder is independent from Module. It can be somewhere else. *)
  module Monad = struct
    include Builder
    let run v = v (Llvm.builder Module.context)
  end
  type 'a m = 'a Monad.t
  let build = Monad.run
  let unknownM (v : 'a v m) : unknown v m = v >>= fun v -> return (!?v)
  let magicM (v : 'a v m) : 'b v m = perform v <-- v; return (P.magic v)
  let unsafeM v = perform v <-- v; return (P.unsafe v)

  (** Function calls *)

  let call 
      ?(name="called") (* CR jfuruse: called + f's name *)
      (f : ('args -> 'ret) pointer v)
      (args : 'args vs)
      : 'ret v m = 
    (* If its return type is void, we erase the name *)
    let name = 
      match classify (function_return (element (type_of f))) with
      | Llvm.TypeKind.Void -> ""
      | _ -> name
    in
    unsafeM (Llvm.build_call !<f (P.List.to_array args) name)

  let call_va_args
      ?(name="called")
      (f : ('args -> dots -> 'ret) pointer v)
      (args : 'args vs)
      (va_args : unknown v list)
      : 'ret v m = 
    let name = 
      match classify (function_return (element (type_of f))) with
      | Llvm.TypeKind.Void -> ""
      | _ -> name
    in
    unsafeM (Llvm.build_call !<f (Array.of_list (P.List.to_list args 
                                            @ List.map (!<) va_args)) name)


  (** String *)

  let global_stringptr ?(name="stringptr") str : i8 pointer v m = 
    unsafeM (Llvm.build_global_stringptr str name)

  (** Pointers *)

  let is_null ?(name="is_null") (lv : 'a pointer v) : i1 v m = 
    unsafeM (Llvm.build_is_null !<lv name)

  (** Casts *)

  let cast_name ?name v lty = match name with
    | Some n -> n
    | None ->
        let name = Value.name v in
        let name = try String.sub name 0 (String.rindex name '=') with Not_found -> name in
        name ^ "=" ^ Type.string_of lty

  let bitcast ?name v lty = 
    let name = cast_name ?name v lty in
    unsafeM (Llvm.build_bitcast !<v !<lty name)

  let pointercast ?name v lty = 
    let name = cast_name ?name v lty in
    unsafeM (Llvm.build_pointercast !<v !<lty name)

  let intcast ?name v lty = 
    let name = cast_name ?name v lty in
    unsafeM (Llvm.build_intcast !<v !<lty name)

  (** Load/Store. Unsafe and type-safe versions *)

  let load 
      ?(name="loaded")
      (v : 'ty pointer v)
      : 'ty v m = 
    unsafeM (Llvm.build_load !<v name)

  let store 
      (x : 'a v)
      ~dst:(dst : 'a pointer v)
      : unit m = 
    Monad.void (Llvm.build_store !<x !<dst)

  (* unsafe *)
  let unsafe_gep 
      ?(name = "gepped")
      (v : 'a pointer v)
      (xs : i32 v list)
      : 'unsafe pointer v m = 
    unsafeM (Llvm.build_gep !<v (Array.of_list (List.map (!<) xs)) name)

  let gep_gen ?name cont v = Gep.gen (fun lst ->
    let lst = List.map (function
      | `int n -> Const.i32_of_int n
      | `llvalue i -> P.unsafe i) lst in
    perform
      ptr <-- unsafe_gep ?name v lst;
    cont ptr)

  let gep ?name v = gep_gen ?name return v
  let gep_load ?name v = gep_gen (load ?name) v
  let gep_store x ~dst:v = gep_gen (fun ptr -> store x ~dst:ptr) v

  let unsafe_const_load ?name ptr indices = perform
    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices);
    load ?name gepped

  (* opposite order! *)
  let unsafe_const_store ptr indices lv = perform
      gepped <-- unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices);
      Monad.void (store lv ~dst:gepped)

  (** Arithmetic operations *)

  (* CR jfuruse: unfortunately no arith type check is done yet *)      
  let arith_binop (defname : string) f = 
    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
      (unsafeM (f !<x !<y name) : 'a v m)
  let cmp (defname : string) f = 
    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
      (unsafeM (f !<x !<y name) : i1 v m)

  let add  ?name = arith_binop "added" Llvm.build_add ?name
  let sub  ?name = arith_binop "subed" Llvm.build_sub ?name
  let mul  ?name = arith_binop "muled" Llvm.build_mul ?name
  let sdiv ?name = arith_binop "sdived" Llvm.build_sdiv ?name
  let fadd ?name = arith_binop "fadded" Llvm.build_fadd ?name
  let fsub ?name = arith_binop "fsubed" Llvm.build_fsub ?name
  let fmul ?name = arith_binop "fmuled" Llvm.build_fmul ?name
  let fdiv ?name = arith_binop "fdived" Llvm.build_fdiv ?name
  let icmp c = cmp "icmped" (Llvm.build_icmp c)
  let fcmp c = cmp "fcmped" (Llvm.build_fcmp c)

  let ( +! )  x = add  ?name:None x
  let ( -! )  x = sub  ?name:None x
  let ( *! )  x = mul  ?name:None x
  let ( /! )  x = sdiv ?name:None x
  let ( +.! ) x = fadd ?name:None x
  let ( -.! ) x = fsub ?name:None x
  let ( *.! ) x = fmul ?name:None x
  let ( /.! ) x = fdiv ?name:None x
  (* let icmp c = cmp "icmped" (Llvm.build_icmp c)
     let fcmp c = cmp "fcmped" (Llvm.build_fcmp c) *)

  let land_ ?name = arith_binop "anded" Llvm.build_and ?name
  let ( &! )  x = land_ ?name:None x

  let arith_unop (defname : string) f = 
    fun ?(name=defname) (x : 'a v) ->
      (unsafeM (f !<x name) : 'a v m)
  let not_ ?name = arith_unop "noted" Llvm.build_not ?name

  (** Arithmetic type conversion *)

  let sitofp ?(name="sitofped") i ty = 
    unsafeM & Llvm.build_sitofp !<i !<ty name

  (** Memory *)

  let alloca ?(name="inStack") ty =
    unsafeM & Llvm.build_alloca !<ty name

  let alloca_with ?name ty v = perform
    ptr <-- alloca ?name ty;
    Gep.(gep_store v ~dst:ptr (pos 0) end_);
    return ptr

  (** Useful libc functions *)

  let printf : string -> unknown v list -> unit m = 
    fun fmt args -> perform
      fmt <-- global_stringptr ~name:"fmt" fmt;
      Monad.void (call_va_args (Module.External.printf) (P.c1 fmt) args ~name:"res")
  ;;

  let memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (P.c3 dst src size)

  let bzero dst ~size = Monad.void (call Module.External.bzero (P.c2 dst size))

  let malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m =
    fun ?(name="alloced") ?bzero:(zero=false) size -> perform
      ptr <-- call ~name Module.External.malloc (P.c1 size);
      if zero then bzero ptr ~size else return ();
      return ptr
  ;;

  let malloc_by_ty ?name ?bzero (lty : 'ty typ) = perform
    ptr <-- malloc ?name ?bzero (size_of lty);
    bitcast ptr (pointer lty)

  let free ptr = perform
    ptr <-- bitcast ptr pointer_void;
    Monad.void (call Module.External.free (P.c1 ptr))
  ;;

  (** Control flow codegens *)

  let ret x : unit m = Monad.void (Llvm.build_ret !<x)
  let ret_void : unit m = Monad.void Llvm.build_ret_void

  let phi 
      ?(name="phi")
      (lst : ('a v * Llvm.llbasicblock) list)
      : 'a v m =
    unsafeM (Llvm.build_phi (List.map (fun (v, b) -> !<v, b) lst) name)

  let cond_br 
      (b : i1 v)
      bthen belse
      : unit m
      = Monad.void (Llvm.build_cond_br !<b bthen belse)

  let br b = Monad.void (Llvm.build_br b)

  (** Basic blocks *)

  module Block = struct
    let position_at_end = Llvm.position_at_end
    let insertion = Llvm.insertion_block

    (* They are independent from the builder *) 	
    let append ?(name="block") (v : ('a -> 'b) pointer v) = Llvm.append_block Module.context name !<v  
    let parent bb : ('a -> 'b) pointer v = P.unsafe (Llvm.block_parent bb)
  end

  let func name (ty_ret : 'ret typ) (args : ('args, (string * Llvm.lltype)) P.ts) 
      ?(dump=false)
      (f : ('args -> 'ret) pointer v -> 'args vs -> 'ret v m) : ('args -> 'ret) pointer v m =
    (* Format.eprintf "Creating function %s@." name; *)
    let lty = function_ ty_ret (P.List.map snd args) in
    let lv_f = match Module.Function.lookup name with
      | Some _ -> failwithf "LLib.create_fun: function %s is defined more than once" name
      | None -> Module.Function.declare name lty
    in
    (* name args *)
    List.iter2 (fun lv_param name ->
      Value.set_name name lv_param) 
      (P.List.to_unknown_list (function_params lv_f))
      (P.List.to_list (P.List.map fst args));
    let bb = Block.append ~name:"entry" lv_f in
    perform 
      Block.position_at_end bb;
      lv_body <-- f lv_f (function_params lv_f);
      (* Finish off the function. *)
      if classify ty_ret = Llvm.TypeKind.Void then ret_void else ret lv_body;
      (* Validate the generated code, checking for consistency. *)
      \ if dump then Value.dump lv_f;
      \ Analysis.assert_valid_function lv_f;
      (* Optimize the function *)
      \ Module.PassManager.run_function_if_opt lv_f;
      (* \ Format.eprintf "Created function %s@." name; *)
      return lv_f

  let func0 name ?dump ret () f = func name ?dump ret P.c0 (fun self -> P.uncurry0 (f self))
  let func1 name ?dump ret (arg0,t0) f = func name ?dump ret (P.c1 (P.combine arg0 t0)) (fun self -> P.uncurry1 (f self))
  let func2 name ?dump ret (arg0,t0) (arg1,t1) f = func name ?dump ret (P.c2 (P.combine arg0 t0) (P.combine arg1 t1)) (fun self -> P.uncurry2 (f self))
  let func3 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) f = func name ?dump ret (P.c3 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2)) (fun self -> P.uncurry3 (f self))
  let func4 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) f = func name ?dump ret (P.c4 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3)) (fun self -> P.uncurry4 (f self))
  let func5 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) f = func name ?dump ret (P.c5 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4)) (fun self -> P.uncurry5 (f self))
  let func6 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) f = func name ?dump ret (P.c6 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5)) (fun self -> P.uncurry6 (f self))
  let func7 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) f = func name ?dump ret (P.c7 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6)) (fun self -> P.uncurry7 (f self))
  let func8 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) f = func name ?dump ret (P.c8 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7)) (fun self -> P.uncurry8 (f self))
  let func9 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) (arg8,t8) f = func name ?dump ret (P.c9 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7) (P.combine arg8 t8)) (fun self -> P.uncurry9 (f self))
  let func10 name ?dump ret (arg0,t0) (arg1,t1) (arg2,t2) (arg3,t3) (arg4,t4) (arg5,t5) (arg6,t6) (arg7,t7) (arg8,t8) (arg9,t9) f = func name ?dump ret (P.c10 (P.combine arg0 t0) (P.combine arg1 t1) (P.combine arg2 t2) (P.combine arg3 t3) (P.combine arg4 t4) (P.combine arg5 t5) (P.combine arg6 t6) (P.combine arg7 t7) (P.combine arg8 t8) (P.combine arg9 t9)) (fun self -> P.uncurry10 (f self))

  (* stupid lambda abstraction is required for polymorphism *)    
  let current_function : unit -> ('a -> 'b) pointer v m = fun () -> perform
    current_bb <-- Block.insertion;
    return (Block.parent current_bb)

  let append_code_block name (codegen : 'a m) : (Llvm.llbasicblock * 'a * Llvm.llbasicblock) m = perform
    the_function <-- current_function ();
    let bb = Block.append ~name the_function in
    (* Emit value. *)
    Block.position_at_end bb;
    res <-- codegen;
    (* Codegen of [res] can change the current block, update bb for the phi. *)
    new_bb <-- Block.insertion;
    return (bb, res, new_bb)

  (** Connecting basic blocks *)

  let return_void : void v m = (fun _builder -> P.magic Const.i32_0)
    (* The return value looks strange but probably ok. Probably. *)

  let uncond_br from to_ = perform
    Block.position_at_end from;
    Monad.void (br to_)

  let if_then_else (lv_cond : i1 v m) (lv_then : 'a v m) (lv_else : 'a v m) : 'a v m = perform
    (* get the current bb *)
    start_bb <-- Block.insertion;

    lv_cond <-- lv_cond; (* created in [start_bb] *)
    (* before adding branching, we must create the destinations *)

    (then_bb, lv_then, new_then_bb) <-- append_code_block "then" lv_then;
    (else_bb, lv_else, new_else_bb) <-- append_code_block "else" lv_else;

    (* merge_bb and new_merge_bb should be the same *)
    (merge_bb, phi, new_merge_bb) <-- append_code_block "ifcont" begin
      let incoming = [(lv_then, new_then_bb); (lv_else, new_else_bb)] in
      (* Llvm.build_phi returns the merged value, which can be used the
         return of the entire (if ...) *)
      phi incoming ~name:"iftmp"
    end;

    (* Return to the start block to add the conditional branch. *)
    Block.position_at_end start_bb;
    cond_br lv_cond then_bb else_bb;

    (* Set a unconditional branch at the end of the 'then' block and the
     * 'else' block to the 'merge' block. *)
    uncond_br new_then_bb merge_bb;
    uncond_br new_else_bb merge_bb;

    (* Finally, set the G.builder to the end of the merge block. *)
    Block.position_at_end new_merge_bb;

    return phi

  let imp_if_then_else (lv_cond : i1 v m) (lv_then : unit m) (lv_else : unit m) : unit m = perform
    (* get the current bb *)
    start_bb <-- Block.insertion;

    lv_cond <-- lv_cond; (* created in [start_bb] *)
    (* before adding branching, we must create the destinations *)

    (then_bb, (), new_then_bb) <-- append_code_block "then" lv_then;
    (else_bb, (), new_else_bb) <-- append_code_block "else" lv_else;

    (* merge_bb and new_merge_bb should be the same *)
    (merge_bb, (), new_merge_bb) <-- append_code_block "ifcont" (return ());

    (* Return to the start block to add the conditional branch. *)
    Block.position_at_end start_bb;
    cond_br lv_cond then_bb else_bb;

    (* Set a unconditional branch at the end of the 'then' block and the
     * 'else' block to the 'merge' block. *)
    uncond_br new_then_bb merge_bb;
    uncond_br new_else_bb merge_bb;

    (* Finally, set the G.builder to the end of the merge block. *)
    Block.position_at_end new_merge_bb;

    return ()

  let for_loop 
      (init : 'a v) (* initialization of the loop variable of type 'a v *)
      (cond : 'a v -> i1 v m) (* test on the loop variable *)
      (do_ : 'a v -> 'a v m) (* do the job and update the loop variable *) = perform
    start_bb <-- Block.insertion;
    current_function <-- current_function ();

    (phi_enter, phi, phi_exit) <-- append_code_block "phi" (
      perform
        let incoming = [(init, start_bb)] in (* do is not prepared. Added later. *)
        phi incoming ~name:"fortmp");

    (do_enter,   do_,  do_exit)   <-- append_code_block "do" (do_ phi);
    \ Llvm.add_incoming (!<do_, do_exit) !<phi; (* now we can add the other incoming *)

    let exit_bb = Block.append ~name:"exit" current_function in

    (cond_enter, _cond, _cond_exit) <-- append_code_block "cond" (perform
      cond <-- cond phi;
      cond_br cond do_enter exit_bb;
      return cond);

    uncond_br start_bb phi_enter;
    uncond_br do_exit phi_enter;
    uncond_br phi_exit cond_enter;

    Block.position_at_end exit_bb;

    return ()

  (** Execution *)

  let exec =
    let cntr = ref 0 in
    fun (v : unit m) ->
      incr cntr;
      let name = Printf.sprintf "lbuilder.exec%d" !cntr in
      Format.eprintf "Executing %s...@." name;
      let f : (unit -> void) pointer v =
        let proto = function_ void P.c0 in
        match Module.Function.lookup name with
        | Some _ -> failwithf "function %s is defined more than once" name
        | None -> Module.Function.declare name proto
      in
      prerr_endline "proto done";
      (* Create a new basic block to start insertion into. *)
      Monad.run (perform
        let bb = Block.append ~name:"entry" f in
        Block.position_at_end bb;
        v; (* create the code *)
        ret_void);
      (* Optimize the function *)
      Value.dump f;
      Module.PassManager.run_function_if_opt f;
      Analysis.assert_valid_function f;
      Format.eprintf "Now running %s@." name;
      ignore (Module.ExecutionEngine.run_function f P.c0);
      Format.eprintf "Done running %s@." name;
end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.