cparser/StructByValue.ml

   1 (* *********************************************************************)
   2 (*                                                                     *)
   3 (*              The Compcert verified compiler                         *)
   4 (*                                                                     *)
   5 (*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
   6 (*                                                                     *)
   7 (*  Copyright Institut National de Recherche en Informatique et en     *)
   8 (*  Automatique.  All rights reserved.  This file is distributed       *)
   9 (*  under the terms of the GNU General Public License as published by  *)
  10 (*  the Free Software Foundation, either version 2 of the License, or  *)
  11 (*  (at your option) any later version.  This file is also distributed *)
  12 (*  under the terms of the INRIA Non-Commercial License Agreement.     *)
  13 (*                                                                     *)
  14 (* *********************************************************************)
  15
  16 (* Eliminate by-value passing of structs and unions. *)
  17
  18 (* Assumes: nothing.
  19    Preserves: simplified code, unblocked code *)
  20
  21 open C
  22 open Cutil
  23 open Transform
  24
  25 (* In function argument types, struct s -> struct s *
  26    In function result types, struct s -> void + add 1st parameter struct s *
  27    Try to preserve original typedef names when no change.
  28 *)
  29
  30 let rec transf_type env t =
  31   match unroll env t with
  32   | TFun(tres, None, vararg, attr) ->
  33       let tres' = transf_type env tres in
  34       TFun((if is_composite_type env tres then TVoid [] else tres'),
  35            None, vararg, attr)
  36   | TFun(tres, Some args, vararg, attr) ->
  37       let args' = List.map (transf_funarg env) args in
  38       let tres' = transf_type env tres in
  39       if is_composite_type env tres then begin
  40         let res = Env.fresh_ident "_res" in
  41         TFun(TVoid [], Some((res, TPtr(tres', [])) :: args'), vararg, attr)
  42       end else
  43         TFun(tres', Some args', vararg, attr)
  44   | TPtr(t1, attr) ->
  45       let t1' = transf_type env t1 in
  46       if t1' = t1 then t else TPtr(transf_type env t1, attr)
  47   | TArray(t1, sz, attr) ->
  48       let t1' = transf_type env t1 in
  49       if t1' = t1 then t else TArray(transf_type env t1, sz, attr)
  50   | _ -> t
  51
  52 and transf_funarg env (id, t) =
  53   let t = transf_type env t in
  54   if is_composite_type env t
  55   then (id, TPtr(add_attributes_type [AConst] t, []))
  56   else (id, t)
  57
  58 (* Simple exprs: no change in structure, since calls cannot occur within,
  59    but need to rewrite the types. *)
  60
  61 let rec transf_expr env e =
  62   { etyp = transf_type env e.etyp;
  63     edesc = match e.edesc with
  64       | EConst c -> EConst c
  65       | ESizeof ty -> ESizeof (transf_type env ty)
  66       | EVar x -> EVar x
  67       | EUnop(op, e1) -> EUnop(op, transf_expr env e1)
  68       | EBinop(op, e1, e2, ty) ->
  69           EBinop(op, transf_expr env e1, transf_expr env e2, transf_type env ty)
  70       | EConditional(e1, e2, e3) ->
  71           assert (not (is_composite_type env e.etyp));
  72           EConditional(transf_expr env e1, transf_expr env e2, transf_expr env e3)
  73       | ECast(ty, e1) -> ECast(transf_type env ty, transf_expr env e1)
  74       | ECall(e1, el) -> assert false
  75   }
  76
  77 (* Initializers *)
  78
  79 let rec transf_init env = function
  80   | Init_single e ->
  81       Init_single (transf_expr env e)
  82   | Init_array il ->
  83       Init_array (List.map (transf_init env) il)
  84   | Init_struct(id, fil) ->
  85       Init_struct (id, List.map (fun (fld, i) -> (fld, transf_init env i)) fil)
  86   | Init_union(id, fld, i) ->
  87       Init_union(id, fld, transf_init env i)
  88
  89 (* Declarations *)
  90
  91 let transf_decl env (sto, id, ty, init) =
  92   (sto, id, transf_type env ty,
  93    match init with None -> None | Some i -> Some (transf_init env i))
  94
  95 (* Transformation of statements and function bodies *)
  96
  97 let transf_funbody env body optres =
  98
  99 let transf_type t = transf_type env t
 100 and transf_expr e = transf_expr env e in
 101
 102 (* Function arguments: pass by reference those having struct/union type *)
 103
 104 let transf_arg e =
 105   let e' = transf_expr e in
 106   if is_composite_type env e'.etyp
 107   then {edesc = EUnop(Oaddrof, e'); etyp = TPtr(e'.etyp, [])}
 108   else e'
 109 in
 110
 111 (* Function calls: if return type is struct or union,
 112      lv = f(...)   -> f(&lv, ...)
 113      f(...)        -> f(&newtemp, ...)
 114    Returns: if return type is struct or union,
 115      return x      -> _res = x; return
 116 *)
 117
 118 let rec transf_stmt s =
 119   match s.sdesc with
 120   | Sskip -> s
 121   | Sdo {edesc = ECall(fn, args); etyp = ty} ->
 122       let fn = transf_expr fn in
 123       let args = List.map transf_arg args in
 124       if is_composite_type env ty then begin
 125         let tmp = new_temp ~name:"_res" ty in
 126         let arg0 = {edesc = EUnop(Oaddrof, tmp); etyp = TPtr(ty, [])} in
 127         {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}}
 128       end else
 129         {s with sdesc = Sdo {edesc = ECall(fn, args); etyp = ty}}
 130   | Sdo {edesc = EBinop(Oassign, dst, {edesc = ECall(fn, args); etyp = ty}, _)} ->
 131       let dst = transf_expr dst in
 132       let fn = transf_expr fn in
 133       let args = List.map transf_arg args in
 134       let ty = transf_type ty in
 135       if is_composite_type env ty then begin
 136         let arg0 = {edesc = EUnop(Oaddrof, dst); etyp = TPtr(dst.etyp, [])} in
 137         {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}}
 138       end else
 139         sassign s.sloc dst {edesc = ECall(fn, args); etyp = ty}
 140   | Sdo e ->
 141       {s with sdesc = Sdo(transf_expr e)}
 142   | Sseq(s1, s2) ->
 143       {s with sdesc = Sseq(transf_stmt s1, transf_stmt s2)}
 144   | Sif(e, s1, s2) ->
 145       {s with sdesc = Sif(transf_expr e, transf_stmt s1, transf_stmt s2)}
 146   | Swhile(e, s1) ->
 147       {s with sdesc = Swhile(transf_expr e, transf_stmt s1)}
 148   | Sdowhile(s1, e) ->
 149       {s with sdesc = Sdowhile(transf_stmt s1, transf_expr e)}
 150   | Sfor(s1, e, s2, s3) ->
 151       {s with sdesc = Sfor(transf_stmt s1, transf_expr e,
 152                            transf_stmt s2, transf_stmt s3)}
 153   | Sbreak -> s
 154   | Scontinue -> s
 155   | Sswitch(e, s1) ->
 156       {s with sdesc = Sswitch(transf_expr e, transf_stmt s1)}
 157   | Slabeled(lbl, s1) ->
 158       {s with sdesc = Slabeled(lbl, transf_stmt s1)}
 159   | Sgoto lbl -> s
 160   | Sreturn None -> s
 161   | Sreturn(Some e) ->
 162       let e = transf_expr e in
 163       begin match optres with
 164       | None ->
 165           {s with sdesc = Sreturn(Some e)}
 166       | Some dst ->
 167           sseq s.sloc
 168             (sassign s.sloc dst e)
 169             {sdesc = Sreturn None; sloc = s.sloc}
 170       end
 171   | Sblock sl ->
 172       {s with sdesc = Sblock(List.map transf_stmt sl)}
 173   | Sdecl d ->
 174       {s with sdesc = Sdecl(transf_decl env d)}
 175
 176 in
 177   transf_stmt body
 178
 179 let transf_params loc env params =
 180   let rec transf_prm = function
 181   | [] ->
 182       ([], [], sskip)
 183   | (id, ty) :: params ->
 184       let ty = transf_type env ty in
 185       if is_composite_type env ty then begin
 186         let id' = Env.fresh_ident id.name in
 187         let ty' = TPtr(add_attributes_type [AConst] ty, []) in
 188         let (params', decls, init) = transf_prm params in
 189         ((id', ty') :: params',
 190          (Storage_default, id, ty, None) :: decls,
 191          sseq loc
 192           (sassign loc {edesc = EVar id; etyp = ty}
 193                        {edesc = EUnop(Oderef, {edesc = EVar id'; etyp = ty'});
 194                         etyp = ty})
 195           init)
 196       end else begin
 197         let (params', decls, init) = transf_prm params in
 198         ((id, ty) :: params', decls, init)
 199       end
 200   in transf_prm params
 201
 202 let transf_fundef env f =
 203   reset_temps();
 204   let ret = transf_type env f.fd_ret in
 205   let (params, newdecls, init) = transf_params f.fd_body.sloc env f.fd_params in
 206   let (ret1, params1, body1) =
 207     if is_composite_type env ret then begin
 208       let vres = Env.fresh_ident "_res" in
 209       let tres = TPtr(ret, []) in
 210       let eres = {edesc = EVar vres; etyp = tres} in
 211       let eeres = {edesc = EUnop(Oderef, eres); etyp = ret} in
 212       (TVoid [],
 213        (vres, tres) :: params,
 214        transf_funbody env f.fd_body (Some eeres))
 215     end else
 216       (ret, params, transf_funbody env f.fd_body None) in
 217   let body2 = sseq body1.sloc init body1 in
 218   let temps = get_temps() in
 219   {f with fd_ret = ret1; fd_params = params1;
 220           fd_locals = newdecls @ f.fd_locals @ temps; fd_body = body2}
 221
 222 (* Composites *)
 223
 224 let transf_composite env su id fl =
 225   List.map (fun f -> {f with fld_typ = transf_type env f.fld_typ}) fl
 226
 227 (* Entry point *)
 228
 229 let program p =
 230   Transform.program
 231     ~decl:transf_decl
 232     ~fundef:transf_fundef
 233     ~composite:transf_composite
 234     ~typedef:(fun env id ty -> transf_type env ty)
 235     p