Commit 71d5cf4b authored by Stefan Gränitz's avatar Stefan Gränitz
Browse files

[WIP] Store multiple instantiations/signatures per LambdaExpr/Lambda-decl in AST

parent 4158dd22
......@@ -1709,40 +1709,63 @@ 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(rt, args, closure, body) ->
| LambdaExpr(insts, closure) ->
let loc = Convert_env.get_loc env in
let closure_type = Cxx_utils.make_lambda_type rt args closure 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 type_def = convert_lambda_type env closure_type rt args closure in
let env = Convert_env.add_c_global env type_def in
let cons_def =
convert_lambda_constructor env closure_type rt args closure
in
let env = Convert_env.add_c_global env cons_def in
let env = Convert_env.add_closure_info env closure in
let env, body_name, glob =
convert_lambda_body env closure_type rt args body
in
let env = Convert_env.add_c_global env glob in
let env = Convert_env.reset_closure env in
let lam_name = Convert_env.temp_name env "__fc_lam" 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 body_name closure
in
let lam_decl =
DECDEF(
None,
([ SpecCV CV_CONST; SpecType (Tstruct(closure_name, None,[]))],
[(lam_name, JUSTBASE, [], loc), NO_INIT ]),loc)
[(lam_name, JUSTBASE, [], loc), NO_INIT ]),loc);
in
let aux = add_local_aux_def_init aux lam_decl lam_init in
let (env, aux) = convert_lambda_instatiations
env lam_name lam_decl closure_type
insts closure aux in
env, aux, VARIABLE lam_name
in
env, aux, mk_expr env node
and convert_lambda_type env lambda_type result arguments closures =
let name = Mangling.mangle_cc_type lambda_type in
and convert_lambda_instatiations env lam_name lam_decl closure_type insts closure aux =
match insts with
| [] -> (env, aux)
| inst::insts ->
let (env, aux) = convert_lambda_single_instance
env lam_name lam_decl closure_type
inst closure aux in
convert_lambda_instatiations
env lam_name lam_decl closure_type
insts closure aux
and convert_lambda_single_instance env lam_name lam_decl closure_type inst closure aux =
let arg_types = (List.map (fun x -> x.arg_type) inst.arg_decls) in
let type_def = convert_lambda_type env closure_type inst.return_type arg_types closure in
let env = Convert_env.add_c_global env type_def in
let cons_def =
convert_lambda_constructor env closure_type inst.return_type arg_types closure
in
let env = Convert_env.add_c_global env cons_def in
let env = Convert_env.add_closure_info env closure in
let env, body_name, glob =
convert_lambda_body env closure_type inst
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 body_name closure
in
let aux = add_local_aux_def_init aux lam_decl lam_init in
env, aux
and convert_lambda_type env lam_type result params 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
......@@ -1750,11 +1773,10 @@ and convert_lambda_type env lambda_type result arguments closures =
FIELD (rt, [ (s, decl JUSTBASE, [], loc), None ])
in
let fields = List.map field_of_capture closures in
let obj_ptr =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lambda_type)))
let lam_ptr_type =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lam_type)))
in
let parameter = List.map (fun x -> x.arg_type) arguments in
let parameter = obj_ptr :: parameter in
let parameter = lam_ptr_type :: params in
let fptr =
Cxx_utils.unqual_type (
Pointer (PFunctionPointer { result; parameter; variadic = false }))
......@@ -1765,35 +1787,35 @@ and convert_lambda_type env lambda_type result arguments closures =
ONLYTYPEDEF (
[SpecType (Tstruct(name, Some (fptr_field :: fields),[]))],loc)
and convert_lambda_constructor env lambda_type result arguments closures =
and convert_lambda_constructor env lam_type result params 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 lambda_type in
let lambda_name = Mangling.mangle_cc_type lam_type in
let funcname = make_lambda_cons_name lambda_name in
let lam_type =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lambda_type)))
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_type :: (List.map (fun x -> x.arg_type) arguments) in
let parameter = lam_ptr_type :: params in
let fptr_type =
Cxx_utils.unqual_type
(Pointer (PFunctionPointer { result; parameter; variadic = false }))
in
let lam_prm =
{ arg_type = lam_type;
arg_name = closure_name;
arg_loc = cloc; }
in
let fptr_prm =
let fptr_arg_decl =
{ arg_type = fptr_type;
arg_name = "__fc_func";
arg_loc = cloc; }
in
let closure_arg cap =
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_prm = List.map closure_arg closures in
let args = lam_prm :: fptr_prm :: closure_prm 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 env, proto =
make_prototype loc env funcname (FKConstructor true)
(Cxx_utils.unqual_type Void) args false false
......@@ -1851,22 +1873,23 @@ and make_assign_cap env cap =
in
aux typ
and convert_lambda_body env lam_type rt args body =
and convert_lambda_body env lam_type lam_inst =
let loc = Convert_env.get_loc env in
let name = new_lambda_def_name () in
let lam_type =
let lam_ptr_type =
Cxx_utils.(force_ptr_to_const (obj_ptr (unqual_type lam_type)))
in
let lam_prm =
{ arg_type = lam_type;
let lam_ptr_arg_decl =
{ arg_type = lam_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 env, full_name =
make_prototype loc env name FKFunction rt (lam_prm :: args) false false
make_prototype loc env name FKFunction lam_inst.return_type arg_decls false false
in
let benv = Convert_env.add_formal_parameters env args in
let cbody, benv = convert_stmt_list benv body false in
let benv = Convert_env.add_formal_parameters env arg_decls in
let cbody, benv = convert_stmt_list benv lam_inst.impl false in
let env = Convert_env.unscope benv env in
env, name, FUNDEF (None, full_name, raw_block cbody,loc,loc)
......
......@@ -763,9 +763,6 @@ and get_dynamic_signature env e =
let signature = get_dynamic_signature env ptr.econtent in
get_signature_type env signature.result.plain_type
| Temporary(_, ctyp, _, _) -> get_signature_type env ctyp.plain_type
| LambdaExpr(result, args, _, _) ->
let parameter = List.map (fun x -> x.arg_type) args in
{ result; parameter; variadic = false }
| _ -> fatal env "no function type information for expression"
let add_closure_info env capture =
......
......@@ -408,10 +408,6 @@ let force_ptr_to_const p =
{ p with plain_type = Pointer (PDataPointer t) }
| _ -> p
let make_lambda_type result args closure =
let parameter = List.map (fun x -> x.arg_type) args in
Lambda ([{ result; parameter; variadic = false }], closure)
let plain_obj_ptr t = Pointer (PDataPointer t)
let plain_obj_lvref t = LVReference (PDataPointer t)
......
......@@ -73,9 +73,6 @@ val const_qual_type: qual_type -> qual_type
*)
val force_ptr_to_const: qual_type -> qual_type
(** creates a lambda type with the given signature and captured ids. *)
val make_lambda_type: qual_type -> arg_decl list -> capture list -> typ
(** given an object type, returns an unqualified pointer type to the object. *)
val obj_ptr: qual_type -> qual_type
......
......@@ -183,14 +183,7 @@ and pretty_type fmt typ =
-> Format.fprintf fmt "union %a"
pretty_qualified_name (name, tc)
| Named (qname, _) -> pretty_qualified_name fmt (qname, TStandard)
| Lambda (protos, cap) -> pretty_generic_lambda fmt protos cap
and pretty_capture fmt cap =
match cap with
| Cap_id (s,typ,is_ref) ->
Format.fprintf fmt "%a %s%s"
pretty_qual_type typ (if is_ref then "&" else "=") s
| Cap_this is_ref -> Format.fprintf fmt "%sthis" (if is_ref then "&" else "=")
| Lambda (sigs, caps) -> pretty_generic_lambda fmt sigs caps
and pretty_specifier fmt spec =
match spec with
......@@ -202,19 +195,25 @@ and pretty_qual_type fmt { qualifier = specs; plain_type = typ} =
Format.fprintf fmt "%a (%a)"
(Pretty_utils.pp_list ~sep:" " pretty_specifier) specs
pretty_type typ
and pretty_lambda fmt proto cap =
and pretty_capture fmt cap =
match cap with
| Cap_id (s,typ,is_ref) ->
Format.fprintf fmt "%a %s%s"
pretty_qual_type typ (if is_ref then "&" else "=") s
| Cap_this is_ref -> Format.fprintf fmt "%sthis" (if is_ref then "&" else "=")
and pretty_lambda fmt result params cap =
let pp_sep fmt () = Format.pp_print_string fmt ", " in
Format.fprintf fmt "lambda %a [%a]-> %a"
(Format.pp_print_list ~pp_sep pretty_qual_type)
proto.parameter
(Format.pp_print_list ~pp_sep pretty_qual_type) params
(Format.pp_print_list ~pp_sep pretty_capture) cap
pretty_qual_type proto.result
and pretty_generic_lambda fmt protos cap =
match protos with
pretty_qual_type result
and pretty_generic_lambda fmt signatures caps =
match signatures with
| [] -> ()
| p :: ps ->
pretty_lambda fmt p cap;
pretty_generic_lambda fmt ps cap
| s::sigs ->
pretty_lambda fmt s.result s.parameter caps;
pretty_generic_lambda fmt sigs caps
module Template_parameter =
Datatype.Make_with_collections(
......
......@@ -168,7 +168,7 @@ type typ =
(* body.ckind should be CUnion *)
| Named { name: qualified_name; is_extern_c_name : bool; } (* typedef *)
| Lambda {
proto : signature list;
proto: signature list;
closure: capture list;
} (* a lambda object of the given signature.
Note that normally each anonymous lambda object should give rise
......@@ -264,6 +264,10 @@ type reference_or_pointer_kind =
| RPKDynamicReference { origin_type : qual_type; pvmt : expression; }
;;
type lambda_expr_instance =
{ return_type: qual_type; arg_decls: arg_decl list; impl: statement list; }
;;
type exp_node =
| Constant { cst: compilation_constant; }
| String { cst: string; }
......@@ -330,10 +334,8 @@ type exp_node =
| Throw { sub: expression option; }
| GnuBody { body: statement list; }
| LambdaExpr {
lam_rt: qual_type;
lam_args: arg_decl list;
lam_closure: capture list;
lam_body: statement list;
instances: lambda_expr_instance list;
captures: capture list;
}
;;
......
......@@ -203,15 +203,14 @@ let rec mangle_cc_type = function
| Named (name,is_extern_c_name) ->
if is_extern_c_name then name.decl_name
else mangle_name_optt name TStandard
| Lambda (protos,cap) ->
| Lambda (signatures,cap) ->
(* NB: we depart from standard mangling rules here, in order to have
a contextless mangling, whereas Itanium ABI mangles according to
the number of lambda classes found in each function. *)
let proto = (match protos with
| p :: _ -> p
| [] -> Frama_Clang_option.not_yet_implemented
"Initializer list without Compound initialization") in
"Ul" ^ mangle_parameter proto.parameter ^ "EUc" ^ mangle_captures cap ^ "E_"
let rec mangle_all = function
| [] -> ""
| s::sigs -> mangle_parameter s.parameter ^ mangle_all sigs in
"Ul" ^ mangle_all signatures ^ "EUc" ^ mangle_captures cap ^ "E_"
(* not translated yet
| ArrayType(t,(DYN_SIZE | NO_SIZE)) ->
"A_" ^ mangle_cc_type t *)
......
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