From 05e4823231b911aa103ebb0339a9d3519606a028 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rich@annexia.org>
Date: Tue, 26 Aug 2008 08:22:42 +0000
Subject: [PATCH] This large, but mostly mechanical, patch removes an
 unnecessary tuple allocation from generated code.

---
 bitstring.ml    | 106 ++++++++++++--------
 bitstring.mli   |  35 ++++---
 pa_bitstring.ml | 305 +++++++++++++++++++++++++++++++++++++-------------------
 3 files changed, 283 insertions(+), 163 deletions(-)

diff --git a/bitstring.ml b/bitstring.ml
index 610c2b5..9712189 100644
--- a/bitstring.ml
+++ b/bitstring.ml
@@ -372,10 +372,10 @@ end
 
 (* Bitstrings. *)
 let extract_bitstring data off len flen =
-  (data, off, flen), off+flen, len-flen
+  (data, off, flen) (*, off+flen, len-flen*)
 
 let extract_remainder data off len =
-  (data, off, len), off+len, 0
+  (data, off, len) (*, off+len, 0*)
 
 (* Extract and convert to numeric.  A single bit is returned as
  * a boolean.  There are no endianness or signedness considerations.
@@ -384,7 +384,7 @@ let extract_bit data off len _ =	(* final param is always 1 *)
   let byteoff = off lsr 3 in
   let bitmask = 1 lsl (7 - (off land 7)) in
   let b = Char.code data.[byteoff] land bitmask <> 0 in
-  b, off+1, len-1
+  b (*, off+1, len-1*)
 
 (* Returns 8 bit unsigned aligned bytes from the string.
  * If the string ends then this returns 0's.
@@ -405,7 +405,7 @@ let extract_char_unsigned data off len flen =
   (* Optimize the common (byte-aligned) case. *)
   if off land 7 = 0 then (
     let byte = Char.code data.[byteoff] in
-    byte lsr (8 - flen), off+flen, len-flen
+    byte lsr (8 - flen) (*, off+flen, len-flen*)
   ) else (
     (* Extract the 16 bits at byteoff and byteoff+1 (note that the
      * second byte might not exist in the original string).
@@ -423,7 +423,7 @@ let extract_char_unsigned data off len flen =
     let shift = 16 - ((off land 7) + flen) in
     let word = word lsr shift in
 
-    word, off+flen, len-flen
+    word (*, off+flen, len-flen*)
   )
 
 (* Extract [9..31] bits.  We have to consider endianness and signedness. *)
@@ -457,19 +457,22 @@ let extract_int_be_unsigned data off len flen =
     ) else (
       (* Extract the next 31 bits, slow method. *)
       let word =
-	let c0, off, len = extract_char_unsigned data off len 8 in
-	let c1, off, len = extract_char_unsigned data off len 8 in
-	let c2, off, len = extract_char_unsigned data off len 8 in
-	let c3, off, len = extract_char_unsigned data off len 7 in
+	let c0 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c1 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c2 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c3 = extract_char_unsigned data off len 7 in
 	(c0 lsl 23) + (c1 lsl 15) + (c2 lsl 7) + c3 in
       word lsr (31 - flen)
     ) in
-  word, off+flen, len-flen
+  word (*, off+flen, len-flen*)
 
 let extract_int_le_unsigned data off len flen =
-  let v, off, len = extract_int_be_unsigned data off len flen in
+  let v = extract_int_be_unsigned data off len flen in
   let v = I.byteswap v flen in
-  v, off, len
+  v
 
 let extract_int_ne_unsigned =
   if nativeendian = BigEndian
@@ -518,10 +521,13 @@ let extract_int32_be_unsigned data off len flen =
     ) else (
       (* Extract the next 32 bits, slow method. *)
       let word =
-	let c0, off, len = extract_char_unsigned data off len 8 in
-	let c1, off, len = extract_char_unsigned data off len 8 in
-	let c2, off, len = extract_char_unsigned data off len 8 in
-	let c3, _, _ = extract_char_unsigned data off len 8 in
+	let c0 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c1 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c2 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c3 = extract_char_unsigned data off len 8 in
 	let c0 = Int32.of_int c0 in
 	let c1 = Int32.of_int c1 in
 	let c2 = Int32.of_int c2 in
@@ -529,12 +535,12 @@ let extract_int32_be_unsigned data off len flen =
 	_make_int32_be c0 c1 c2 c3 in
       Int32.shift_right_logical word (32 - flen)
     ) in
-  word, off+flen, len-flen
+  word (*, off+flen, len-flen*)
 
 let extract_int32_le_unsigned data off len flen =
-  let v, off, len = extract_int32_be_unsigned data off len flen in
+  let v = extract_int32_be_unsigned data off len flen in
   let v = I32.byteswap v flen in
-  v, off, len
+  v
 
 let extract_int32_ne_unsigned =
   if nativeendian = BigEndian
@@ -589,14 +595,21 @@ let extract_int64_be_unsigned data off len flen =
     ) else (
       (* Extract the next 64 bits, slow method. *)
       let word =
-	let c0, off, len = extract_char_unsigned data off len 8 in
-	let c1, off, len = extract_char_unsigned data off len 8 in
-	let c2, off, len = extract_char_unsigned data off len 8 in
-	let c3, off, len = extract_char_unsigned data off len 8 in
-	let c4, off, len = extract_char_unsigned data off len 8 in
-	let c5, off, len = extract_char_unsigned data off len 8 in
-	let c6, off, len = extract_char_unsigned data off len 8 in
-	let c7, _, _ = extract_char_unsigned data off len 8 in
+	let c0 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c1 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c2 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c3 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c4 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c5 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c6 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c7 = extract_char_unsigned data off len 8 in
 	let c0 = Int64.of_int c0 in
 	let c1 = Int64.of_int c1 in
 	let c2 = Int64.of_int c2 in
@@ -608,7 +621,7 @@ let extract_int64_be_unsigned data off len flen =
 	_make_int64_be c0 c1 c2 c3 c4 c5 c6 c7 in
       Int64.shift_right_logical word (64 - flen)
     ) in
-  word, off+flen, len-flen
+  word (*, off+flen, len-flen*)
 
 let extract_int64_le_unsigned data off len flen =
   let byteoff = off lsr 3 in
@@ -632,14 +645,21 @@ let extract_int64_le_unsigned data off len flen =
     ) else (
       (* Extract the next 64 bits, slow method. *)
       let word =
-	let c0, off, len = extract_char_unsigned data off len 8 in
-	let c1, off, len = extract_char_unsigned data off len 8 in
-	let c2, off, len = extract_char_unsigned data off len 8 in
-	let c3, off, len = extract_char_unsigned data off len 8 in
-	let c4, off, len = extract_char_unsigned data off len 8 in
-	let c5, off, len = extract_char_unsigned data off len 8 in
-	let c6, off, len = extract_char_unsigned data off len 8 in
-	let c7, _, _ = extract_char_unsigned data off len 8 in
+	let c0 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c1 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c2 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c3 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c4 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c5 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c6 = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
+	let c7 = extract_char_unsigned data off len 8 in
 	let c0 = Int64.of_int c0 in
 	let c1 = Int64.of_int c1 in
 	let c2 = Int64.of_int c2 in
@@ -651,7 +671,7 @@ let extract_int64_le_unsigned data off len flen =
 	_make_int64_le c0 c1 c2 c3 c4 c5 c6 c7 in
       Int64.logand word (I64.mask flen)
     ) in
-  word, off+flen, len-flen
+  word (*, off+flen, len-flen*)
 
 let extract_int64_ne_unsigned =
   if nativeendian = BigEndian
@@ -882,7 +902,8 @@ let construct_bitstring buf (data, off, len) =
   let rec loop off len blen =
     if blen = 0 then (off, len)
     else (
-      let b, off, len = extract_bit data off len 1 in
+      let b = extract_bit data off len 1
+      and off = off + 1 and len = len + 1 in
       Buffer.add_bit buf b;
       loop off len (blen-1)
     )
@@ -912,11 +933,12 @@ let string_of_bitstring (data, off, len) =
     let str = String.make strlen '\000' in
     let rec loop data off len i =
       if len >= 8 then (
-	let c, off, len = extract_char_unsigned data off len 8 in
+	let c = extract_char_unsigned data off len 8
+	and off = off + 8 and len = len - 8 in
 	str.[i] <- Char.chr c;
 	loop data off len (i+1)
       ) else if len > 0 then (
-	let c, _, _ = extract_char_unsigned data off len len in
+	let c = extract_char_unsigned data off len len in
 	str.[i] <- Char.chr (c lsl (8-len))
       )
     in
@@ -966,8 +988,8 @@ let hexdump_bitstring chan (data, off, len) =
 
   while !len > 0 do
     let bits = min !len 8 in
-    let byte, off', len' = extract_char_unsigned data !off !len bits in
-    off := off'; len := len';
+    let byte = extract_char_unsigned data !off !len bits in
+    off := !off + bits; len := !len - bits;
 
     let byte = byte lsl (8-bits) in
     fprintf chan "%02x " byte;
diff --git a/bitstring.mli b/bitstring.mli
index 6c35da8..0b77cce 100644
--- a/bitstring.mli
+++ b/bitstring.mli
@@ -870,38 +870,41 @@ val debug : bool ref
  * these directly - they are not safe.
  *)
 
-val extract_bitstring : string -> int -> int -> int -> bitstring * int * int
+(* 'extract' functions are used in bitmatch statements. *)
 
-val extract_remainder : string -> int -> int -> bitstring * int * int
+val extract_bitstring : string -> int -> int -> int -> bitstring
 
-val extract_bit : string -> int -> int -> int -> bool * int * int
+val extract_remainder : string -> int -> int -> bitstring
 
-val extract_char_unsigned : string -> int -> int -> int -> int * int * int
+val extract_bit : string -> int -> int -> int -> bool
 
-val extract_int_be_unsigned : string -> int -> int -> int -> int * int * int
+val extract_char_unsigned : string -> int -> int -> int -> int
 
-val extract_int_le_unsigned : string -> int -> int -> int -> int * int * int
+val extract_int_be_unsigned : string -> int -> int -> int -> int
 
-val extract_int_ne_unsigned : string -> int -> int -> int -> int * int * int
+val extract_int_le_unsigned : string -> int -> int -> int -> int
 
-val extract_int_ee_unsigned : endian -> string -> int -> int -> int -> int * int * int
+val extract_int_ne_unsigned : string -> int -> int -> int -> int
 
-val extract_int32_be_unsigned : string -> int -> int -> int -> int32 * int * int
+val extract_int_ee_unsigned : endian -> string -> int -> int -> int -> int
 
-val extract_int32_le_unsigned : string -> int -> int -> int -> int32 * int * int
+val extract_int32_be_unsigned : string -> int -> int -> int -> int32
 
-val extract_int32_ne_unsigned : string -> int -> int -> int -> int32 * int * int
+val extract_int32_le_unsigned : string -> int -> int -> int -> int32
 
-val extract_int32_ee_unsigned : endian -> string -> int -> int -> int -> int32 * int * int
+val extract_int32_ne_unsigned : string -> int -> int -> int -> int32
 
-val extract_int64_be_unsigned : string -> int -> int -> int -> int64 * int * int
+val extract_int32_ee_unsigned : endian -> string -> int -> int -> int -> int32
 
-val extract_int64_le_unsigned : string -> int -> int -> int -> int64 * int * int
+val extract_int64_be_unsigned : string -> int -> int -> int -> int64
 
-val extract_int64_ne_unsigned : string -> int -> int -> int -> int64 * int * int
+val extract_int64_le_unsigned : string -> int -> int -> int -> int64
 
-val extract_int64_ee_unsigned : endian -> string -> int -> int -> int -> int64 * int * int
+val extract_int64_ne_unsigned : string -> int -> int -> int -> int64
 
+val extract_int64_ee_unsigned : endian -> string -> int -> int -> int -> int64
+
+(* 'construct' functions are used in BITSTRING constructors. *)
 val construct_bit : Buffer.t -> bool -> int -> exn -> unit
 
 val construct_char_unsigned : Buffer.t -> int -> int -> exn -> unit
diff --git a/pa_bitstring.ml b/pa_bitstring.ml
index 63c280e..5e5582c 100644
--- a/pa_bitstring.ml
+++ b/pa_bitstring.ml
@@ -180,22 +180,31 @@ let parse_field _loc field qs =
 
   field
 
+type functype = ExtractFunc | ConstructFunc
+
 (* Choose the right constructor function. *)
-let build_bitstring_call _loc funcname length endian signed =
-  match length, endian, signed with
+let build_bitstring_call _loc functype length endian signed =
+  match functype, length, endian, signed with
     (* XXX The meaning of signed/unsigned breaks down at
      * 31, 32, 63 and 64 bits.
      *)
-  | (Some 1, _, _) -> <:expr< Bitstring.$lid:funcname ^ "_bit"$ >>
-  | (Some (2|3|4|5|6|7|8), _, sign) ->
-      let call = Printf.sprintf "%s_char_%s"
-        funcname (if sign then "signed" else "unsigned") in
+  | (ExtractFunc, Some 1, _, _) -> <:expr< Bitstring.extract_bit >>
+  | (ConstructFunc, Some 1, _, _) -> <:expr< Bitstring.construct_bit >>
+  | (functype, Some (2|3|4|5|6|7|8), _, signed) ->
+      let funcname = match functype with
+	| ExtractFunc -> "extract"
+	| ConstructFunc -> "construct" in
+      let sign = if signed then "signed" else "unsigned" in
+      let call = sprintf "%s_char_%s" funcname sign in
       <:expr< Bitstring.$lid:call$ >>
-  | (len, endian, signed) ->
+  | (functype, len, endian, signed) ->
+      let funcname = match functype with
+	| ExtractFunc -> "extract"
+	| ConstructFunc -> "construct" in
       let t = match len with
-      | Some i when i <= 31 -> "int"
-      | Some 32 -> "int32"
-      | _ -> "int64" in
+	| Some i when i <= 31 -> "int"
+	| Some 32 -> "int32"
+	| _ -> "int64" in
       let sign = if signed then "signed" else "unsigned" in
       match endian with
       | P.ConstantEndian constant ->
@@ -203,12 +212,10 @@ let build_bitstring_call _loc funcname length endian signed =
           | BigEndian -> "be"
           | LittleEndian -> "le"
           | NativeEndian -> "ne" in
-          let call = Printf.sprintf "%s_%s_%s_%s"
-            funcname t endianness sign in
+          let call = sprintf "%s_%s_%s_%s" funcname t endianness sign in
           <:expr< Bitstring.$lid:call$ >>
       | P.EndianExpr expr ->
-          let call = Printf.sprintf "%s_%s_%s_%s"
-            funcname t "ee" sign in
+          let call = sprintf "%s_%s_%s_%s" funcname t "ee" sign in
           <:expr< Bitstring.$lid:call$ $expr$ >>
 
 (* Generate the code for a constructor, ie. 'BITSTRING ...'. *)
@@ -278,9 +285,9 @@ let output_constructor _loc fields =
       let flen_is_const = expr_is_constant flen in
 
       let int_construct_const (i, endian, signed) =
-        build_bitstring_call _loc "construct" (Some i) endian signed in
+        build_bitstring_call _loc ConstructFunc (Some i) endian signed in
       let int_construct (endian, signed) =
-	build_bitstring_call _loc "construct" None endian signed in
+	build_bitstring_call _loc ConstructFunc None endian signed in
 
       let expr =
 	match t, flen_is_const with
@@ -444,20 +451,25 @@ let output_bitmatch _loc bs cases =
    * current position within the bitstring:
    *
    *   data - original bitstring data (string, never changes)
-   *
    *   off  - current offset within data (int, increments as we move through
    *            the bitstring)
    *   len  - current remaining length within data (int, decrements as
    *            we move through the bitstring)
    *
+   * Also:
+   *
    *   original_off - saved offset at the start of the match (never changes)
    *   original_len - saved length at the start of the match (never changes)
+   *   off_aligned  - true if the original offset is byte-aligned (allows
+   *            us to make some common optimizations)
    *)
   let data = gensym "data"
   and off = gensym "off"
   and len = gensym "len"
   and original_off = gensym "original_off"
   and original_len = gensym "original_len"
+  and off_aligned = gensym "off_aligned"
+
   (* This is where the result will be stored (a reference). *)
   and result = gensym "result" in
 
@@ -511,52 +523,175 @@ let output_bitmatch _loc bs cases =
 	  | Some check_expr ->
 	      <:expr< if $check_expr$ then $expr$ >> in
 
-	(* Now build the code which matches a field. *)
-	let int_extract_const (i, endian, signed) =
-          build_bitstring_call _loc "extract" (Some i) endian signed in
-	let int_extract (endian, signed) =
-	  build_bitstring_call _loc "extract" None endian signed in
+	(* Compute the offset of this field within the match, if it
+	 * can be known at compile time.
+	 *
+	 * Actually, we'll compute two things: the 'natural_field_offset'
+	 * is the offset assuming this field had no offset() qualifier
+	 * (in other words, its position, immediately following the
+	 * preceding field).  'field_offset' is the real field offset
+	 * taking into account any offset() qualifier.
+	 *
+	 * This will be [Some i] if our current offset is known
+	 * at compile time, or [None] if we can't determine it.
+	 *)
+	let natural_field_offset, field_offset =
+	  let has_constant_offset field =
+	    match P.get_offset field with
+	    | None -> false
+	    | Some expr ->
+		match expr_is_constant expr with
+		| None -> false
+		| Some i -> true
+	  in
+	  let get_constant_offset field =
+	    match P.get_offset field with
+	    | None -> assert false
+	    | Some expr ->
+		match expr_is_constant expr with
+		| None -> assert false
+		| Some i -> i
+	  in
+
+	  let has_constant_len field =
+	    match expr_is_constant (P.get_length field) with
+	    | None -> false
+	    | Some i when i > 0 -> true
+	    | Some _ -> false
+	  in
+	  let get_constant_len field =
+	    match expr_is_constant (P.get_length field) with
+	    | None -> assert false
+	    | Some i when i > 0 -> i
+	    | Some _ -> assert false
+	  in
+
+	  (* NB: We are looping over the PRECEDING fields in reverse order. *)
+	  let rec loop = function
+	    (* first field has constant offset 0 *)
+	    | [] -> Some 0
+	    (* preceding field with constant offset & length *)
+	    | f :: _
+		when has_constant_offset f && has_constant_len f ->
+		Some (get_constant_offset f + get_constant_len f)
+	    (* preceding field with no offset & constant length *)
+	    | f :: fs
+		when P.get_offset f = None && has_constant_len f ->
+		(match loop fs with
+		 | None -> None
+		 | Some offset -> Some (offset + get_constant_len f))
+	    (* else, can't work out the offset *)
+	    | _ -> None
+	  in
+
+	  let natural_field_offset = loop fields in
+
+	  let field_offset =
+	    match P.get_offset field with
+	    | None -> natural_field_offset
+	    | Some expr -> (* has an offset() clause *)
+		match expr_is_constant expr with
+		| None -> None
+		| i -> i in
+
+	  natural_field_offset, field_offset in
+
+	(* Also compute if the field_offset is known to be byte-aligned at
+	 * compile time, which is usually both the common and best possible
+	 * case for generating optimized code.
+	 *
+	 * This is None if not aligned / don't know.
+	 * Or Some byte_offset if we can work it out.
+	 *)
+	let field_offset_aligned =
+	  match field_offset with
+	  | None -> None		(* unknown, assume no *)
+	  | Some off when off land 7 = 0 -> Some (off lsr 3)
+	  | Some _ -> None in		(* definitely no *)
+
+	(* Now build the code which matches a single field. *)
+	let int_extract_const i endian signed =
+          build_bitstring_call _loc ExtractFunc (Some i) endian signed in
+	let int_extract endian signed =
+	  build_bitstring_call _loc ExtractFunc None endian signed in
 
 	let expr =
-	  match t, flen_is_const with
+	  match t, flen_is_const, field_offset_aligned with
+	  (* Very common cases: int field, constant 8/16/32/64 bit length,
+	   * aligned to the match at a known offset.  We still have to
+	   * check if the bitstring is aligned (can only be known at
+	   * runtime) but we may be able to directly access the
+	   * bytes in the string.
+	   *)
+	  | P.Int, Some ((8(*|16|32|64*)) as i), Some field_byte_offset ->
+	      let extract_fn = int_extract_const i endian signed in
+	      let o = gensym "off" and v = gensym "val" in
+
+	      (* The fast-path code when everything is aligned. *)
+	      let fastpath =
+		<:expr<
+		  let $lid:o$ = ($lid:original_off$ lsr 3) +
+		    $`int:field_byte_offset$ in
+		  Char.code (String.unsafe_get $lid:data$ $lid:o$)
+	        >> in
+
+	      <:expr<
+		if $lid:len$ >= $`int:i$ then (
+		  let $lid:v$ =
+		    if $lid:off_aligned$ then
+		      $fastpath$
+		    else
+		      $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
+		  let $lid:off$ = $lid:off$ + $`int:i$
+		  and $lid:len$ = $lid:len$ - $`int:i$ in
+		  match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> ()
+		)
+	      >>
+
 	  (* Common case: int field, constant flen *)
-	  | P.Int, Some i when i > 0 && i <= 64 ->
-	      let extract_fn = int_extract_const (i,endian,signed) in
+	  | P.Int, Some i, _ when i > 0 && i <= 64 ->
+	      let extract_fn = int_extract_const i endian signed in
 	      let v = gensym "val" in
 	      <:expr<
 		if $lid:len$ >= $`int:i$ then (
-		  let $lid:v$, $lid:off$, $lid:len$ =
+		  let $lid:v$ =
 		    $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $`int:i$ in
+		  let $lid:off$ = $lid:off$ + $`int:i$
+		  and $lid:len$ = $lid:len$ - $`int:i$ in
 		  match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> ()
 		)
 	      >>
 
-	  | P.Int, Some _ ->
+	  | P.Int, Some _, _ ->
 	      fail "length of int field must be [1..64]"
 
 	  (* Int field, non-const flen.  We have to test the range of
 	   * the field at runtime.  If outside the range it's a no-match
 	   * (not an error).
 	   *)
-	  | P.Int, None ->
-	      let extract_fn = int_extract (endian,signed) in
+	  | P.Int, None, _ ->
+	      let extract_fn = int_extract endian signed in
 	      let v = gensym "val" in
 	      <:expr<
 		if $flen$ >= 1 && $flen$ <= 64 && $flen$ <= $lid:len$ then (
-		  let $lid:v$, $lid:off$, $lid:len$ =
+		  let $lid:v$ =
 		    $extract_fn$ $lid:data$ $lid:off$ $lid:len$ $flen$ in
+		  let $lid:off$ = $lid:off$ + $flen$
+		  and $lid:len$ = $lid:len$ - $flen$ in
 		  match $lid:v$ with $fpatt$ when true -> $expr$ | _ -> ()
 		)
 	      >>
 
           (* String, constant flen > 0. *)
-	  | P.String, Some i when i > 0 && i land 7 = 0 ->
+	  | P.String, Some i, _ when i > 0 && i land 7 = 0 ->
 	      let bs = gensym "bs" in
 	      <:expr<
 		if $lid:len$ >= $`int:i$ then (
-		  let $lid:bs$, $lid:off$, $lid:len$ =
+		  let $lid:bs$ =
 		    Bitstring.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 		      $`int:i$ in
+		  let $lid:off$ = $lid:off$ + $`int:i$
+		  and $lid:len$ = $lid:len$ - $`int:i$ in
 		  match Bitstring.string_of_bitstring $lid:bs$ with
 		  | $fpatt$ when true -> $expr$
 		  | _ -> ()
@@ -566,30 +701,34 @@ let output_bitmatch _loc bs cases =
           (* String, constant flen = -1, means consume all the
 	   * rest of the input.
 	   *)
-	  | P.String, Some i when i = -1 ->
+	  | P.String, Some i, _ when i = -1 ->
 	      let bs = gensym "bs" in
 	      <:expr<
-		let $lid:bs$, $lid:off$, $lid:len$ =
+		let $lid:bs$ =
 		  Bitstring.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
+		let $lid:off$ = $lid:off$ + $lid:len$ in
+		let $lid:len$ = 0 in
 		match Bitstring.string_of_bitstring $lid:bs$ with
 		| $fpatt$ when true -> $expr$
 		| _ -> ()
 	      >>
 
-	  | P.String, Some _ ->
+	  | P.String, Some _, _ ->
 	      fail "length of string must be > 0 and a multiple of 8, or the special value -1"
 
 	  (* String field, non-const flen.  We check the flen is > 0
 	   * and a multiple of 8 (-1 is not allowed here), at runtime.
 	   *)
-	  | P.String, None ->
+	  | P.String, None, _ ->
 	      let bs = gensym "bs" in
 	      <:expr<
 		if $flen$ >= 0 && $flen$ <= $lid:len$
 		  && $flen$ land 7 = 0 then (
-		    let $lid:bs$, $lid:off$, $lid:len$ =
+		    let $lid:bs$ =
 		      Bitstring.extract_bitstring
 			$lid:data$ $lid:off$ $lid:len$ $flen$ in
+		    let $lid:off$ = $lid:off$ + $flen$
+		    and $lid:len$ = $lid:len$ - $flen$ in
 		    match Bitstring.string_of_bitstring $lid:bs$ with
 		    | $fpatt$ when true -> $expr$
 		    | _ -> ()
@@ -600,7 +739,7 @@ let output_bitmatch _loc bs cases =
 	   * At the moment all we can do is assign the bitstring to an
 	   * identifier.
 	   *)
-	  | P.Bitstring, Some i when i >= 0 ->
+	  | P.Bitstring, Some i, _ when i >= 0 ->
 	      let ident =
 		match fpatt with
 		| <:patt< $lid:ident$ >> -> ident
@@ -609,9 +748,11 @@ let output_bitmatch _loc bs cases =
 		    fail "cannot compare a bitstring to a constant" in
 	      <:expr<
 		if $lid:len$ >= $`int:i$ then (
-		  let $lid:ident$, $lid:off$, $lid:len$ =
+		  let $lid:ident$ =
 		    Bitstring.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 		      $`int:i$ in
+		  let $lid:off$ = $lid:off$ + $`int:i$
+		  and $lid:len$ = $lid:len$ - $`int:i$ in
 		  $expr$
 		)
 	      >>
@@ -619,7 +760,7 @@ let output_bitmatch _loc bs cases =
           (* Bitstring, constant flen = -1, means consume all the
 	   * rest of the input.
 	   *)
-	  | P.Bitstring, Some i when i = -1 ->
+	  | P.Bitstring, Some i, _ when i = -1 ->
 	      let ident =
 		match fpatt with
 		| <:patt< $lid:ident$ >> -> ident
@@ -627,18 +768,20 @@ let output_bitmatch _loc bs cases =
 		| _ ->
 		    fail "cannot compare a bitstring to a constant" in
 	      <:expr<
-		let $lid:ident$, $lid:off$, $lid:len$ =
+		let $lid:ident$ =
 		  Bitstring.extract_remainder $lid:data$ $lid:off$ $lid:len$ in
+		let $lid:off$ = $lid:off$ + $lid:len$ in
+		let $lid:len$ = 0 in
 		  $expr$
 	      >>
 
-	  | P.Bitstring, Some _ ->
+	  | P.Bitstring, Some _, _ ->
 	      fail "length of bitstring must be >= 0 or the special value -1"
 
 	  (* Bitstring field, non-const flen.  We check the flen is >= 0
 	   * (-1 is not allowed here) at runtime.
 	   *)
-	  | P.Bitstring, None ->
+	  | P.Bitstring, None, _ ->
 	      let ident =
 		match fpatt with
 		| <:patt< $lid:ident$ >> -> ident
@@ -647,9 +790,11 @@ let output_bitmatch _loc bs cases =
 		    fail "cannot compare a bitstring to a constant" in
 	      <:expr<
 		if $flen$ >= 0 && $flen$ <= $lid:len$ then (
-		  let $lid:ident$, $lid:off$, $lid:len$ =
+		  let $lid:ident$ =
 		    Bitstring.extract_bitstring $lid:data$ $lid:off$ $lid:len$
 		      $flen$ in
+		  let $lid:off$ = $lid:off$ + $flen$
+		  and $lid:len$ = $lid:len$ - $flen$ in
 		  $expr$
 		)
 	      >>
@@ -676,72 +821,18 @@ let output_bitmatch _loc bs cases =
 	       *)
 	      let requested_offset = expr_is_constant offset_expr in
 
-	      (* This will be [Some i] if our current offset is known
-	       * at compile time, or [None] if we can't determine it.
-	       *)
-	      let current_offset =
-		let has_constant_offset field =
-		  match P.get_offset field with
-		  | None -> false
-		  | Some expr ->
-		      match expr_is_constant expr with
-		      | None -> false
-		      | Some i -> true
-		in
-		let get_constant_offset field =
-		  match P.get_offset field with
-		  | None -> assert false
-		  | Some expr ->
-		      match expr_is_constant expr with
-		      | None -> assert false
-		      | Some i -> i
-		in
-
-		let has_constant_len field =
-		  match expr_is_constant (P.get_length field) with
-		  | None -> false
-		  | Some i when i > 0 -> true
-		  | Some _ -> false
-		in
-		let get_constant_len field =
-		  match expr_is_constant (P.get_length field) with
-		  | None -> assert false
-		  | Some i when i > 0 -> i
-		  | Some _ -> assert false
-		in
-
-		let rec loop = function
-		  (* first field has constant offset 0 *)
-		  | [] -> Some 0
-		  (* field with constant offset & length *)
-		  | field :: _
-		      when has_constant_offset field &&
-			has_constant_len field ->
-		      Some (get_constant_offset field + get_constant_len field)
-		  (* field with no offset & constant length *)
-		  | field :: fields
-		      when P.get_offset field = None &&
-			has_constant_len field ->
-		      (match loop fields with
-		       | None -> None
-		       | Some offset -> Some (offset + get_constant_len field))
-		  (* else, can't work out the offset *)
-		  | _ -> None
-		in
-		loop fields in
-
-              (* Look at the current offset and requested offset cases and
-	       * determine what code to generate.
+              (* Look at the field offset (if known) and requested offset
+	       * cases and determine what code to generate.
 	       *)
-	      match current_offset, requested_offset with
-		(* This is the good case: both the current offset and
+	      match natural_field_offset, requested_offset with
+		(* This is the good case: both the field offset and
 		 * the requested offset are constant, so we can remove
 		 * almost all the runtime checks.
 		 *)
-	      | Some current_offset, Some requested_offset ->
-		  let move = requested_offset - current_offset in
+	      | Some natural_field_offset, Some requested_offset ->
+		  let move = requested_offset - natural_field_offset in
 		  if move < 0 then
-		    fail (sprintf "requested offset is less than the current offset (%d < %d)" requested_offset current_offset);
+		    fail (sprintf "requested offset is less than the field offset (%d < %d)" requested_offset natural_field_offset);
 		  (* Add some code to move the offset and length by a
 		   * constant amount, and a runtime test that len >= 0
 		   * (XXX possibly the runtime test is unnecessary?)
@@ -848,9 +939,13 @@ let output_bitmatch _loc bs cases =
   <:expr<
     (* Note we save the original offset/length at the start of the match
      * in 'original_off'/'original_len' symbols.  'data' never changes.
+     * This code also ensures that if original_off/original_len/off_aligned
+     * aren't actually used, we don't get a warning.
      *)
     let ($lid:data$, $lid:original_off$, $lid:original_len$) = $bs$ in
     let $lid:off$ = $lid:original_off$ and $lid:len$ = $lid:original_len$ in
+    let $lid:off_aligned$ = $lid:off$ land 7 = 0 in
+    ignore $lid:off_aligned$;
     let $lid:result$ = ref None in
     (try
       $cases$
-- 
1.8.3.1