Commit 1cfad74e authored by Stefan Gränitz's avatar Stefan Gränitz
Browse files

[WIP] Cleanup Ocaml codegen for generic lambdas

parent 0e40dd95
......@@ -590,7 +590,7 @@ static uint64_t pointerToInt(T *ptr) {
return static_cast<uint64_t>(reinterpret_cast<uintptr_t>(ptr));
}
lambda_expr_instance
lambda_overload_instance
FramacVisitor::makeLambdaExprInstance(const clang::FunctionDecl *meth) {
qual_type result =
makeDefaultExternalNameType(
......@@ -604,7 +604,7 @@ FramacVisitor::makeLambdaExprInstance(const clang::FunctionDecl *meth) {
makeCodeBlock(meth->getBody(), meth->getDeclContext(), meth);
uint64_t addr = pointerToInt(meth);
assert(addr < (1ull << 63) && "Must fit in OCaml's signed int64");
return lambda_expr_instance_cons(result, arg_decls, addr, body_statements);
return lambda_overload_instance_cons(result, arg_decls, addr, body_statements);
}
exp_node FramacVisitor::makeLambdaExpr(const clang::LambdaExpr* lam) {
......
......@@ -1111,7 +1111,7 @@ private:
const clang::QualType& ret, exp_node call, const clang::Expr* expr);
exp_node makeLambdaExpr(const clang::LambdaExpr* lam);
arg_decl makeArgDecl(clang::ParmVarDecl &param);
lambda_expr_instance makeLambdaExprInstance(const clang::FunctionDecl *meth);
lambda_overload_instance makeLambdaExprInstance(const clang::FunctionDecl *meth);
exp_node makeTemporaryObjectExpression(
const clang::CXXTemporaryObjectExpr* constructor,
bool* shouldDelay, /* statement */ list* receiver);
......
......@@ -24,17 +24,23 @@ open Intermediate_format
open Cabs
open Cil
(* Create global fresh name based on given prefix *)
let fresh_names s =
let nb = ref (-1) in
fun () ->
incr nb;
if !nb = 0 then s else s ^ "_" ^ string_of_int !nb
s ^ "_" ^ string_of_int !nb
let lambda_def_name = "__fc_lambda_def"
let lambda_apply_name = "__fc_lambda_apply"
let lambda_unique_def_name = fresh_names lambda_def_name
let unique_lambda_def_name = fresh_names lambda_def_name
let lambda_unique_overload_name id = "__fc_lambda_overload_" ^ Int64.to_string id
(* Create fresh local name based on reserved prefix __fc_lambda_tmp *)
let lambda_local_init_helper_name env = Convert_env.temp_name env "__fc_lambda_tmp"
let closure_name = "__fc_closure"
let fc_implicit_attr = "__fc_implicit"
......@@ -166,8 +172,6 @@ let is_unsigned_kind = function
| ILong | ILongLong -> false
| IULong | IULongLong -> true
let closure_name = "__fc_closure"
let mk_expr_l expr_loc expr_node = { expr_loc; expr_node }
let mk_expr env node = mk_expr_l (Convert_env.get_loc env) node
......@@ -211,6 +215,12 @@ let make_closure_access env id_name is_ref =
let access = MEMBEROFPTR (mk_var env closure_name, id_name) in
if is_ref then UNARY(MEMOF,mk_expr env access) else access
let mk_signature res_type param_types =
{ result = res_type; parameter = param_types; variadic = false }
let mk_arg_decl ty name loc =
{ arg_type = ty; arg_name = name; arg_loc = loc; }
let convert_variable env = function
| Local({ decl_name = "__func__" }) ->
CONSTANT(CONST_STRING (Convert_env.get_current_func_name env))
......@@ -1343,9 +1353,8 @@ and convert_expr_node ?(drop_temp=false) env aux e does_remove_virtual =
convert_list_expr env aux args does_remove_virtual
in
let args = mk_addrof env callee :: args in
let apply_name = lambda_apply_name ^ "_" ^ Int64.to_string id in
env, aux,
CALL(mk_expr_l loc (MEMBEROF (callee, apply_name)), args, [])
let mem_fn_name = lambda_unique_overload_name id in
env, aux, CALL(mk_expr_l loc (MEMBEROF (callee, mem_fn_name)), args, [])
| Static_call(name, signature, kind, args, t, is_extern_c) ->
let cname =
if is_extern_c then name.decl_name
......@@ -1708,128 +1717,122 @@ and convert_expr_node ?(drop_temp=false) env aux e does_remove_virtual =
| InitializerList _ ->
Frama_Clang_option.not_yet_implemented
"Initializer list without Compound initialization"
| LambdaExpr(insts, closure) ->
| LambdaExpr(overloads, closures) ->
let loc = Convert_env.get_loc env in
let sigs = List.map (fun inst -> {
result = inst.return_type;
parameter = List.map (fun arg -> arg.arg_type) inst.arg_decls;
variadic = false
}) insts in
let closure_type = Lambda (sigs, closure) in
let closure_name = Mangling.mangle_cc_type closure_type in
let lam_name = Convert_env.temp_name env "__fc_lam" in
let lam_decl =
let make_signature overload =
{ result = overload.return_type;
parameter = List.map (fun arg -> arg.arg_type) overload.arg_decls;
variadic = false
} in
let signatures = List.map make_signature overloads in
let lam_type = Lambda (signatures, closures) in
let struct_name = Mangling.mangle_cc_type lam_type in
let init_helper_name = lambda_local_init_helper_name env in
let init_helper_decl =
DECDEF(
None,
([ SpecCV CV_CONST; SpecType (Tstruct(closure_name, None,[]))],
[(lam_name, JUSTBASE, [], loc), NO_INIT ]),loc);
([ SpecCV CV_CONST; SpecType (Tstruct(struct_name, None,[]))],
[(init_helper_name, JUSTBASE, [], loc), NO_INIT ]),loc);
in
let aux = add_local_aux_def aux lam_decl in
let type_def = convert_lambda_type env closure_type insts closure in
let env = Convert_env.add_c_global env type_def in
let aux = add_local_aux_def aux init_helper_decl in
let env = Convert_env.add_local_var env init_helper_name lam_type in
let struct_def = convert_lambda_type env lam_type overloads closures in
let env = instantiate_lambda_type env struct_def closures in
let (env, aux) = convert_lambda_instantiations
env lam_name lam_decl closure_type
insts closure aux in
env, aux, VARIABLE lam_name
env init_helper_name lam_type
overloads closures aux in
env, aux, VARIABLE init_helper_name
in
env, aux, mk_expr env node
and convert_lambda_instantiations env lam_name lam_decl closure_type insts closure aux =
match insts with
(* Create the type definition for a function pointer to one lambda overload *)
and lambda_init_overload_fptr lam_type ovl =
let fn_ptr_param =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lam_type))) in
let arg_types = (List.map (fun x -> x.arg_type) ovl.arg_decls) in
let fn_sig = mk_signature ovl.return_type (fn_ptr_param :: arg_types) in
Cxx_utils.unqual_type (Pointer (PFunctionPointer fn_sig))
(* Create the definition of the struct that represents the lambda instance *)
and convert_lambda_type env lam_type overloads closures =
let loc = Convert_env.get_loc env in
let field_of_capture cap =
let s, t = capture_name_type env cap in
let rt, decl = convert_specifiers env t false in
FIELD (rt, [ (s, decl JUSTBASE, [], loc), None ])
in
let field_of_functions ovl =
let fptr = lambda_init_overload_fptr lam_type ovl in
let name = lambda_unique_overload_name ovl.id in
let rt, decl = convert_specifiers env fptr false in
FIELD (rt, [(name, decl JUSTBASE, [], loc), None])
in
let cap_fields = List.map field_of_capture closures in
let fptr_fields = List.map field_of_functions overloads in
let struct_name = Mangling.mangle_cc_type lam_type in
ONLYTYPEDEF (
[SpecType (Tstruct(struct_name, Some (fptr_fields @ cap_fields),[]))],loc)
(* Create a local instance and initialize the captures (TODO) *)
and instantiate_lambda_type env struct_def closures =
let _unused = closures in
Convert_env.add_c_global env struct_def
and convert_lambda_instantiations env init_helper_name lam_type overloads closures aux =
match overloads with
| [] -> (env, aux)
| inst::insts ->
| ovl::overloads ->
let (env, aux) = convert_lambda_single_instance
env lam_name lam_decl closure_type
inst closure aux in
env init_helper_name lam_type
ovl closures aux in
convert_lambda_instantiations
env lam_name lam_decl closure_type
insts closure aux
env init_helper_name lam_type
overloads closures aux
and convert_lambda_single_instance env lam_name lam_decl closure_type inst closure aux =
let _ = lam_decl in
let apply_name = lambda_apply_name ^ "_" ^ Int64.to_string inst.id in
let arg_types = (List.map (fun x -> x.arg_type) inst.arg_decls) in
and convert_lambda_single_instance env init_helper_name lam_type ovl closures aux =
let cons_def =
convert_lambda_constructor env closure_type inst.return_type arg_types inst.id apply_name closure
convert_lambda_init env lam_type ovl closures
in
let env = Convert_env.add_c_global env cons_def in
let env = Convert_env.add_closure_info env closure in
let env = Convert_env.add_closure_info env closures in
let env, body_name, glob =
convert_lambda_body env closure_type inst
convert_lambda_body env lam_type ovl
in
let env = Convert_env.add_c_global env glob in
let env = Convert_env.reset_closure env in
let env = Convert_env.add_local_var env lam_name closure_type in
let lam_init =
init_lambda_object env closure_type lam_name inst.id body_name closure
convert_lambda_init_call env lam_type init_helper_name ovl.id body_name closures
in
let aux = add_local_aux_init aux lam_init in
env, aux
and convert_lambda_type env lam_type insts closures =
let name = Mangling.mangle_cc_type lam_type in
let loc = Convert_env.get_loc env in
let field_of_capture cap =
let s, t = capture_name_type env cap in
let rt, decl = convert_specifiers env t false in
FIELD (rt, [ (s, decl JUSTBASE, [], loc), None ])
in
let cap_fields = List.map field_of_capture closures in
let field_of_functions inst =
let lam_ptr_type =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lam_type))) in
let apply_name = lambda_apply_name ^ "_" ^ Int64.to_string inst.id in
let arg_types = (List.map (fun x -> x.arg_type) inst.arg_decls) in
let parameter = lam_ptr_type :: arg_types in
let result = inst.return_type in
let fptr =
Cxx_utils.unqual_type (
Pointer (PFunctionPointer { result; parameter; variadic = false })) in
let rt, decl = convert_specifiers env fptr false in
FIELD (rt, [(apply_name, decl JUSTBASE, [], loc),None])
in
let fptr_fields = List.map field_of_functions insts in
ONLYTYPEDEF (
[SpecType (Tstruct(name, Some (fptr_fields @ cap_fields),[]))],loc)
and convert_lambda_constructor env lam_type result params id apply_name closures =
and convert_lambda_init env lam_type ovl closures =
let loc = Convert_env.get_loc env in
let cloc = Convert_env.get_clang_loc env in
let lambda_name = Mangling.mangle_cc_type lam_type in
let func_name = lambda_name ^ "_" ^ Int64.to_string id in
let lam_ptr_type =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lam_type)))
in
let lam_ptr_arg_decl =
{ arg_type = lam_ptr_type;
arg_name = closure_name; (* global variable!! *)
arg_loc = cloc; }
in
let parameter = lam_ptr_type :: params in
let fptr_type =
Cxx_utils.unqual_type
(Pointer (PFunctionPointer { result; parameter; variadic = false }))
in
let fptr_arg_decl =
{ arg_type = fptr_type;
arg_name = "__fc_func";
arg_loc = cloc; }
in
let struct_name = Mangling.mangle_cc_type lam_type in
let ctor_name = struct_name ^ "_init_" ^ Int64.to_string ovl.id in
let fptr_type = lambda_init_overload_fptr lam_type ovl in
let fptr_arg_decl = mk_arg_decl fptr_type "__fc_func" cloc in
let make_closure_arg_decl cap =
let (arg_name, arg_type) = capture_name_type env cap in
{ arg_name; arg_type; arg_loc = cloc }
in
let closure_arg_decls = List.map make_closure_arg_decl closures in
let args = lam_ptr_arg_decl :: fptr_arg_decl :: closure_arg_decls in
let fn_ptr_param =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lam_type))) in
let this_ptr = mk_arg_decl fn_ptr_param closure_name cloc in
let captures = List.map make_closure_arg_decl closures in
let args = this_ptr :: fptr_arg_decl :: captures in
let env, proto =
make_prototype loc env func_name (FKConstructor true)
make_prototype loc env ctor_name (FKConstructor true)
(Cxx_utils.unqual_type Void) args false false
in
let fn_name = lambda_unique_overload_name ovl.id in
let body = List.map (make_assign_cap env) closures in
let body =
make_computation env
(mk_assign env
(mk_expr env (make_closure_access env apply_name false))
(mk_expr env (make_closure_access env fn_name false))
(mk_var env "__fc_func"))
:: body
in
......@@ -1880,16 +1883,16 @@ and make_assign_cap env cap =
and convert_lambda_body env lam_type lam_inst =
let loc = Convert_env.get_loc env in
let name = unique_lambda_def_name () in
let lam_ptr_type =
let name = lambda_unique_def_name () in
let fn_ptr_type =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lam_type)))
in
let lam_ptr_arg_decl =
{ arg_type = lam_ptr_type;
let mem_fn_this_ptr =
{ arg_type = fn_ptr_type;
arg_name = closure_name;
arg_loc = Convert_env.get_clang_loc env }
in
let arg_decls = lam_ptr_arg_decl :: lam_inst.arg_decls in
let arg_decls = mem_fn_this_ptr :: lam_inst.arg_decls in
let env, full_name =
make_prototype loc env name FKFunction lam_inst.return_type arg_decls false false
in
......@@ -1898,14 +1901,14 @@ and convert_lambda_body env lam_type lam_inst =
let env = Convert_env.unscope benv env in
env, name, FUNDEF (None, full_name, raw_block cbody,loc,loc)
and init_lambda_object
env closure_type lam_name id body_name closure =
let closure_name = Mangling.mangle_cc_type closure_type in
let f = mk_var env (closure_name ^ "_" ^ Int64.to_string id) in
let lam = mk_addrof env (mk_var env lam_name) in
and convert_lambda_init_call
env lam_type init_helper_name id body_name closures =
let struct_name = Mangling.mangle_cc_type lam_type in
let f = mk_var env (struct_name ^ "_init_" ^ Int64.to_string id) in
let lam = mk_addrof env (mk_var env init_helper_name) in
let ptr = mk_var env body_name in
let mk_arg cap = mk_var env (fst (capture_name_type env cap)) in
let args = List.map mk_arg closure in
let args = List.map mk_arg closures in
let call = mk_expr env (CALL(f,lam :: ptr :: args,[])) in
make_computation env call
......
......@@ -264,7 +264,7 @@ type reference_or_pointer_kind =
| RPKDynamicReference { origin_type : qual_type; pvmt : expression; }
;;
type lambda_expr_instance =
type lambda_overload_instance =
{ return_type: qual_type; arg_decls: arg_decl list; id: int64; impl: statement list; }
;;
......@@ -334,7 +334,7 @@ type exp_node =
| Throw { sub: expression option; }
| GnuBody { body: statement list; }
| LambdaExpr {
instances: lambda_expr_instance list;
overloads: lambda_overload_instance list;
captures: capture list;
}
;;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment