module List = Extensions.List
The CPS representation stems from the paper "Compiling with continuations, continued" by Andrew Kennedy. In particular this representation separates continuations from standard lambda functions, which allows calling and returning from functions using the normal stack, and allow close correspondance with the SSA form.
This module assumes that functions have no free variables (or continuation variables). Closure conversion removes free variables from functions. Free continuation variables should never happen when translating normal terms to CPS.
The module also assumes that the CPS values do not refer to primitive operations, such as +,-,*,/. Previous passes must transform calls to primitive operations to let x = primitive(args); and η-expand primitive operations passed as functions (e.g. let x = f() must have been transformed).
To keep things simple in this first version, no external functions is called (only lambdas defined in the body of the expression, and primitive operations, can be called).
In addition, all data is boxed, allocated using malloc (and never
freed; this could be improved by using libgc). Unboxed data would
requires to carry typing information in the CPS terms.
3.
To get an overview of the translation algorithm, the best is to
understand how the CPS concepts are mapped to the SSA concepts. In
the following, we denote by [x] the translation of x.
Llvm.llvalue
). CPS variables are introduced as arguments to lambda
and continuations, and in the let x = ... form. CPS variables and
SSA variables have the same name in their respective printed
representation.Llvm.basicblock
). The x formal argument of k corresponds to a
phi node at the start of [t1]. A call k( y to this continuation
with a value y is translated to a "jmp" instruction to the basic
block [t1], that binds [y] to the phi node at the start of
[t1]
.Dynamic_value(term)
, its size cannot be statically computed; so we
allocate the space for a global variable s
that contains one
pointer, and compile term
as a constructor that stores the
dynamically allocated result of initialization, in s
. Accesses to
x
are transformed to dereferences to s
. A future
"staticalization" transformation will try to maximize the amount of
static values, to avoid this indirection.Note that the SSA representation are well-formed only if "the
definition of a variable %x
does not dominate all of its uses"
(http://llvm.org/docs/LangRef.html#introduction). The translation
from a CPS term (without free variables) ensures that.
4.
Here is a simplified example of how the translation from CPS to
SSA works.
The CPS code:
let v = 3; let k(x) = k(2+x); k(11)
Is translated to SSA (ignoring boxing):
entry: v = 3 n_ = 11 jmp k k: x = phi (entry n_) (k o_) m_ = 2 o_ = m_ + x jmp k
This shows how k is translated to a separate basic block, and the argument x to a phi node connected to all the uses of k.
5.
If one encounters segmentation faults when changing the LLVM
related code, this may be caused by:
Llvm.build_call
on a value which does not have the
function lltype
, or Llvm.build_gep
with operations that do not
correspond to the lltype of the value.build_phi
with an empty list of "incoming".ExecutionEngine.create the_module
before calling
Llvm_executionengine.initialize_native_target()
can also segfault.Using valgrind or gdb allows to quickly locate the problematic Ocaml Llvm binding.
let context = Llvm.global_context()
let the_module = Llvmenv.the_module
let void_type = Llvm.void_type context
let i32_type = Llvm.i32_type context
let i32star_type = Llvm.pointer_type i32_type
let anystar_type = Llvm.pointer_type (Llvm.i8_type context)
6.
These helper functions create or read-from memory object.
Currently LLVM compiles using a very simple strategy: every value is
boxed (including integers and floats). This simplifies compilation a
lot: every value we create has type void *, and we cast the type
from void * according to how we use it.
LLVM does not (yet?) know how to replace heap allocations with stack
allocations, so we should do that (using an escape analysis). But
LLVM has passes that allow promotion of stack allocations to
register ("mem2reg" and "scalarrepl"), so once this is done (plus
passing and returning arguments in registers), many values should be
unboxed by the compiler (and this would not be that inefficient).
Additional performances could then be obtained by monomorphizing the
code.
7.
Store llvalue
in heap-allocated memory.
let build_box name llvalue builder =
let lltype = Llvm.type_of llvalue in
let pointer = Llvm.build_malloc lltype (name ^ "_uncasted") builder in
ignore(Llvm.build_store llvalue pointer builder);
Llvm.build_bitcast pointer anystar_type name builder
llvalue
of type lltype
.
let build_unbox name llvalue lltype builder =
let typeptr = Llvm.pointer_type lltype in
let castedptr = Llvm.build_bitcast llvalue typeptr (name ^ "_casted") builder in
Llvm.build_load castedptr name builder
anystar_type
. Each
element of the array contains the llvalue in l.
let build_tuple name l builder =
let length = List.length l in
let array_type = Llvm.array_type anystar_type length in
let pointer = Llvm.build_malloc array_type (name ^ "_tuple") builder in
let f elem int =
(∗ Note: the first 0 is because pointer is not the start of
the array, but a pointer to the start of the array, that
must thus be dereferenced. ∗)
let path = [| (Llvm.const_int i32_type 0); (Llvm.const_int i32_type int) |] in
let gep_ptr = Llvm.build_gep pointer path (name ^ "_tuple_" ^ (string_of_int int)) builder in
ignore(Llvm.build_store elem gep_ptr builder) in
List.iter_with_index f l;
Llvm.build_bitcast pointer anystar_type name builder
let build_letproj name pointer i builder =
(∗ First we compute an acceptable LLvm type, and cast the pointer to
that type (failure to do that makes Llvm.build_gep
segfault).
As we try to access the ith element, we assume we are accessing
an array of size i+1. ∗)
let array_type = Llvm.array_type anystar_type (i+1) in
let arraystar_type = Llvm.pointer_type array_type in
let cast_pointer = Llvm.build_bitcast pointer arraystar_type (name ^ "_casted") builder in
let gep_ptr = Llvm.build_gep cast_pointer [| (Llvm.const_int i32_type 0);
(Llvm.const_int i32_type i) |]
(name ^ "_gep" ^ (string_of_int i)) builder in
let result = Llvm.build_load gep_ptr name builder in
result
module Variant:sig
open Llvm
val build:string → llvalue → llvalue → llbuilder → llvalue
val bind: string → llvalue → llbuilder → (llvalue × llvalue)
end = struct
let variant_type = Llvm.struct_type context [| i32_type; anystar_type |]
let variant_star_type = Llvm.pointer_type variant_type
let get_variant_ptrs name ptr builder =
let cast_pointer = Llvm.build_bitcast ptr variant_star_type (name ^ "_casted") builder in
let ptr_to_tag = Llvm.build_gep cast_pointer [| (Llvm.const_int i32_type 0);
(Llvm.const_int i32_type 0) |]
(name ^ "_tag_ptr") builder in
let tag = Llvm.build_load ptr_to_tag (name ^ "_tag") builder in
let ptr_to_value = Llvm.build_gep cast_pointer [| (Llvm.const_int i32_type 0);
(Llvm.const_int i32_type 1) |]
(name ^ "_value_ptr") builder in
(ptr_to_tag,ptr_to_value)
(∗ Note: tag is a i32bit unboxed llvalue. value is a anystar_type llvalue. ∗)
let build name tag value builder =
let ptr = Llvm.build_malloc variant_type (name ^ "_variant") builder in
let (ptr_to_tag, ptr_to_value) = get_variant_ptrs name ptr builder in
ignore(Llvm.build_store tag ptr_to_tag builder);
ignore(Llvm.build_store value ptr_to_value builder);
Llvm.build_bitcast ptr anystar_type name builder
let bind name ptr builder =
let (ptr_to_tag, ptr_to_value) = get_variant_ptrs name ptr builder in
let tag = Llvm.build_load ptr_to_tag (name ^ "_tag") builder in
let value = Llvm.build_load ptr_to_value (name ^ "_value") builder in
(tag,value)
let build_boolean name value builder =
let ext_value = Llvm.build_zext_or_bitcast value i32_type (name ^ "_icmp_ext") builder in
Variant.build name ext_value undef_anystar builder
let build_integer_binary_op name op a b builder =
let build_fn = match op with
∣ Constant.Ibop.Add → Llvm.build_add
∣ Constant.Ibop.Sub → Llvm.build_sub
∣ Constant.Ibop.Mul → Llvm.build_mul
∣ Constant.Ibop.Div → Llvm.build_udiv in
let a_unbox = (build_unbox (name ^ "_a") a i32_type builder) in
let b_unbox = (build_unbox (name ^ "_b") b i32_type builder) in
let res = build_fn a_unbox b_unbox (name ^ "_bop") builder in
build_box name res builder
let build_integer_comparison name op a b builder =
let llvm_pred = match op with
∣ Constant.Ibpred.Eq → Llvm.Icmp.Eq
∣ Constant.Ibpred.Ne → Llvm.Icmp.Ne
∣ Constant.Ibpred.Ugt → Llvm.Icmp.Ugt
∣ Constant.Ibpred.Uge → Llvm.Icmp.Uge
∣ Constant.Ibpred.Ult → Llvm.Icmp.Ult
∣ Constant.Ibpred.Ule → Llvm.Icmp.Ule
∣ Constant.Ibpred.Sgt → Llvm.Icmp.Sgt
∣ Constant.Ibpred.Sge → Llvm.Icmp.Sge
∣ Constant.Ibpred.Slt → Llvm.Icmp.Slt
∣ Constant.Ibpred.Sle → Llvm.Icmp.Sle in
let a_unbox = (build_unbox (name ^ "_a") a i32_type builder) in
let b_unbox = (build_unbox (name ^ "_b") b i32_type builder) in
let res = Llvm.build_icmp llvm_pred a_unbox b_unbox (name ^ "_icmp") builder in
build_boolean (name ^ "_boolean") res builder
caller
to a function pointer.
let build_call name caller callees builder =
let function_type = Llvm.pointer_type (Llvm.function_type anystar_type [| anystar_type; anystar_type |]) in
let casted_caller = Llvm.build_bitcast caller function_type (name ^ "_function") builder in
let retval = Llvm.build_call casted_caller (Array.of_list callees) (name ^"_result") builder in
retval
15.
This special value is used to ensure, via the type checker, that
compilation to LLVM never leaves a basic-block halfly built. LLVM
basic blocks should all end with a terminator instruction; whenever
one is inserted, the function should return End_of_block
. When
building non-terminator instructions, the code must continue
building the basic block.
type termination = End_of_block
Note that LLVM basic blocks are associated to a parent function,
that we need to retrieve to create a new basic block.
let new_block name builder =
let current_bb = Llvm.insertion_block builder in
let the_function = Llvm.block_parent current_bb in
let new_bb = Llvm.append_block context name the_function in
new_bb
Some(phi)
if the block already begins with a phi instruction,
or None
otherwise.
let begin_with_phi_node basic_block =
let pos = Llvm.instr_begin basic_block in
match pos with
∣ Llvm.At_end(_) → None
∣ Llvm.Before(inst) →
(match Llvm.instr_opcode inst with
∣ Llvm.Opcode.PHI → Some(inst)
∣ _ → None)
let with_new_block name builder f =
let current_bb = Llvm.insertion_block builder in
let new_bb = new_block name builder in
Llvm.position_at_end new_bb builder;
f();
Llvm.position_at_end current_bb builder;
new_bb
let new_unreachable_block builder =
with_new_block "unreachable" builder (fun () → Llvm.build_unreachable builder)
destination_block
, also passing
the v
value. This is achieved by setting v
as an incoming value
for the phi instruction that begins destination_block
. If
destination_block
does not start with a phi node, then it is the
first time that destination_block
is called, and we create this
phi node.
let build_jmp_to_and_add_incoming destination_block v builder =
let add_incoming_to_block basic_block (value,curblock) =
match begin_with_phi_node basic_block with
∣ Some(phi) → Llvm.add_incoming (value,curblock) phi
∣ None →
(∗ Temporarily create a builder to build the phi instruction. ∗)
let builder = Llvm.builder_at context (Llvm.instr_begin basic_block) in
ignore(Llvm.build_phi [value,curblock] "phi" builder) in
let current_basic_block = Llvm.insertion_block builder in
add_incoming_to_block destination_block (v, current_basic_block);
ignore(Llvm.build_br destination_block builder);
End_of_block
x
of the call k( x)
is returned;x
of
the call k( x)
is passed to the phi node starting this basic
block.The CPS→LLVM translation maps continuation variables to
dest_type
s.
type dest_type =
∣ Ret
∣ Jmp_to of Llvm.llbasicblock
k x
, but k
and x
are already translated to their corresponding dest_type
and llvalue
.
let build_applycont k x builder =
match k with
∣ Ret → ignore(Llvm.build_ret x builder); End_of_block
∣ Jmp_to(destination) → build_jmp_to_and_add_incoming destination x builder
k
. Even if continuations are translated to a code label, calling a
continuation also requires to pass an argument x
. This function
creates a small basic block that just calls the k
with the
argument x
, to be used by such LLVM instructions.
let basic_block_that_calls name k x builder =
with_new_block name builder (fun () →
build_applycont k x builder)
It is important for LLVM that function names are unique.
module UniqueFunctionId = Unique.Make(struct end)
let uniquify_name name = name ^ "_uniq" ^ (UniqueFunctionId.to_string (UniqueFunctionId.fresh()))
contvarmap
, a mapping from local
continuation variables to dest_type; globalvarmap
, a mapping from
the global variables to llvalues; varmap
, containing a mapping
from both the global and local variables to llvalues; and
handle_halt
, which explains how Halt
is translated.
type env = { contvarmap: dest_type Cont_var_Map.t;
varmap: Llvm.llvalue Var_Map.t;
globalvarmap: Llvm.llvalue Var_Map.t;
handle_halt: handle_halt
}
Halt(x)
CPS term must be translated:
either we return x
, or we ignore x
return nothing, or x
is
stored in some memory region.
and handle_halt =
∣ Halt_returns_value
∣ Halt_returns_void
∣ Halt_stores_results_in of Llvm.llvalue
cps
, in the current block
pointed to by builder
. varmap
maps CPS variables to LLVM
llvalues. contvarmap
maps CPS continuation variables to values of
type contvar_type
.All the free variables or continuation variables in cps
must be
in contvarmap
or in varmap
. cps
can contain lambda, but they
must not contain any free variables or free continuation variables
(even the one in varmap
and contvarmap
). Closure conversion
deals with this. Note: previously-defined global variables are not
considered free.
let rec build_term cps env builder =
let translate_occurrence x =
let bound_var = Var.Occur.binding_variable x in
let llvalue =
try Var_Map.find bound_var env.varmap
with _ → failwith ("in translate_var " ^ (Var.Occur.to_string x)) in
match Var.Var.binding_site bound_var with
(∗ Global dynamic values are allocated with an extra level of
indirection, so we need to unbox them. ∗)
∣ Enclosing_definition(Definition(_,Dynamic_value(_))) →
build_unbox (Var.Occur.to_string x) llvalue anystar_type builder
(∗ Note: we could directly return constant integer here. It
seems not worth it, because LLVM should be able to deal
with them itself. ∗)
∣ _ → llvalue
in
let translate_cont_occurrence k =
try Cont_var_Map.find (Cont_var.Occur.binding_variable k) env.contvarmap
with _ → failwith "in translate_cont_occurrence" in
let add_to_varmap var value = Var_Map.add var value env.varmap in
let add_to_contvarmap contvar block = Cont_var_Map.add contvar (Jmp_to block) env.contvarmap in
To keep the implementation simple, all values are boxed (i.e. put
in the heap and accessed through a pointer), and of llvm type "i8
*". Pointer conversions are done according to the use of the
value.
match Expression.get cps with
Let_prim(x,prim,body)
we just build the new llvalue
corresponding to prim
, map it to x
, then continue building
body
.
∣ Let_prim(x,prim,body) →
let xname = (Var.Var.to_string x) in
let result = (match prim with
∣ Value( Constant(Constant.Integer i)) →
let llvalue = Llvm.const_int i32_type i in
build_box (xname ^ "_is_const_" ^ string_of_int i) llvalue builder
∣ Value( Constant(Constant.Float(_) ∣ Constant.String(_))) →
failwith "Float and strings not yet implemented"
∣ Value( External( id)) →
let llvalue = Llvmenv.lookup_global id in
Llvm.build_bitcast llvalue anystar_type ("external_" ^ id) builder
∣ Value( Tuple [ ]) →
Llvm.undef anystar_type
∣ Value( Tuple(l)) →
let llvalues = List.map translate_occurrence l in
build_tuple xname llvalues builder
∣ Value( Injection( i,_,value)) →
let llvalue = translate_occurrence value in
Variant.build xname (Llvm.const_int i32_type i) llvalue builder
Note that build_function
will use a new builder, so the
lambda can be built in parallel with the current
function. Also it will use new variables and continuation
variable maps (with only the x parameter), so the lambda
expression must not contain any free variables.
∣ Value( Lambda(ft,k,vl,body)) → assert(ft ≡ No_environment);
let funname = ((Var.Var.to_string x) ^ "fun") in
TODO: Extend this to any mutually recursive value
(Lamdba, Tuples, Injections). This is an argument for
separating let_prim(x,prim,body) from
let_values((x1,value1);...(xn,valuen)
,body).
FIXME: The function is build from env.globalvarmap
. This
can cause issues when an inner function recursively calls
the function in which it is defined. It works currently
because the closure conversion algorithm pass the outer
function in the environment, but optimisations will break
that. One solution would be to lift the lamdba to global
scope. Another solution would be to pass the current
varmap, but then cpsllvm will not be able to catch some
errors.
let the_function = declare_llvm_function funname (List.length vl) true in
let the_function = Llvm.build_bitcast the_function anystar_type (funname ^ "cast") builder in
let function_build_map = Var_Map.add x the_function env.globalvarmap in
let f = build_function funname k vl body function_build_map in
Llvm.set_linkage Llvm.Linkage.Private f;
Llvm.build_bitcast f anystar_type xname builder
∣ Integer_binary_operation(op,xa,xb) →
build_integer_binary_op xname op (translate_occurrence xa) (translate_occurrence xb) builder
∣ Integer_binary_predicate(pred,xa,xb) →
build_integer_comparison xname pred (translate_occurrence xa) (translate_occurrence xb) builder
∣ Projection(i,x) → build_letproj xname (translate_occurrence x) i builder
∣ Value (Constant(c)) → print_endline (Constant.to_string c);
failwith "ICE: primitive operations as value in LLVM translation."
)
in build_term body {env with varmap=(add_to_varmap x result)} builder
k
, then build body
, then build
term
(if k
is really called), binding x
to the phi
node.
∣ Let_cont(k,_,_,body) when
Cont_var.Var.number_of_occurrences k ≡ Cont_var.Var.No_occurrence →
build_term body env builder
k
is never called (so we do not
bother building it).Doing the operations in this order ensures that calls to k
are
processed before k
is built.
∣ Let_cont(k,x,term,body) →
let new_bb = new_block (Cont_var.Var.to_string k) builder in
let newcvm = add_to_contvarmap k new_bb in
let End_of_block = build_term body {env with contvarmap=newcvm} builder in
Llvm.position_at_end new_bb builder;
(match begin_with_phi_node new_bb with
∣ None → End_of_block
∣ Some(phi) → build_term term {env with contvarmap=newcvm; varmap=add_to_varmap x phi} builder)
∣ Apply_cont(k,x) →
build_applycont (translate_cont_occurrence k) (translate_occurrence x) builder
k
. LLVM
optimizations will eliminate the superfluous jump if needed.
∣ Apply(ft,func,k,args) → assert(ft ≡ No_environment);
let retval = build_call
(Var.Occur.to_string func)
(translate_occurrence func)
(List.map translate_occurrence args) builder in
build_applycont (translate_cont_occurrence k) retval builder
∣ Case(x,cases,default) →
begin
let xval = translate_occurrence x in
let cases_nb = CaseMap.cardinal cases in
let default_bb = (match default with
∣ None → new_unreachable_block builder
∣ Some(k) →
basic_block_that_calls
("bb_" ^ (Cont_var.Occur.to_string k))
(translate_cont_occurrence k) xval builder) in
let (tag,value) = Variant.bind (Var.Occur.to_string x) xval builder in
let switch = Llvm.build_switch tag default_bb cases_nb builder in
CaseMap.iter (fun i k →
Llvm.add_case switch (Llvm.const_int i32_type i)
(basic_block_that_calls
("bb_" ^ (Cont_var.Occur.to_string k))
(translate_cont_occurrence k) value builder))
cases;
End_of_block
end
∣ Halt(x) → (match env.handle_halt with
∣ Halt_returns_void → ignore(Llvm.build_ret_void builder)
∣ Halt_returns_value → ignore(Llvm.build_ret (translate_occurrence x) builder)
∣ Halt_stores_results_in(llvalue) →
Llvm.build_store (translate_occurrence x) llvalue builder;
ignore(Llvm.build_ret_void builder)
); End_of_block
name
, numparams
parameters.
returns
if true if the function returns a value, and false if it
returns void.
and declare_llvm_function name numparams returns =
match (Llvm.lookup_function name the_module) with
∣ Some(f) → f
∣ None →
let args_type = Array.make numparams anystar_type in
let ret_type = if returns then anystar_type else void_type in
let function_type = Llvm.function_type ret_type args_type in
let the_function = Llvm.declare_function name function_type the_module in
the_function
name
, a string name
does not need to be unique, just
informative.params
is Some(cont_var,var)
if the LLvm function takes
arguments, or None otherwise.cpsbody
is the CPS term representing the body of the
function to be translated.handle_halt
states how Halt(x)
CPS terms must be
translated.globalvarmap
is the mapping from global CPS variables to
llvalues.
and created_functions = ((Hashtbl.create 47):(string, unit) Hashtbl.t)
and build_llvm_function name ~params cpsbody handle_halt globalvarmap =
name
must already be uniquifed by the caller. The
hashtable allows to check that: a name is in the hashtable iff
a function with the same name has been built.
if Hashtbl.mem created_functions name
then failwith ("Calling build_llvm_function twice with name ‘" ^ name ^"’")
else Hashtbl.add created_functions name ();
let numparams = match params with
∣ Some(_,l) → (List.length l)
∣ None → 0 in
let returns = match handle_halt with
∣ Halt_returns_value → true
∣ Halt_stores_results_in _ ∣ Halt_returns_void → false in
let the_function = declare_llvm_function name numparams returns in
the_function
is created.
let (initial_contvarmap, initial_varmap) = match params with
∣ Some(k,l) → (Cont_var_Map.singleton k Ret,
List.fold_left_with_index (fun map x i →
Var_Map.add x (Llvm.param the_function i) map)
globalvarmap l)
∣ None → (Cont_var_Map.empty, globalvarmap) in
let initial_env = { contvarmap = initial_contvarmap;
varmap = initial_varmap;
globalvarmap = globalvarmap;
handle_halt = handle_halt
} in
let bb = Llvm.append_block context "entry" the_function in
(∗ Note that we use a new builder. If OCaml supported SMP, functions
could even be built in parallel. ∗)
let builder = Llvm.builder context in
Llvm.position_at_end bb builder;
try
ignore(build_term cpsbody initial_env builder);
(∗ Prints the textual representation of the function to stderr. ∗)
if Log.Llvm_output.is_output Log.Debug
then Llvm.dump_value the_function
else ();
(∗ Validate the code we just generated. ∗)
Llvm_analysis.assert_valid_function the_function;
the_function
(∗ Normally, no exception should be thrown, be we never know. ∗)
with e → Llvm.delete_function the_function; raise e
and build_function name contparam params cpsbody globalvarmap =
build_llvm_function name ~params:(Some(contparam,params)) cpsbody Halt_returns_value globalvarmap
let build_unbound_def cpsbody globalvarmap =
build_llvm_function (uniquify_name "nodef") ~params:None cpsbody Halt_returns_void globalvarmap
let build_bound_def var cpsbody globalvarmap =
let varname = Var.Var.to_string var in
let funname = ("construct_" ^ varname) in
let the_variable = Llvm.define_global varname undef_anystar the_module in
let the_function =
build_llvm_function funname ~params:None cpsbody (Halt_stores_results_in the_variable) globalvarmap in
(the_variable, the_function)
let build_definition def globalvarmap =
let (Definition(visib,Dynamic_value(expr))) = def in
match visib with
(∗ The result of the expression is meaningful, and bound to a variable. ∗)
∣ Public(var) ∣ Private(var) →
let (the_variable, the_function) = build_bound_def var expr globalvarmap in
let newmap = Var_Map.add var the_variable globalvarmap in
(the_function, newmap)
(∗ We do not care about the result of the expression. ∗)
∣ Unused →
let the_function = build_unbound_def expr globalvarmap in
(the_function, globalvarmap)
module Stream = Extensions.Stream
let from_stream cps_stream =
let f state cps =
let (llvmdef, new_state) = build_definition cps state in
[llvmdef], new_state in
Stream.transformer f Base.Var.Var.Map.empty cps_stream