Renamed StructReturn to structPassing

1 files changed, 0 insertions, 594 deletions

diff --git a/cparser/StructReturn.ml b/cparser/StructReturn.ml
deleted file mode 100644
index 3de05e19..00000000
--- a/cparser/StructReturn.ml
+++ /dev/null
@@ -1,594 +0,0 @@
-(* *********************************************************************)
-(*                                                                     *)
-(*              The Compcert verified compiler                         *)
-(*                                                                     *)
-(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
-(*                                                                     *)
-(*  Copyright Institut National de Recherche en Informatique et en     *)
-(*  Automatique.  All rights reserved.  This file is distributed       *)
-(*  under the terms of the GNU General Public License as published by  *)
-(*  the Free Software Foundation, either version 2 of the License, or  *)
-(*  (at your option) any later version.  This file is also distributed *)
-(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
-(*                                                                     *)
-(* *********************************************************************)
-
-(* Eliminate structs and unions that are
-   - returned by value as function results
-   - passed by value as function parameters. *)
-
-open Machine
-open C
-open Cutil
-open Transform
-
-let struct_return_style = ref SR_ref
-let struct_passing_style = ref SP_ref_callee
-
-(* Classification of function return types. *)
-
-type return_kind =
-  | Ret_scalar    (**r a scalar type, returned as usual *)
-  | Ret_ref       (**r a composite type, returned by reference *)
-  | Ret_value of typ * int * int
-                  (**r a small composite type, returned as an integer
-                       (type, size, alignment) *)
-
-let classify_return env ty =
-  if is_composite_type env ty then begin
-    match sizeof env ty, alignof env ty with
-    | Some sz, Some al ->
-        begin match !struct_return_style with
-        | SR_int1248 when sz = 1 || sz = 2 || sz = 4 ->
-            Ret_value (TInt(IUInt, []), sz, al)
-        | SR_int1248 when sz = 8 ->
-            Ret_value (TInt(IULongLong, []), sz, al)
-        | (SR_int1to4 | SR_int1to8) when sz <= 4 ->
-            Ret_value (TInt(IUInt, []), sz, al)
-        | SR_int1to8 when sz > 4 && sz <= 8 ->
-            Ret_value (TInt(IULongLong, []), sz, al)
-        | _ ->
-            Ret_ref
-        end
-    | _, _ ->
-        Ret_ref  (* should not happen *)
-  end else
-    Ret_scalar
-
-(* Classification of function parameter types. *)
-
-type param_kind =
-  | Param_unchanged     (**r passed as is *)
-  | Param_ref_caller    (**r passed by reference to a copy taken by the caller *)
-  | Param_flattened of int * int * int (**r passed as N integer arguments *)
-                        (**r (N, size, alignment) *)
-
-let classify_param env ty =
-  if is_composite_type env ty then begin
-    match !struct_passing_style with
-    | SP_ref_callee -> Param_unchanged
-    | SP_ref_caller -> Param_ref_caller
-    | _ ->
-      match sizeof env ty, alignof env ty with
-      | Some sz, Some al ->
-          Param_flattened ((sz + 3) / 4, sz, al)
-      | _, _ ->
-          Param_unchanged  (* should not happen *)
-  end else
-    Param_unchanged
-
-(* Return the list [f 0; f 1; ...; f (n-1)] *)
-
-let list_map_n f n =
-  let rec map i = if i >= n then [] else f i :: map (i + 1)
-  in map 0
-
-(* Declaring and accessing buffers (arrays of int) *)
-
-let uchar = TInt(IUChar, [])
-let ushort = TInt(IUShort, [])
-let uint = TInt(IUInt, [])
-let ulonglong = TInt(IULongLong, [])
-let ucharptr = TPtr(uchar, [])
-let ushortptr = TPtr(ushort, [])
-let uintptr = TPtr(uint, [])
-let ulonglongptr = TPtr(ulonglong, [])
-
-let ty_buffer n =
-  TArray(uint, Some (Int64.of_int n), [])
-
-let ebuffer_index base idx =
-  { edesc = EBinop(Oindex, base, intconst (Int64.of_int idx) IInt, uintptr);
-    etyp = uint }
-
-let attr_structret = [Attr("__structreturn", [])]
-
-(* Expression constructor functions *)
-
-let ereinterpret ty e =
-  { edesc = EUnop(Oderef, ecast (TPtr(ty, [])) (eaddrof e)); etyp = ty }
-
-let or2 a b = { edesc = EBinop(Oor, a, b, uint); etyp = uint }
-let or3 a b c = or2 (or2 a b) c
-let or4 a b c d = or2 (or2 (or2 a b) c) d
-
-let lshift a nbytes =
-  if nbytes = 0 then a else
-    { edesc = EBinop(Oshl, a, intconst (Int64.of_int (nbytes * 8)) IInt, uint);
-      etyp = uint }
-
-let offsetptr base ofs =
-  if ofs = 0 then base else
-  { edesc = EBinop(Oadd, base, intconst (Int64.of_int ofs) IInt, ucharptr);
-    etyp = ucharptr }
-
-let load1 base ofs shift_le shift_be =
-  let shift = if (!config).bigendian then shift_be else shift_le in
-  let a = offsetptr base ofs in
-  lshift { edesc = EUnop(Oderef, a); etyp = uchar } shift
-
-let load2 base ofs shift_le shift_be =
-  let shift = if (!config).bigendian then shift_be else shift_le in
-  let a = ecast ushortptr (offsetptr base ofs) in
-  lshift { edesc = EUnop(Oderef, a); etyp = ushort } shift
-
-let load4 base ofs =
-  let a = ecast uintptr (offsetptr base ofs) in
-  { edesc = EUnop(Oderef, a); etyp = uint }
-
-let load8 base ofs =
-  let a = ecast ulonglongptr (offsetptr base ofs) in
-  { edesc = EUnop(Oderef, a); etyp = ulonglong }
-
-let lshift_ll a nbytes =
-  let a = ecast ulonglong a in
-  if nbytes = 0 then a else
-    { edesc = EBinop(Oshl, a, intconst (Int64.of_int (nbytes * 8)) IInt, ulonglong);
-      etyp = ulonglong }
-
-let or2_ll a b = { edesc = EBinop(Oor, a, b, uint); etyp = ulonglong }
-
-(* Loading a memory area as one or several integers. *)
-
-let load_word base ofs sz al =
-  match sz with
-  | 0 -> intconst 0L IInt
-  | 1 -> load1 base ofs 0 3
-  | 2 -> if al >= 2 || (!config).supports_unaligned_accesses then
-           load2 base ofs 0 2
-         else
-           or2 (load1 base ofs 0 3)
-               (load1 base (ofs + 1) 1 2)
-  | 3 -> if al >= 2 || (!config).supports_unaligned_accesses then
-           or2 (load2 base ofs 0 2)
-               (load1 base (ofs + 2) 2 1)
-         else
-           or3 (load1 base ofs 0 3)
-               (load1 base (ofs + 1) 1 2)
-               (load1 base (ofs + 2) 2 1)
-  | 4 -> if al >= 4 || (!config).supports_unaligned_accesses then
-           load4 base ofs
-         else if al >= 2 then
-           or2 (load2 base ofs 0 2)
-               (load2 base (ofs + 2) 2 0)
-         else
-           or4 (load1 base ofs 0 3)
-               (load1 base (ofs + 1) 1 2)
-               (load1 base (ofs + 2) 2 1)
-               (load1 base (ofs + 3) 3 0)
-  | _ -> assert false
-
-
-let rec load_words base ofs sz al =
-  if ofs >= sz then []
-  else if ofs + 4 >= sz then [load_word base ofs (sz - ofs) al]
-  else load_word base ofs 4 al :: load_words base (ofs + 4) sz al
-
-let load_result base sz al =
-  assert (sz <= 8);
-  if sz <= 4 then
-    load_word base 0 sz al
-  else if sz = 8 && (al >= 8 || (!config).supports_unaligned_accesses) then
-    load8 base 0
-  else begin
-    let (shift1, shift2) = if (!config).bigendian then (4, 0) else (0, 4) in
-    or2_ll (lshift_ll (load_word base 0 4 al) shift1)
-           (lshift_ll (load_word base 4 (sz - 4) al) shift2)
-  end
-
-(* Rewriting of function types.  For the return type:
-      return kind scalar   -> no change
-      return kind ref      -> return type void + add 1st parameter struct s *
-      return kind value(t) -> return type t.
-   For the parameters:
-      param unchanged      -> no change
-      param_ref_caller     -> turn into a pointer
-      param_flattened N    -> turn into N parameters of type "int"
-   Try to preserve original typedef names when no change.
-*)
-
-let rec transf_type env t =
-  match unroll env t with
-  | TFun(tres, None, vararg, attr) ->
-      let tres' = transf_type env tres in
-      begin match classify_return env tres with
-      | Ret_scalar ->
-          TFun(tres', None, vararg, attr)
-      | Ret_ref ->
-          TFun(TVoid [], None, vararg, add_attributes attr attr_structret)
-      | Ret_value(ty, sz, al) ->
-          TFun(ty, None, vararg, attr)
-      end
-  | TFun(tres, Some args, vararg, attr) ->
-      let args' = transf_funargs env args in
-      let tres' = transf_type env tres in
-      begin match classify_return env tres with
-      | Ret_scalar ->
-          TFun(tres', Some args', vararg, attr)
-      | Ret_ref ->
-          let res = Env.fresh_ident "_res" in
-          TFun(TVoid [], Some((res, TPtr(tres', [])) :: args'), vararg,
-               add_attributes attr attr_structret)
-      | Ret_value(ty, sz, al) ->
-          TFun(ty, Some args', vararg, attr)
-      end
-  | TPtr(t1, attr) ->
-      let t1' = transf_type env t1 in
-      if t1' = t1 then t else TPtr(transf_type env t1, attr)
-  | TArray(t1, sz, attr) ->
-      let t1' = transf_type env t1 in
-      if t1' = t1 then t else TArray(transf_type env t1, sz, attr)
-  | _ -> t
-
-and transf_funargs env = function
-  | [] -> []
-  | (id, t) :: args ->
-      let t' = transf_type env t in
-      let args' = transf_funargs env args in
-      match classify_param env t with
-      | Param_unchanged ->
-          (id, t') :: args'
-      | Param_ref_caller ->
-          (id, TPtr(t', [])) :: args'
-      | Param_flattened(n, sz, al) ->
-          list_map_n (fun _ -> (Env.fresh_ident id.C.name, uint)) n
-          @ args'
-
-(* Expressions: transform calls + rewrite the types *)
-
-let rec translates_to_extended_lvalue arg =
-  is_lvalue arg ||
-  (match arg.edesc with
-   | ECall _ -> true
-   | EBinop(Ocomma, a, b, _) -> translates_to_extended_lvalue b
-   | _ -> false)
-
-let rec transf_expr env ctx e =
-  let newty = transf_type env e.etyp in
-  match e.edesc with
-  | EConst c ->
-      {edesc = EConst c; etyp = newty}
-  | ESizeof ty ->
-      {edesc = ESizeof (transf_type env ty); etyp = newty}
-  | EAlignof ty ->
-      {edesc = EAlignof (transf_type env ty); etyp = newty}
-  | EVar x ->
-      {edesc = EVar x; etyp = newty}
-  | EUnop(op, e1) ->
-      {edesc = EUnop(op, transf_expr env Val e1); etyp = newty}
-  | EBinop(Oassign, lhs, {edesc = ECall(fn, args); etyp = ty}, _) ->
-      transf_call env ctx (Some (transf_expr env Val lhs)) fn args ty
-  | EBinop(Ocomma, e1, e2, ty) ->
-      ecomma (transf_expr env Effects e1) (transf_expr env ctx e2)
-  | EBinop(op, e1, e2, ty) ->
-      {edesc = EBinop(op, transf_expr env Val e1,
-                          transf_expr env Val e2,
-                          transf_type env ty);
-       etyp = newty}
-  | EConditional(e1, e2, e3) ->
-      {edesc = EConditional(transf_expr env Val e1,
-                            transf_expr env ctx e2,
-                            transf_expr env ctx e3);
-       etyp = newty}
-  | ECast(ty, e1) ->
-      {edesc = ECast(transf_type env ty, transf_expr env Val e1); etyp = newty}
-  | ECompound(ty, ie) ->
-      {edesc = ECompound(transf_type env ty, transf_init env ie); etyp = newty}
-  | ECall(fn, args) ->
-      transf_call env ctx None fn args e.etyp
-
-(* Function calls returning a composite by reference: add first argument.
-    ctx = Effects:   lv = f(...)     -> f(&newtemp, ...), lv = newtemp
-                     f(...)          -> f(&newtemp, ...)
-    ctx = Val:       lv = f(...)     -> f(&newtemp, ...), lv = newtemp
-                     f(...)          -> f(&newtemp, ...), newtemp
-
-   We used to do a copy optimization:
-     ctx = Effects:   lv = f(...)     -> f(&lv, ...)
-   but it is not correct in case of overlap (see test/regression/struct12.c)
-
-   Function calls returning a composite by value:
-    ctx = Effects:   lv = f(...)     -> newtemp = f(...), lv = newtemp
-                     f(...)          -> f(...)
-    ctx = Val:       lv = f(...)     -> newtemp = f(...), lv = newtemp
-                     f(...)          -> newtemp = f(...), newtemp
-*)
-
-and transf_call env ctx opt_lhs fn args ty =
-  let ty' = transf_type env ty in
-  let fn' = transf_expr env Val fn in
-  let (assignments, args') = transf_arguments env args in
-  let opt_eassign e =
-    match opt_lhs with
-    | None -> e
-    | Some lhs -> eassign lhs e in
-  match fn with
-  | {edesc = EVar {C.name = "__builtin_va_arg"}} ->
-      (* Do not transform the call in this case *)
-      opt_eassign {edesc = ECall(fn, args'); etyp = ty}
-  | _ ->
-    let call =
-      match classify_return env ty with
-      | Ret_scalar ->
-          opt_eassign {edesc = ECall(fn', args'); etyp = ty'}
-      | Ret_ref ->
-          begin match ctx, opt_lhs with
-          | Effects, None ->
-              let tmp = new_temp ~name:"_res" ty in
-              {edesc = ECall(fn', eaddrof tmp :: args'); etyp = TVoid []}
-          (* Copy optimization, turned off as explained above *)
-       (* | Effects, Some lhs ->
-              {edesc = ECall(fn', eaddrof lhs :: args'); etyp = TVoid []} *)
-          | Val, None ->
-              let tmp = new_temp ~name:"_res" ty in
-              ecomma {edesc = ECall(fn', eaddrof tmp :: args'); etyp = TVoid []}
-                     tmp
-          | _, Some lhs ->
-              let tmp = new_temp ~name:"_res" ty in
-              ecomma {edesc = ECall(fn', eaddrof tmp :: args'); etyp = TVoid []}
-                     (eassign lhs tmp)
-          end
-      | Ret_value(ty_ret, sz, al) ->
-          let ecall = {edesc = ECall(fn', args'); etyp = ty_ret} in
-          begin match ctx, opt_lhs with
-          | Effects, None ->
-              ecall
-          | _, _ ->
-              let tmp = new_temp ~name:"_res" ty_ret in
-              opt_eassign
-                (ecomma (eassign tmp ecall)
-                        (ereinterpret ty' tmp))
-          end
-    in ecommalist assignments call
-
-(* Function argument of ref_caller kind: take a copy and pass pointer to copy
-        arg      --->   newtemp = arg  ...   &newtemp
-   Function argument of flattened(N) kind: load and pass as integers
-   either using an intermediate array
-        arg      --->   ( * ((ty * ) temparray) = arg ...
-                        temparray[0], ...,, temparray[N-1]
-   or by using loadwords:
-        arg      --->   addr = &(arg) ... loadwords addr ...
-*)
-
-and transf_arguments env args =
-  match args with
-  | [] -> ([], [])
-  | arg :: args ->
-      let (assignments, args') = transf_arguments env args in
-      match classify_param env arg.etyp with
-      | Param_unchanged ->
-          let arg' = transf_expr env Val arg in
-          (assignments, arg' :: args')
-      | Param_ref_caller ->
-          let ty' = transf_type env arg.etyp in
-          let tmp = new_temp ~name:"_arg" ty' in
-          (transf_assign env tmp arg :: assignments,
-           eaddrof tmp :: args')
-      | Param_flattened(n, sz, al) ->
-          let ty' = transf_type env arg.etyp in
-          if translates_to_extended_lvalue arg then begin
-            let tmp = new_temp ~name:"_arg" ucharptr in
-            (eassign tmp (ecast ucharptr (eaddrof (transf_expr env Val arg)))
-             :: assignments,
-             load_words tmp 0 sz al @ args')
-          end else begin
-            let tmp = new_temp ~name:"_arg" (ty_buffer n) in
-            (transf_assign env (ereinterpret ty' tmp) arg :: assignments,
-             list_map_n (ebuffer_index tmp) n @ args')
-          end
-
-and transf_assign env lhs e =
-  match e.edesc with
-  | ECall(fn, args) ->
-      transf_call env Effects (Some lhs) fn args e.etyp
-  | _ ->
-      eassign lhs (transf_expr env Val e)
-
-(* Initializers *)
-
-and transf_init env = function
-  | Init_single e ->
-      Init_single (transf_expr env Val e)
-  | Init_array il ->
-      Init_array (List.rev (List.rev_map (transf_init env) il))
-  | Init_struct(id, fil) ->
-      Init_struct (id, List.map (fun (fld, i) -> (fld, transf_init env i)) fil)
-  | Init_union(id, fld, i) ->
-      Init_union(id, fld, transf_init env i)
-
-(* Declarations *)
-
-let transf_decl env (sto, id, ty, init) =
-  (sto, id, transf_type env ty,
-   match init with None -> None | Some i -> Some (transf_init env i))
-
-(* Transformation of statements and function bodies *)
-
-let transf_funbody env body optres =
-
-let transf_expr ctx e = transf_expr env ctx e in
-let transf_asm_operand (lbl, cstr, e) = (lbl, cstr, transf_expr Val e) in
-
-(* Function returns:
-     return kind scalar    -> return e
-     return kind ref       -> _res = x; return
-     return kind value ty  -> *((struct s * )_res) = x; return _res
-                           or addr = &x; return loadresult(addr)
-*)
-
-let rec transf_stmt s =
-  match s.sdesc with
-  | Sskip -> s
-  | Sdo e ->
-      {s with sdesc = Sdo(transf_expr Effects e)}
-  | Sseq(s1, s2) ->
-      {s with sdesc = Sseq(transf_stmt s1, transf_stmt s2)}
-  | Sif(e, s1, s2) ->
-      {s with sdesc = Sif(transf_expr Val e,
-                          transf_stmt s1, transf_stmt s2)}
-  | Swhile(e, s1) ->
-      {s with sdesc = Swhile(transf_expr Val e, transf_stmt s1)}
-  | Sdowhile(s1, e) ->
-      {s with sdesc = Sdowhile(transf_stmt s1, transf_expr Val e)}
-  | Sfor(s1, e, s2, s3) ->
-      {s with sdesc = Sfor(transf_stmt s1, transf_expr Val e,
-                           transf_stmt s2, transf_stmt s3)}
-  | Sbreak -> s
-  | Scontinue -> s
-  | Sswitch(e, s1) ->
-      {s with sdesc = Sswitch(transf_expr Val e, transf_stmt s1)}
-  | Slabeled(lbl, s1) ->
-      {s with sdesc = Slabeled(lbl, transf_stmt s1)}
-  | Sgoto lbl -> s
-  | Sreturn None -> s
-  | Sreturn(Some e) ->
-      let e' = transf_expr Val e in
-      begin match classify_return env e'.etyp, optres with
-      | Ret_scalar, None ->
-          {s with sdesc = Sreturn(Some e')}
-      | Ret_ref, Some dst ->
-          sseq s.sloc
-            (sassign s.sloc dst e')
-            {sdesc = Sreturn None; sloc = s.sloc}
-      | Ret_value(ty, sz, al), None ->
-          if translates_to_extended_lvalue e then begin
-            let tmp = new_temp ~name:"_res" ucharptr in
-            sseq s.sloc
-              (sassign s.sloc tmp (ecast ucharptr (eaddrof e')))
-              {sdesc = Sreturn (Some (load_result tmp sz al)); sloc = s.sloc}
-          end else begin
-            let dst = new_temp ~name:"_res" ty in
-            sseq s.sloc
-              (sassign s.sloc (ereinterpret e'.etyp dst) e')
-              {sdesc = Sreturn (Some dst); sloc = s.sloc}
-          end
-      | _, _ ->
-          assert false
-      end
-  | Sblock sl ->
-      {s with sdesc = Sblock(List.map transf_stmt sl)}
-  | Sdecl d ->
-      {s with sdesc = Sdecl(transf_decl env d)}
-  | Sasm(attr, template, outputs, inputs, clob) ->
-      {s with sdesc = Sasm(attr, template,
-                           List.map transf_asm_operand outputs,
-                           List.map transf_asm_operand inputs, clob)}
-
-in
-  transf_stmt body
-
-(* Binding arguments to parameters.  Returns a triple:
-    - parameter list
-    - actions to perform at the beginning of the function
-    - substitution to apply to the function body
-*)
-
-let rec transf_funparams loc env params =
-  match params with
-  | [] ->
-      ([], sskip, IdentMap.empty)
-  | (x, tx) :: params ->
-      let tx' = transf_type env tx in
-      let (params', actions, subst) = transf_funparams loc env params in
-      match classify_param env tx with
-      | Param_unchanged ->
-          ((x, tx') :: params',
-           actions,
-           subst)
-      | Param_ref_caller ->
-          let tpx = TPtr(tx', []) in
-          let ex = { edesc = EVar x; etyp = tpx } in
-          let estarx = { edesc = EUnop(Oderef, ex); etyp = tx' } in
-          ((x, tpx) :: params',
-           actions,
-           IdentMap.add x estarx subst)
-      | Param_flattened(n, sz, al) ->
-          let y = new_temp ~name:x.C.name (ty_buffer n) in
-          let yparts = list_map_n (fun _ -> Env.fresh_ident x.C.name) n in
-          let assign_part e p act =
-            sseq loc (sassign loc e {edesc = EVar p; etyp = uint}) act in
-          (List.map (fun p -> (p, uint)) yparts @ params',
-           List.fold_right2 assign_part
-                            (list_map_n (ebuffer_index y) n)
-                            yparts
-                            actions,
-           IdentMap.add x (ereinterpret tx' y) subst)
-
-let transf_fundef env f =
-  reset_temps();
-  let ret = transf_type env f.fd_ret in
-  let (params, actions, subst) =
-    transf_funparams f.fd_body.sloc env f.fd_params in
-  let locals =
-    List.map (fun d -> transf_decl env (subst_decl subst d)) f.fd_locals in
-  let (attr1, ret1, params1, body1) =
-    match classify_return env f.fd_ret with
-    | Ret_scalar ->
-        (f.fd_attrib,
-         ret,
-         params,
-         transf_funbody env (subst_stmt subst f.fd_body) None)
-    | Ret_ref ->
-        let vres = Env.fresh_ident "_res" in
-        let tres = TPtr(ret, []) in
-        let eres = {edesc = EVar vres; etyp = tres} in
-        let eeres = {edesc = EUnop(Oderef, eres); etyp = ret} in
-        (add_attributes f.fd_attrib attr_structret,
-         TVoid [],
-         (vres, tres) :: params,
-         transf_funbody env (subst_stmt subst f.fd_body) (Some eeres))
-    | Ret_value(ty, sz, al) ->
-        (f.fd_attrib,
-         ty,
-         params,
-         transf_funbody env (subst_stmt subst f.fd_body) None) in
-  let temps = get_temps() in
-  {f with fd_attrib = attr1;
-          fd_ret = ret1;
-          fd_params = params1;
-          fd_locals = locals @ temps;
-          fd_body = sseq f.fd_body.sloc actions body1}
-
-(* Composites *)
-
-let transf_composite env su id attr fl =
-  (attr, List.map (fun f -> {f with fld_typ = transf_type env f.fld_typ}) fl)
-
-(* Entry point *)
-
-let program p =
-  struct_passing_style :=
-    if !Clflags.option_interp
-    then SP_ref_callee
-    else !Machine.config.struct_passing_style;
-  struct_return_style :=
-    if !Clflags.option_interp
-    then SR_ref
-    else !Machine.config.struct_return_style;
-  Transform.program
-    ~decl:transf_decl
-    ~fundef:transf_fundef
-    ~composite:transf_composite
-    ~typedef:(fun env id ty -> transf_type env ty)
-    p