Merge branch 'master' into dwarf

Conflicts:
	Makefile
	driver/Driver.ml

6 files changed, 480 insertions, 88 deletions

diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index 9e7f102e..4d6d2137 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -834,9 +834,23 @@ let nullconst = ecast (TPtr(TVoid [], [])) (intconst 0L IInt)
 
 let eassign e1 e2 = { edesc = EBinop(Oassign, e1, e2, e1.etyp); etyp = e1.etyp }
 
-(* Construct a "," expression *)
+(* Construct a "," expression.  Reassociate to the left so that
+   it prints more nicely. *)
 
-let ecomma e1 e2 = { edesc = EBinop(Ocomma, e1, e2, e2.etyp); etyp = e2.etyp }
+let rec ecomma e1 e2 =
+  match e2.edesc with
+  | EBinop(Ocomma, e2', e2'', _) ->
+     ecomma (ecomma e1 e2') e2''
+  | _ ->
+     { edesc = EBinop(Ocomma, e1, e2, e2.etyp); etyp = e2.etyp }
+
+(* Construct a cascade of "," expressions.
+   Associate to the left so that it prints more nicely. *)
+
+let ecommalist el e =
+  match el with
+  | [] -> e
+  | e1 :: el -> ecomma (List.fold_left ecomma e1 el) e
 
 (* Construct an address-of expression.  Can be applied not just to
    an l-value but also to a sequence or a conditional of l-values. *)
@@ -910,3 +924,65 @@ let rec default_init env ty =
       end
   | _ ->
       assert false
+
+(* Substitution of variables by expressions *)
+
+let rec subst_expr phi e =
+  match e.edesc with
+  | EConst _ | ESizeof _ | EAlignof _ -> e
+  | EVar x ->
+      begin try IdentMap.find x phi with Not_found -> e end
+  | EUnop(op, e1) ->
+      { e with edesc = EUnop(op, subst_expr phi e1) }
+  | EBinop(op, e1, e2, ty) ->
+      { e with edesc = EBinop(op, subst_expr phi e1, subst_expr phi e2, ty) }
+  | EConditional(e1, e2, e3) ->
+      { e with edesc =
+          EConditional(subst_expr phi e1, subst_expr phi e2, subst_expr phi e3) }
+  | ECast(ty, e1) ->
+      { e with edesc = ECast(ty, subst_expr phi e1) }
+  | ECompound(ty, i) ->
+      { e with edesc = ECompound(ty, subst_init phi i) }
+  | ECall(e1, el) ->
+      { e with edesc = ECall(subst_expr phi e1, List.map (subst_expr phi) el) }
+
+and subst_init phi = function
+  | Init_single e -> Init_single (subst_expr phi e)
+  | Init_array il -> Init_array (List.map (subst_init phi) il)
+  | Init_struct(name, fl) ->
+      Init_struct(name, List.map (fun (f,i) -> (f, subst_init phi i)) fl)
+  | Init_union(name, f, i) ->
+      Init_union(name, f, subst_init phi i)
+
+let subst_decl phi (sto, name, ty, optinit) =
+  (sto, name, ty,
+   match optinit with None -> None | Some i -> Some (subst_init phi i))
+
+let rec subst_stmt phi s =
+  { s with sdesc =
+      match s.sdesc with
+      | Sskip
+      | Sbreak
+      | Scontinue
+      | Sgoto _
+      | Sasm _ -> s.sdesc
+      | Sdo e -> Sdo (subst_expr phi e)
+      | Sseq(s1, s2) -> Sseq (subst_stmt phi s1, subst_stmt phi s2)
+      | Sif(e, s1, s2) ->
+          Sif (subst_expr phi e, subst_stmt phi s1, subst_stmt phi s2)
+      | Swhile(e, s1) -> Swhile (subst_expr phi e, subst_stmt phi s1)
+      | Sdowhile(s1, e) -> Sdowhile (subst_stmt phi s1, subst_expr phi e)
+      | Sfor(s1, e, s2, s3) ->
+          Sfor (subst_stmt phi s1, subst_expr phi e,
+                subst_stmt phi s2, subst_stmt phi s3)
+      | Sswitch(e, s1) -> Sswitch (subst_expr phi e, subst_stmt phi s1)
+      | Slabeled(l, s1) -> Slabeled (l, subst_stmt phi s1)
+      | Sreturn None -> s.sdesc
+      | Sreturn (Some e) -> Sreturn (Some (subst_expr phi e))
+      | Sblock sl -> Sblock (List.map (subst_stmt phi) sl)
+      | Sdecl d -> Sdecl (subst_decl phi d)
+  }
+
+
+
+
diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli
index 06c66b41..9d41f8fa 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -212,6 +212,8 @@ val eassign : exp -> exp -> exp
   (* Expression for [e1 = e2] *)
 val ecomma :  exp -> exp -> exp
   (* Expression for [e1, e2] *)
+val ecommalist :  exp list -> exp -> exp
+  (* Expression for [e1, ..., eN, e] *)
 val sskip: stmt
   (* The [skip] statement.  No location. *)
 val sseq : location -> stmt -> stmt -> stmt
@@ -234,3 +236,10 @@ val formatloc: Format.formatter -> location -> unit
 val default_init: Env.t -> typ -> init
   (* Return a default initializer for the given type
      (with zero numbers, null pointers, etc). *)
+
+(* Substitution of variables by expressions *)
+
+val subst_expr: exp IdentMap.t -> exp -> exp
+val subst_init: exp IdentMap.t -> init -> init
+val subst_decl: exp IdentMap.t -> decl -> decl
+val subst_stmt: exp IdentMap.t -> stmt -> stmt
diff --git a/cparser/Machine.ml b/cparser/Machine.ml
index b215505b..bd6489fd 100644
--- a/cparser/Machine.ml
+++ b/cparser/Machine.ml
@@ -44,7 +44,7 @@ type t = {
   alignof_fun: int option;
   bigendian: bool;
   bitfields_msb_first: bool;
-  struct_return_as_int: int
+  supports_unaligned_accesses: bool
 }
 
 let ilp32ll64 = {
@@ -76,7 +76,7 @@ let ilp32ll64 = {
   alignof_fun = None;
   bigendian = false;
   bitfields_msb_first = false;
-  struct_return_as_int = 0
+  supports_unaligned_accesses = false
 }
 
 let i32lpll64 = {
@@ -108,7 +108,7 @@ let i32lpll64 = {
   alignof_fun = None;
   bigendian = false;
   bitfields_msb_first = false;
-  struct_return_as_int = 0
+  supports_unaligned_accesses = false
 }
 
 let il32pll64 = {
@@ -140,7 +140,7 @@ let il32pll64 = {
   alignof_fun = None;
   bigendian = false;
   bitfields_msb_first = false;
-  struct_return_as_int = 0
+  supports_unaligned_accesses = false
 }
 
 (* Canned configurations for some ABIs *)
@@ -149,9 +149,15 @@ let x86_32 =
   { ilp32ll64 with name = "x86_32";
                    char_signed = true;
                    alignof_longlong = 4; alignof_double = 4;
-                   sizeof_longdouble = 12; alignof_longdouble = 4 }
+                   sizeof_longdouble = 12; alignof_longdouble = 4;
+                   supports_unaligned_accesses = true }
+
+let x86_32_macosx =
+  { x86_32 with sizeof_longdouble = 16; alignof_longdouble = 16 }
+
 let x86_64 =
   { i32lpll64 with name = "x86_64"; char_signed = true }
+
 let win32 =
   { ilp32ll64 with name = "win32"; char_signed = true;
                    sizeof_wchar = 2; wchar_signed = false }
@@ -162,10 +168,10 @@ let ppc_32_bigendian =
   { ilp32ll64 with name = "powerpc";
                    bigendian = true;
                    bitfields_msb_first = true;
-                   struct_return_as_int = 8 }
+                   supports_unaligned_accesses = true }
+
 let arm_littleendian =
-  { ilp32ll64 with name = "arm";
-                   struct_return_as_int = 4 }
+  { ilp32ll64 with name = "arm" }
 
 (* Add GCC extensions re: sizeof and alignof *)
 
@@ -173,6 +179,12 @@ let gcc_extensions c =
   { c with sizeof_void = Some 1; sizeof_fun = Some 1;
            alignof_void = Some 1; alignof_fun = Some 1 }
 
+(* Normalize configuration for use with the CompCert reference interpreter *)
+
+let compcert_interpreter c =
+  { c with sizeof_longdouble = 8; alignof_longdouble = 8;
+           supports_unaligned_accesses = false }
+
 (* Undefined configuration *)
 
 let undef = {
@@ -204,7 +216,7 @@ let undef = {
   alignof_fun = None;
   bigendian = false;
   bitfields_msb_first = false;
-  struct_return_as_int = 0
+  supports_unaligned_accesses = false
 }
 
 (* The current configuration.  Must be initialized before use. *)
diff --git a/cparser/Machine.mli b/cparser/Machine.mli
index b544711f..fb7321f9 100644
--- a/cparser/Machine.mli
+++ b/cparser/Machine.mli
@@ -44,13 +44,20 @@ type t = {
   alignof_fun: int option;
   bigendian: bool;
   bitfields_msb_first: bool;
-  struct_return_as_int: int
+  supports_unaligned_accesses: bool
 }
 
+(* The current configuration *)
+
+val config : t ref
+
+(* Canned configurations *)
+
 val ilp32ll64 : t
 val i32lpll64 : t
 val il32pll64 : t
 val x86_32 : t
+val x86_32_macosx : t
 val x86_64 : t
 val win32 : t
 val win64 : t
@@ -58,5 +65,4 @@ val ppc_32_bigendian : t
 val arm_littleendian : t
 
 val gcc_extensions : t -> t
-
-val config : t ref
+val compcert_interpreter : t -> t
diff --git a/cparser/StructReturn.ml b/cparser/StructReturn.ml
index 228cc530..8bfc6954 100644
--- a/cparser/StructReturn.ml
+++ b/cparser/StructReturn.ml
@@ -13,37 +13,198 @@
 (*                                                                     *)
 (* *********************************************************************)
 
-(* Eliminate structs and unions being returned by value as function results *)
+(* Eliminate structs and unions that are
+   - returned by value as function results
+   - passed by value as function parameters. *)
 
 open Machine
+open Configuration
 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 (**r a small composite type, returned as an integer *)
+  | 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 with
-    | None -> Ret_ref  (* should not happen *)
-    | Some sz ->
-        if (!config).struct_return_as_int >= 4 && sz <= 4 then
-          Ret_value (TInt(IUInt, []))
-        else if (!config).struct_return_as_int >= 8 && sz <= 8 then
-          Ret_value (TInt(IULongLong, []))
-        else Ret_ref
+    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
 
-(* Rewriting of function types.
+(* 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.
 *)
 
@@ -51,22 +212,25 @@ let rec transf_type env t =
   match unroll env t with
   | TFun(tres, None, vararg, attr) ->
       let tres' = transf_type env tres in
-      let tres'' =
-        match classify_return env tres with
-        | Ret_scalar -> tres'
-        | Ret_ref -> TVoid []
-        | Ret_value ty -> ty in
-      TFun(tres'', None, vararg, attr)
+      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' = List.map (transf_funarg env) args in
+      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, attr)
-      | Ret_value ty ->
+          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) ->
@@ -77,12 +241,28 @@ let rec transf_type env t =
       if t1' = t1 then t else TArray(transf_type env t1, sz, attr)
   | _ -> t
 
-and transf_funarg env (id, t) = (id, transf_type env 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.name, uint)) n
+          @ args'
 
 (* Expressions: transform calls + rewrite the types *)
 
-let ereinterpret ty e =
-  { edesc = EUnop(Oderef, ecast (TPtr(ty, [])) (eaddrof e)); etyp = ty }
+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
@@ -98,7 +278,7 @@ let rec transf_expr env ctx e =
   | 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 lhs) fn args 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) ->
@@ -133,48 +313,92 @@ let rec transf_expr env ctx e =
 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 args' = List.map (transf_expr env Val) args in
+  let (assignments, args') = transf_arguments env args in
   let opt_eassign e =
     match opt_lhs with
     | None -> e
-    | Some lhs -> eassign (transf_expr env Val lhs) e in
+    | Some lhs -> eassign lhs e in
   match fn with
   | {edesc = EVar {name = "__builtin_va_arg"}} ->
       (* Do not transform the call in this case *)
       opt_eassign {edesc = ECall(fn, args'); etyp = ty}
   | _ ->
-    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 []}
-        | Effects, Some lhs ->
-            let lhs' = transf_expr env Val lhs in
-            {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
-        | Val, Some lhs ->
-            let lhs' = transf_expr env Val lhs in
-            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 ->
-        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
+    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 []}
+          | 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
+          | Val, 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 *)
 
@@ -204,6 +428,7 @@ let transf_expr ctx e = transf_expr env ctx e in
      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 =
@@ -240,10 +465,18 @@ let rec transf_stmt s =
           sseq s.sloc
             (sassign s.sloc dst e')
             {sdesc = Sreturn None; sloc = s.sloc}
-      | Ret_value ty, Some dst ->
-          sseq s.sloc
-            (sassign s.sloc (ereinterpret e'.etyp dst) e')
-            {sdesc = Sreturn (Some dst); 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
@@ -256,29 +489,77 @@ let rec transf_stmt s =
 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.name (ty_buffer n) in
+          let yparts = list_map_n (fun _ -> Env.fresh_ident x.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 =
-    List.map (fun (id, ty) -> (id, transf_type env ty)) f.fd_params in
-  let (ret1, params1, body1) =
+  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 ->
-        (ret, params, transf_funbody env f.fd_body None)
+        (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
-        (TVoid [],
+        (add_attributes f.fd_attrib attr_structret,
+         TVoid [],
          (vres, tres) :: params,
-         transf_funbody env f.fd_body (Some eeres))
-    | Ret_value ty ->
-        let eres = new_temp ~name:"_res" ty in
-        (ty, params, transf_funbody env f.fd_body (Some eres)) in
+         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_ret = ret1; fd_params = params1;
-          fd_locals = f.fd_locals @ temps; fd_body = body1}
+  {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 *)
 
@@ -288,6 +569,14 @@ let transf_composite env su id attr fl =
 (* Entry point *)
 
 let program p =
+  struct_passing_style :=
+    if !Clflags.option_interp
+    then SP_ref_callee
+    else !Clflags.option_fstruct_passing_style;
+  struct_return_style :=
+    if !Clflags.option_interp
+    then SR_ref
+    else !Clflags.option_fstruct_return_style;
   Transform.program
     ~decl:transf_decl
     ~fundef:transf_fundef
diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml
index 405986f3..4013db9b 100644
--- a/cparser/Unblock.ml
+++ b/cparser/Unblock.ml
@@ -149,7 +149,7 @@ let rec expand_expr islocal env e =
     | ECall(e1, el) ->
         {edesc = ECall(expand e1, List.map expand el); etyp = e.etyp}
   in 
-    let e' = expand e in add_inits_expr !inits e'
+    let e' = expand e in ecommalist !inits e'
 
 (* Elimination of compound literals within an initializer. *)