Merge of branches/full-expr-4:

- Csyntax, Csem: source C language has side-effects within expressions,
  performs implicit casts, and has nondeterministic reduction semantics
  for expressions
- Cstrategy: deterministic red. sem. for the above
- Clight: the previous source C language, with pure expressions.
  Added: temporary variables + implicit casts.
- New pass SimplExpr to pull side-effects out of expressions
  (previously done in untrusted Caml code in cparser/)
- Csharpminor: added temporary variables to match Clight.
- Cminorgen: adapted, removed cast optimization (moved to back-end)
- CastOptim: RTL-level optimization of casts
- cparser: transformations Bitfields, StructByValue and StructAssign
  now work on non-simplified expressions
- Added pretty-printers for several intermediate languages,
  and matching -dxxx command-line flags.



git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1467 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e

7 files changed, 440 insertions, 194 deletions

diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml
index dea1862..2abe6b1 100644
--- a/cparser/Bitfields.ml
+++ b/cparser/Bitfields.ml
@@ -175,107 +175,194 @@ let bitfield_assign bf carrier newval =
   {edesc = EBinop(Oor,  oldval_masked, newval_masked,  TInt(IUInt,[]));
    etyp =  TInt(IUInt,[])}
 
-(* Expressions *)
+(* Detect invariant l-values *)
+
+let rec invariant_lvalue e =
+  match e.edesc with
+  | EVar _ -> true
+  | EUnop(Oderef, {edesc = EVar _}) -> true   (* to check *)
+  | EUnop(Odot _, e1) -> invariant_lvalue e1
+  | _ -> false
+
+(* Bind a l-value to a temporary variable if it is not invariant. *)
+
+let bind_lvalue e fn =
+  if invariant_lvalue e then
+    fn e
+  else begin
+    let tmp = new_temp (TPtr(e.etyp, [])) in
+    ecomma (eassign tmp (eaddrof e))
+           (fn {edesc = EUnop(Oderef, tmp); etyp = e.etyp})
+  end
+
+(* Transformation of operators *)
+
+let op_for_incr_decr = function
+  | Opreincr -> Oadd
+  | Opredecr -> Osub
+  | Opostincr -> Oadd
+  | Opostdecr -> Osub
+  | _ -> assert false
 
-let transf_expr env e =
+let op_for_assignop = function
+  | Oadd_assign -> Oadd
+  | Osub_assign -> Osub
+  | Omul_assign -> Omul
+  | Odiv_assign -> Odiv
+  | Omod_assign -> Omod
+  | Oand_assign -> Oand
+  | Oor_assign -> Oor 
+  | Oxor_assign -> Oxor
+  | Oshl_assign -> Oshl
+  | Oshr_assign -> Oshr
+  | _ -> assert false
 
-  let is_bitfield_access ty fieldname =
-    match unroll env ty with
-    | TStruct(id, _) ->
-        (try Some(Hashtbl.find bitfield_table (id, fieldname))
-         with Not_found -> None)
-    | _ -> None in
+(* Check whether a field access (e.f or e->f) is a bitfield access.
+   If so, return carrier expression (e and *e, respectively)
+   and bitfield_info *)
+
+let rec is_bitfield_access env e =
+  match e.edesc with
+  | EUnop(Odot fieldname, e1) ->
+      begin match unroll env e1.etyp with
+      | TStruct(id, _) ->
+          (try Some(e1, Hashtbl.find bitfield_table (id, fieldname))
+           with Not_found -> None)
+      | _ ->
+          None
+      end
+  | EUnop(Oarrow fieldname, e1) ->
+      begin match unroll env e1.etyp with
+      | TPtr(ty, _) ->
+          is_bitfield_access env
+            {edesc = EUnop(Odot fieldname,
+                           {edesc = EUnop(Oderef, e1); etyp = ty});
+             etyp = e.etyp}
+      | _ ->
+          None
+      end
+  | _ -> None
 
-  let is_bitfield_access_ptr ty fieldname =
-    match unroll env ty with
-    | TPtr(ty', _) -> is_bitfield_access ty' fieldname
-    | _ -> None in 
+(* Expressions *)
 
-  let rec texp e =
+type context = Val | Effects
+
+let transf_expr env ctx e =
+
+  let rec texp ctx e =
     match e.edesc with
     | EConst _ -> e
     | ESizeof _ -> e
     | EVar _ -> e
 
-    | EUnop(Odot fieldname, e1) ->
-        let e1' = texp e1 in
-        begin match is_bitfield_access e1.etyp fieldname with
+    | EUnop(Odot s, e1) ->
+        begin match is_bitfield_access env e with
         | None ->
-            {edesc = EUnop(Odot fieldname, e1'); etyp = e.etyp}
-        | Some bf ->
-            bitfield_extract bf
-              {edesc = EUnop(Odot bf.bf_carrier, e1');
-               etyp = bf.bf_carrier_typ}
+            {edesc = EUnop(Odot s, texp Val e1); etyp = e.etyp}
+        | Some(ex, bf) ->
+            transf_read ex bf
         end
-
-    | EUnop(Oarrow fieldname, e1) ->
-        let e1' = texp e1 in
-        begin match is_bitfield_access_ptr e1.etyp fieldname with
+    | EUnop(Oarrow s, e1) ->
+        begin match is_bitfield_access env e with
         | None ->
-            {edesc = EUnop(Oarrow fieldname, e1'); etyp = e.etyp}
-        | Some bf ->
-            bitfield_extract bf
-              {edesc = EUnop(Oarrow bf.bf_carrier, e1');
-               etyp = bf.bf_carrier_typ}
+            {edesc = EUnop(Oarrow s, texp Val e1); etyp = e.etyp}
+        | Some(ex, bf) ->
+            transf_read ex bf
         end
-
-    | EUnop(op, e1) ->
-        (* Note: simplified expr, so no ++/-- *)
-        {edesc = EUnop(op, texp e1); etyp = e.etyp}
+    | EUnop((Opreincr|Opredecr) as op, e1) ->
+        begin match is_bitfield_access env e1 with
+        | None ->
+            {edesc = EUnop(op, texp Val e1); etyp = e.etyp}
+        | Some(ex, bf) ->
+            transf_pre ctx (op_for_incr_decr op) ex bf e1.etyp
+        end
+    | EUnop((Opostincr|Opostdecr) as op, e1) ->
+        begin match is_bitfield_access env e1 with
+        | None ->
+            {edesc = EUnop(op, texp Val e1); etyp = e.etyp}
+        | Some(ex, bf) ->
+            transf_post ctx (op_for_incr_decr op) ex bf e1.etyp
+        end
+    | EUnop(op, e1) -> 
+        {edesc = EUnop(op, texp Val e1); etyp = e.etyp}
 
     | EBinop(Oassign, e1, e2, ty) ->
-        begin match e1.edesc with
-        | EUnop(Odot fieldname, e11) ->
-            let lhs = texp e11 in let rhs = texp e2 in
-            begin match is_bitfield_access e11.etyp fieldname with
-            | None ->
-                {edesc = EBinop(Oassign,
-                                {edesc = EUnop(Odot fieldname, lhs);
-                                 etyp = e1.etyp},
-                                rhs, ty);
-                 etyp = e.etyp}
-            | Some bf ->
-                let carrier =
-                  {edesc = EUnop(Odot bf.bf_carrier, lhs);
-                   etyp = bf.bf_carrier_typ} in
-                {edesc = EBinop(Oassign, carrier,
-                                bitfield_assign bf carrier rhs,
-                                carrier.etyp);
-                 etyp = carrier.etyp}
-            end
-        | EUnop(Oarrow fieldname, e11) ->
-            let lhs = texp e11 in let rhs = texp e2 in
-            begin match is_bitfield_access_ptr e11.etyp fieldname with
-            | None ->
-                {edesc = EBinop(Oassign,
-                                {edesc = EUnop(Oarrow fieldname, lhs);
-                                 etyp = e1.etyp},
-                                rhs, ty);
-                 etyp = e.etyp}
-            | Some bf ->
-                let carrier =
-                  {edesc = EUnop(Oarrow bf.bf_carrier, lhs);
-                   etyp = bf.bf_carrier_typ} in
-                {edesc = EBinop(Oassign, carrier,
-                                bitfield_assign bf carrier rhs,
-                                carrier.etyp);
-                 etyp = carrier.etyp}
-            end
-        | _ ->
-            {edesc = EBinop(Oassign, texp e1, texp e2, e1.etyp); etyp = e1.etyp}
+        begin match is_bitfield_access env e1 with
+        | None ->
+            {edesc = EBinop(Oassign, texp Val e1, texp Val e2, ty);
+             etyp = e.etyp}
+        | Some(ex, bf) ->
+            transf_assign ctx ex bf e2
         end
-
+    | EBinop((Oadd_assign|Osub_assign|Omul_assign|Odiv_assign
+                         |Omod_assign|Oand_assign|Oor_assign|Oxor_assign
+                         |Oshl_assign|Oshr_assign) as op,
+             e1, e2, ty) ->
+        begin match is_bitfield_access env e1 with
+        | None ->
+            {edesc = EBinop(op, texp Val e1, texp Val e2, ty); etyp = e.etyp}
+        | Some(ex, bf) ->
+            transf_assignop ctx (op_for_assignop op) ex bf e2 ty
+        end
+    | EBinop(Ocomma, e1, e2, ty) ->
+        {edesc = EBinop(Ocomma, texp Effects e1, texp Val e2, ty);
+         etyp = e.etyp}
     | EBinop(op, e1, e2, ty) ->
-        (* Note: simplified expr assumed, so no assign-op *)
-        {edesc = EBinop(op, texp e1, texp e2, ty); etyp = e.etyp}
+        {edesc = EBinop(op, texp Val e1, texp Val e2, ty); etyp = e.etyp}
+
     | EConditional(e1, e2, e3) ->
-        {edesc = EConditional(texp e1, texp e2, texp e3); etyp = e.etyp}
+        {edesc = EConditional(texp Val e1, texp ctx e2, texp ctx e3);
+         etyp = e.etyp}
     | ECast(ty, e1) ->
-        {edesc = ECast(ty, texp e1); etyp = e.etyp}
+        {edesc = ECast(ty, texp Val e1); etyp = e.etyp}
     | ECall(e1, el) ->
-        {edesc = ECall(texp e1, List.map texp el); etyp = e.etyp}
-
-  in texp e
+        {edesc = ECall(texp Val e1, List.map (texp Val) el); etyp = e.etyp}
+
+  and transf_read e bf =
+    bitfield_extract bf
+      {edesc = EUnop(Odot bf.bf_carrier, texp Val e); etyp = bf.bf_carrier_typ}
+
+  and transf_assign ctx e1 bf e2 =
+    bind_lvalue (texp Val e1) (fun base ->
+      let carrier =
+        {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in
+      let asg =
+        eassign carrier (bitfield_assign bf carrier (texp Val e2)) in
+      if ctx = Val then ecomma asg (bitfield_extract bf carrier) else asg)
+
+  and transf_assignop ctx op e1 bf e2 tyres =
+    bind_lvalue (texp Val e1) (fun base ->
+      let carrier =
+        {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in
+      let rhs =
+        {edesc = EBinop(op, bitfield_extract bf carrier, texp Val e2, tyres);
+         etyp = tyres} in
+      let asg =
+        eassign carrier (bitfield_assign bf carrier rhs) in
+      if ctx = Val then ecomma asg (bitfield_extract bf carrier) else asg)
+
+  and transf_pre ctx op e1 bf tyfield =
+    transf_assignop ctx op e1 bf (intconst 1L IInt)
+                                 (unary_conversion env tyfield)
+
+  and transf_post ctx op e1 bf tyfield  =
+    if ctx = Effects then
+      transf_pre ctx op e1 bf tyfield
+    else begin
+      bind_lvalue (texp Val e1) (fun base ->
+        let carrier =
+          {edesc = EUnop(Odot bf.bf_carrier, base); etyp = bf.bf_carrier_typ} in
+        let temp = new_temp tyfield in
+        let tyres = unary_conversion env tyfield in
+        let settemp = eassign temp (bitfield_extract bf carrier) in
+        let rhs =
+          {edesc = EBinop(op, temp, intconst 1L IInt, tyres); etyp = tyres} in
+        let asg =
+          eassign carrier (bitfield_assign bf carrier rhs) in
+        ecomma (ecomma settemp asg) temp)
+    end
+
+  in texp ctx e
 
 (* Statements *)
 
@@ -283,39 +370,43 @@ let rec transf_stmt env s =
   match s.sdesc with
   | Sskip -> s
   | Sdo e ->
-      {sdesc = Sdo(transf_expr env e); sloc = s.sloc}
+      {sdesc = Sdo(transf_expr env Effects e); sloc = s.sloc}
   | Sseq(s1, s2) -> 
       {sdesc = Sseq(transf_stmt env s1, transf_stmt env s2); sloc = s.sloc }
   | Sif(e, s1, s2) ->
-      {sdesc = Sif(transf_expr env e, transf_stmt env s1, transf_stmt env s2);
+      {sdesc = Sif(transf_expr env Val e, transf_stmt env s1, transf_stmt env s2);
        sloc = s.sloc}
   | Swhile(e, s1) ->
-      {sdesc = Swhile(transf_expr env e, transf_stmt env s1);
+      {sdesc = Swhile(transf_expr env Val e, transf_stmt env s1);
        sloc = s.sloc}
   | Sdowhile(s1, e) ->
-      {sdesc = Sdowhile(transf_stmt env s1, transf_expr env e);
+      {sdesc = Sdowhile(transf_stmt env s1, transf_expr env Val e);
        sloc = s.sloc}
   | Sfor(s1, e, s2, s3) ->
-      {sdesc = Sfor(transf_stmt env s1, transf_expr env e, transf_stmt env s2,
-                    transf_stmt env s3);
+      {sdesc = Sfor(transf_stmt env s1, transf_expr env Val e,
+                    transf_stmt env s2, transf_stmt env s3);
        sloc = s.sloc}
   | Sbreak -> s
   | Scontinue -> s
   | Sswitch(e, s1) ->
-      {sdesc = Sswitch(transf_expr env e, transf_stmt env s1); sloc = s.sloc}
+      {sdesc = Sswitch(transf_expr env Val e, transf_stmt env s1);
+       sloc = s.sloc}
   | Slabeled(lbl, s) ->
       {sdesc = Slabeled(lbl, transf_stmt env s); sloc = s.sloc}
   | Sgoto lbl -> s
   | Sreturn None -> s
   | Sreturn (Some e) ->
-      {sdesc = Sreturn(Some(transf_expr env e)); sloc = s.sloc}
+      {sdesc = Sreturn(Some(transf_expr env Val e)); sloc = s.sloc}
   | Sblock _ | Sdecl _ ->
       assert false     (* should not occur in unblocked code *)
 
 (* Functions *)
 
 let transf_fundef env f =
-  { f with fd_body = transf_stmt env f.fd_body }
+  reset_temps();
+  let newbody = transf_stmt env f.fd_body in
+  let temps = get_temps() in  
+  { f with fd_locals = f.fd_locals @ temps; fd_body = newbody }
 
 (* Initializers *)
 
@@ -374,7 +465,7 @@ let rec transf_struct_init id fld_init_list =
 
 let rec transf_init env i =
   match i with
-  | Init_single e -> Init_single (transf_expr env e)
+  | Init_single e -> Init_single (transf_expr env Val e)
   | Init_array il -> Init_array (List.map (transf_init env) il)
   | Init_struct(id, fld_init_list) ->
       let fld_init_list' =
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index 49b25a2..c7c5e30 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -655,6 +655,18 @@ let floatconst v fk =
 let nullconst =
   { edesc = EConst(CInt(0L, ptr_t_ikind, "0")); etyp = TPtr(TVoid [], []) }
 
+(* Construct an address-of expression *)
+
+let eaddrof e = { edesc = EUnop(Oaddrof, e); etyp = TPtr(e.etyp, []) }
+
+(* Construct an assignment expression *)
+
+let eassign e1 e2 = { edesc = EBinop(Oassign, e1, e2, e1.etyp); etyp = e1.etyp }
+
+(* Construct a "," expression *)
+
+let ecomma e1 e2 = { edesc = EBinop(Ocomma, e1, e2, e2.etyp); etyp = e2.etyp }
+
 (* Construct a sequence *)
 
 let sseq loc s1 s2 =
@@ -667,8 +679,7 @@ let sseq loc s1 s2 =
 (* Construct an assignment statement *)
 
 let sassign loc lv rv =
-  { sdesc = Sdo {edesc = EBinop(Oassign, lv, rv, lv.etyp); etyp = lv.etyp};
-    sloc = loc }
+  { sdesc = Sdo (eassign lv rv); sloc = loc }
 
 (* Empty location *)
 
diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli
index 9587c57..2e61cf5 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -155,6 +155,12 @@ val floatconst : float -> fkind -> exp
   (* Build expression for given float constant. *)
 val nullconst : exp
   (* Expression for [(void * ) 0] *)
+val eaddrof : exp -> exp
+  (* Expression for [&e] *)
+val eassign : exp -> exp -> exp
+  (* Expression for [e1 = e2] *)
+val ecomma :  exp -> exp -> exp
+  (* Expression for [e1, e2] *)
 val sskip: stmt
   (* The [skip] statement.  No location. *)
 val sseq : location -> stmt -> stmt -> stmt
diff --git a/cparser/Makefile b/cparser/Makefile
index 59d4b47..f4c1274 100644
--- a/cparser/Makefile
+++ b/cparser/Makefile
@@ -40,7 +40,7 @@ cparser.byte: $(COBJS) $(BOBJS) Main.cmo
 	$(OCAMLC) -custom -o cparser.byte str.cma $(COBJS) $(BOBJS) Main.cmo
 
 clean::
-	rm -f cparser
+	rm -f cparser.byte
 
 cparser.cma libcparser.a: uint64.o Cparser.cmo 
 	$(OCAMLMKLIB) -o cparser uint64.o Cparser.cmo
@@ -82,7 +82,7 @@ beforedepend:: Lexer.ml
 	$(OCAMLC) -c $*.c
 
 clean::
-	rm -f *.cm? *.o *.so
+	rm -f *.cm? *.cmxa *.o *.so *.a
 
 depend: beforedepend
 	$(OCAMLDEP) *.mli *.ml > .depend
diff --git a/cparser/Parse.ml b/cparser/Parse.ml
index 7dcc8d1..ed988f9 100644
--- a/cparser/Parse.ml
+++ b/cparser/Parse.ml
@@ -21,10 +21,10 @@ let transform_program t p =
   let run_pass pass flag p = if CharSet.mem flag t then pass p else p in
   Rename.program
   (run_pass (AddCasts.program ~all:(CharSet.mem 'C' t)) 'c'
+  (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'v' t)) 'e'
   (run_pass StructAssign.program 'S'
   (run_pass StructByValue.program 's'
   (run_pass Bitfields.program 'f'
-  (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'v' t)) 'e'
   (run_pass Unblock.program 'b'
   p))))))
 
@@ -37,9 +37,9 @@ let parse_transformations s =
             | 'c' -> set "ec"
             | 'C' -> set "ecC"
             | 's' -> set "s"
-            | 'S' -> set "esS"
+            | 'S' -> set "bsS"
             | 'v' -> set "ev"
-            | 'f' -> set "bef"
+            | 'f' -> set "bf"
             |  _  -> ())
     s;
   !t
diff --git a/cparser/StructAssign.ml b/cparser/StructAssign.ml
index 725c136..51cb489 100644
--- a/cparser/StructAssign.ml
+++ b/cparser/StructAssign.ml
@@ -15,17 +15,23 @@
 
 (* Expand assignments between structs and between unions *)
 
-(* Assumes: simplified code.
-   Preserves: simplified code, unblocked code *)
+(* Assumes: unblocked code.
+   Preserves: unblocked code *)
 
 open C
 open Machine
 open Cutil
 open Env
 open Errors
+open Transform
+
+(* Max number of assignments that can be inlined.  Above this threshold,
+   we call memcpy() instead. *)
 
 let maxsize = ref 8
 
+(* Finding appropriate memcpy functions *)
+
 let memcpy_decl = ref (None : ident option)
 
 let memcpy_type =
@@ -57,7 +63,18 @@ let memcpy_words_ident env =
   try lookup_function env "__builtin_memcpy_words"
   with Env.Error _ -> memcpy_ident env
 
-let transf_assign env loc lhs rhs =
+(* Smart constructor for "," expressions *)
+
+let comma e1 e2 =
+  match e1.edesc, e2.edesc with
+  | EConst _, _ -> e2
+  | _, EConst _ -> e1
+  | _, _ ->  ecomma e1 e2
+
+(* Translate an assignment [lhs = rhs] between composite types.
+   [lhs] and [rhs] must be pure, invariant l-values. *)
+
+let transf_assign env lhs rhs =
 
   let num_assign = ref 0 in
 
@@ -65,38 +82,35 @@ let transf_assign env loc lhs rhs =
     incr num_assign;
     if !num_assign > !maxsize 
     then raise Exit
-    else sassign loc l r in
+    else eassign l r in
 
   let rec transf l r =
     match unroll env l.etyp with
     | TStruct(id, attr) ->
         let ci = Env.find_struct env id in
-        if ci.ci_sizeof = None then
-          error "%a: Error: incomplete struct '%s'" formatloc loc id.name;
         transf_struct l r ci.ci_members
     | TUnion(id, attr) ->
         raise Exit
     | TArray(ty_elt, Some sz, attr) ->
         transf_array l r ty_elt 0L sz
     | TArray(ty_elt, None, attr) ->
-        error "%a: Error: array of unknown size" formatloc loc;
-        sskip                           (* will be ignored later *)
+        assert false
     | _ ->
         assign l r
 
   and transf_struct l r = function
-    | [] -> sskip
+    | [] -> nullconst
     | f :: fl ->
-        sseq loc (transf {edesc = EUnop(Odot f.fld_name, l); etyp = f.fld_typ}
-                         {edesc = EUnop(Odot f.fld_name, r); etyp = f.fld_typ})
-                 (transf_struct l r fl)
+        comma (transf {edesc = EUnop(Odot f.fld_name, l); etyp = f.fld_typ}
+                      {edesc = EUnop(Odot f.fld_name, r); etyp = f.fld_typ})
+              (transf_struct l r fl)
 
   and transf_array l r ty idx sz =
-    if idx >= sz then sskip else begin
+    if idx >= sz then nullconst else begin
       let e = intconst idx size_t_ikind in
-      sseq loc (transf {edesc = EBinop(Oindex, l, e, ty); etyp = ty}
-                       {edesc = EBinop(Oindex, r, e, ty); etyp = ty})
-               (transf_array l r ty (Int64.add idx 1L) sz)
+      comma (transf {edesc = EBinop(Oindex, l, e, ty); etyp = ty}
+                    {edesc = EBinop(Oindex, r, e, ty); etyp = ty})
+            (transf_array l r ty (Int64.add idx 1L) sz)
     end
   in
 
@@ -115,42 +129,101 @@ let transf_assign env loc lhs rhs =
     let e_lhs = {edesc = EUnop(Oaddrof, lhs); etyp = TPtr(lhs.etyp, [])} in
     let e_rhs = {edesc = EUnop(Oaddrof, rhs); etyp = TPtr(rhs.etyp, [])} in
     let e_size = {edesc = ESizeof(lhs.etyp); etyp = TInt(size_t_ikind, [])} in
-    {sdesc = Sdo {edesc = ECall(memcpy, [e_lhs; e_rhs; e_size]);
-                  etyp = TVoid[]};
-     sloc = loc}
+    {edesc = ECall(memcpy, [e_lhs; e_rhs; e_size]); etyp = TVoid[]}
+
+(* Detect invariant l-values *)
+
+let rec invariant_lvalue e =
+  match e.edesc with
+  | EVar _ -> true
+  | EUnop(Oderef, {edesc = EVar _}) -> true   (* to check *)
+  | EUnop(Odot _, e1) -> invariant_lvalue e1
+  | _ -> false
+
+(* Bind a l-value to a temporary variable if it is not invariant. *)
+
+let rec bind_lvalue e fn =
+  match e.edesc with
+  | EBinop(Ocomma, e1, e2, _) ->
+      ecomma e1 (bind_lvalue e2 fn)
+  | _ ->
+      if invariant_lvalue e then
+        fn e
+      else begin
+        let tmp = new_temp (TPtr(e.etyp, [])) in
+        ecomma (eassign tmp (eaddrof e))
+               (fn {edesc = EUnop(Oderef, tmp); etyp = e.etyp})
+      end
+
+(* Transformation of expressions. *)
+
+type context = Val | Effects
+
+let rec transf_expr env ctx e =
+  match e.edesc with
+  | EBinop(Oassign, lhs, rhs, _) when is_composite_type env lhs.etyp ->
+      bind_lvalue (transf_expr env Val lhs) (fun l ->
+      bind_lvalue (transf_expr env Val rhs) (fun r ->
+        let e' = transf_assign env l r in
+        if ctx = Val then ecomma e' l else e'))
+  | EConst c -> e
+  | ESizeof ty -> e
+  | EVar x -> e
+  | EUnop(op, e1) ->
+      {edesc = EUnop(op, transf_expr env Val e1); etyp = e.etyp}
+  | EBinop(Ocomma, e1, e2, ty) ->
+      {edesc = EBinop(Ocomma, transf_expr env Effects e1,
+                              transf_expr env ctx e2, ty);
+       etyp = e.etyp}
+  | EBinop(op, e1, e2, ty) ->
+      {edesc = EBinop(op, transf_expr env Val e1,
+                          transf_expr env Val e2, ty);
+       etyp = e.etyp}
+  | EConditional(e1, e2, e3) ->
+      {edesc = EConditional(transf_expr env Val e1,
+                            transf_expr env ctx e2, transf_expr env ctx e3);
+       etyp = e.etyp}
+  | ECast(ty, e1) ->
+      {edesc = ECast(ty, transf_expr env Val e1); etyp = e.etyp}
+  | ECall(e1, el) ->
+      {edesc = ECall(transf_expr env Val e1,
+                     List.map (transf_expr env Val) el);
+       etyp = e.etyp}
+
+(* Transformation of statements *)
 
 let rec transf_stmt env s =
   match s.sdesc with
   | Sskip -> s
-  | Sdo {edesc = EBinop(Oassign, lhs, rhs, _)}
-    when is_composite_type env lhs.etyp ->
-      transf_assign env s.sloc lhs rhs
-  | Sdo _ -> s
+  | Sdo e -> {s with sdesc = Sdo(transf_expr env Effects e)}
   | Sseq(s1, s2) ->
       {s with sdesc = Sseq(transf_stmt env s1, transf_stmt env s2)}
   | Sif(e, s1, s2) ->
-      {s with sdesc = Sif(e, transf_stmt env s1, transf_stmt env s2)}
+      {s with sdesc = Sif(transf_expr env Val e,
+                          transf_stmt env s1, transf_stmt env s2)}
   | Swhile(e, s1) ->
-      {s with sdesc = Swhile(e, transf_stmt env s1)}
+      {s with sdesc = Swhile(transf_expr env Val e, transf_stmt env s1)}
   | Sdowhile(s1, e) ->
-      {s with sdesc = Sdowhile(transf_stmt env s1, e)}
+      {s with sdesc = Sdowhile(transf_stmt env s1, transf_expr env Val e)}
   | Sfor(s1, e, s2, s3) ->
-      {s with sdesc = Sfor(transf_stmt env s1, e,
+      {s with sdesc = Sfor(transf_stmt env s1, transf_expr env Val e,
                            transf_stmt env s2, transf_stmt env s3)}
   | Sbreak -> s
   | Scontinue -> s
   | Sswitch(e, s1) ->
-      {s with sdesc = Sswitch(e, transf_stmt env s1)}
+      {s with sdesc = Sswitch(transf_expr env Val e, transf_stmt env s1)}
   | Slabeled(lbl, s1) ->
       {s with sdesc = Slabeled(lbl, transf_stmt env s1)}
   | Sgoto lbl -> s
-  | Sreturn _ -> s
-  | Sblock sl ->
-      {s with sdesc = Sblock(List.map (transf_stmt env) sl)}
-  | Sdecl d -> s
-
-let transf_fundef env fd =
-  {fd with fd_body = transf_stmt env fd.fd_body}
+  | Sreturn None -> s
+  | Sreturn (Some e) -> {s with sdesc = Sreturn(Some(transf_expr env Val e))}
+  | Sblock _ | Sdecl _ -> assert false (* not in unblocked code *)
+
+let transf_fundef env f =
+  reset_temps();
+  let newbody = transf_stmt env f.fd_body in
+  let temps = get_temps() in
+  {f with fd_locals = f.fd_locals @ temps; fd_body = newbody}
 
 let program p =
   memcpy_decl := None;
diff --git a/cparser/StructByValue.ml b/cparser/StructByValue.ml
index de79737..c66af32 100644
--- a/cparser/StructByValue.ml
+++ b/cparser/StructByValue.ml
@@ -16,7 +16,7 @@
 (* Eliminate by-value passing of structs and unions. *)
 
 (* Assumes: nothing.
-   Preserves: simplified code, unblocked code *)
+   Preserves: unblocked code *)
 
 open C
 open Cutil
@@ -55,30 +55,126 @@ and transf_funarg env (id, t) =
   then (id, TPtr(add_attributes_type [AConst] t, []))
   else (id, t)
 
-(* Simple exprs: no change in structure, since calls cannot occur within,
-   but need to rewrite the types. *)
-
-let rec transf_expr env e =
-  { etyp = transf_type env e.etyp;
-    edesc = match e.edesc with
-      | EConst c -> EConst c
-      | ESizeof ty -> ESizeof (transf_type env ty)
-      | EVar x -> EVar x
-      | EUnop(op, e1) -> EUnop(op, transf_expr env e1)
-      | EBinop(op, e1, e2, ty) ->
-          EBinop(op, transf_expr env e1, transf_expr env e2, transf_type env ty)
-      | EConditional(e1, e2, e3) ->
-          assert (not (is_composite_type env e.etyp));
-          EConditional(transf_expr env e1, transf_expr env e2, transf_expr env e3)
-      | ECast(ty, e1) -> ECast(transf_type env ty, transf_expr env e1)
-      | ECall(e1, el) -> assert false
-  }
+(* Expressions: transform calls + rewrite the types *)
+
+type context = Val | Effects
+
+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}
+  | 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)}, ty)
+    when is_composite_type env ty ->
+      transf_composite_call env ctx (Some lhs) fn args ty
+  | EBinop(Ocomma, e1, e2, ty) ->
+      {edesc = EBinop(Ocomma, transf_expr env Effects e1,
+                              transf_expr env ctx e2,
+                              transf_type env ty);
+       etyp = newty}
+  | 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}
+  | ECall(fn, args) ->
+      if is_composite_type env e.etyp then
+        transf_composite_call env ctx None fn args e.etyp
+      else
+        {edesc = ECall(transf_expr env Val fn, List.map (transf_arg env) args);
+         etyp = newty}
+
+(* Function arguments: pass by reference those having composite type *)
+
+and transf_arg env e =
+  let e' = transf_expr env Val e in
+  if is_composite_type env e'.etyp then eaddrof e' else e'
+
+(* Function calls returning a composite: add first argument.
+    ctx = Effects:   lv = f(...)     -> f(&lv, ...)
+                     f(...)          -> f(&newtemp, ...)
+    ctx = Val:       lv = f(...)     -> f(&newtemp, ...), lv = newtemp, newtemp
+                     f(...)          -> f(&newtemp, ...), newtemp
+*)
+
+and transf_composite_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_arg env) args in
+  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 (ecomma {edesc = ECall(fn, eaddrof tmp :: args); etyp = TVoid []}
+                     (eassign lhs tmp))
+             tmp
+
+(* The transformation above can create ill-formed lhs containing ",", as in
+     f().x = y    --->   (f(&tmp), tmp).x = y
+     f(g(x));     --->   f(&(g(&tmp),tmp))
+   We fix this by floating the "," above the lhs, up to the nearest enclosing
+   rhs:
+     f().x = y    --->   (f(&tmp), tmp).x = y   --> f(&tmp), tmp.x = y
+     f(g(x));     --->   f(&(g(&tmp),tmp))      --> f((g(&tmp), &tmp))
+*)
+
+let rec float_comma e =
+  match e.edesc with
+  | EConst c -> e
+  | ESizeof ty -> e
+  | EVar x -> e
+  (* lvalue-consuming unops *)
+  | EUnop((Oaddrof|Opreincr|Opredecr|Opostincr|Opostdecr|Odot _) as op,
+          {edesc = EBinop(Ocomma, e1, e2, _)}) ->
+      ecomma (float_comma e1)
+             (float_comma {edesc = EUnop(op, e2); etyp = e.etyp})
+  (* lvalue-consuming binops *)
+  | EBinop((Oassign|Oadd_assign|Osub_assign|Omul_assign|Odiv_assign
+                   |Omod_assign|Oand_assign|Oor_assign|Oxor_assign
+                   |Oshl_assign|Oshr_assign) as op,
+           {edesc = EBinop(Ocomma, e1, e2, _)}, e3, tyres) ->
+      ecomma (float_comma e1)
+             (float_comma {edesc = EBinop(op, e2, e3, tyres); etyp = e.etyp})
+  (* other expressions *)
+  | EUnop(op, e1) ->
+      {edesc = EUnop(op, float_comma e1); etyp = e.etyp}
+  | EBinop(op, e1, e2, tyres) ->
+      {edesc = EBinop(op, float_comma e1, float_comma e2, tyres); etyp = e.etyp}
+  | EConditional(e1, e2, e3) ->
+      {edesc = EConditional(float_comma e1, float_comma e2, float_comma e3);
+       etyp = e.etyp}
+  | ECast(ty, e1) ->
+      {edesc = ECast(ty, float_comma e1); etyp = e.etyp}
+  | ECall(e1, el) ->
+      {edesc = ECall(float_comma e1, List.map float_comma el); etyp = e.etyp}
 
 (* Initializers *)
 
 let rec transf_init env = function
   | Init_single e ->
-      Init_single (transf_expr env e)
+      Init_single (float_comma(transf_expr env Val e))
   | Init_array il ->
       Init_array (List.map (transf_init env) il)
   | Init_struct(id, fil) ->
@@ -96,70 +192,39 @@ let transf_decl env (sto, id, ty, init) =
 
 let transf_funbody env body optres =
 
-let transf_type t = transf_type env t
-and transf_expr e = transf_expr env e in
-
-(* Function arguments: pass by reference those having struct/union type *)
-
-let transf_arg e =
-  let e' = transf_expr e in
-  if is_composite_type env e'.etyp
-  then {edesc = EUnop(Oaddrof, e'); etyp = TPtr(e'.etyp, [])}
-  else e'
-in
+let transf_expr ctx e = float_comma(transf_expr env ctx e) in
 
-(* Function calls: if return type is struct or union,
-     lv = f(...)   -> f(&lv, ...)
-     f(...)        -> f(&newtemp, ...)
-   Returns: if return type is struct or union,
+(* Function returns: if return type is struct or union,
      return x      -> _res = x; return
 *)
 
 let rec transf_stmt s =
   match s.sdesc with
   | Sskip -> s
-  | Sdo {edesc = ECall(fn, args); etyp = ty} ->
-      let fn = transf_expr fn in
-      let args = List.map transf_arg args in
-      if is_composite_type env ty then begin
-        let tmp = new_temp ~name:"_res" ty in
-        let arg0 = {edesc = EUnop(Oaddrof, tmp); etyp = TPtr(ty, [])} in
-        {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}}
-      end else
-        {s with sdesc = Sdo {edesc = ECall(fn, args); etyp = ty}}
-  | Sdo {edesc = EBinop(Oassign, dst, {edesc = ECall(fn, args); etyp = ty}, _)} ->
-      let dst = transf_expr dst in
-      let fn = transf_expr fn in
-      let args = List.map transf_arg args in
-      let ty = transf_type ty in
-      if is_composite_type env ty then begin
-        let arg0 = {edesc = EUnop(Oaddrof, dst); etyp = TPtr(dst.etyp, [])} in
-        {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}}
-      end else
-        sassign s.sloc dst {edesc = ECall(fn, args); etyp = ty}
   | Sdo e ->
-      {s with sdesc = Sdo(transf_expr 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 e, transf_stmt s1, transf_stmt s2)}
+      {s with sdesc = Sif(transf_expr Val e,
+                          transf_stmt s1, transf_stmt s2)}
   | Swhile(e, s1) ->
-      {s with sdesc = Swhile(transf_expr e, transf_stmt s1)}
+      {s with sdesc = Swhile(transf_expr Val e, transf_stmt s1)}
   | Sdowhile(s1, e) ->
-      {s with sdesc = Sdowhile(transf_stmt s1, transf_expr 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 e,
+      {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 e, transf_stmt 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 e in
+      let e = transf_expr Val e in
       begin match optres with
       | None ->
           {s with sdesc = Sreturn(Some e)}