- (* A map from kernel versions to follower functions.
- *
- * For each struct, we have a list of kernel versions which contain
- * that struct. Some kernels are missing a particular struct, so
- * that is turned into a ParseError exception.
- *)
- let strs =
- let nr_kernels =
- List.fold_left max 0
- (List.map (fun (_, (kernels, _, _, _)) -> List.length kernels) xs) in
- let nr_structs = List.length xs in
- let array = Array.make_matrix nr_kernels (nr_structs+1) (Missing "") in
- List.iteri (
- fun si (struct_name, _) ->
- for i = 0 to nr_kernels - 1 do
- array.(i).(si+1) <- Missing struct_name
- done
- ) xs;
- List.iteri (
- fun si (struct_name, (kernels, _, _, _)) ->
- List.iter (
- fun ({ PP.kernel_version = version; kv_i = kv_i }, _) ->
- array.(kv_i).(0) <- KernelVersion version;
- array.(kv_i).(si+1) <-
- Follower (sprintf "%s_kv%d_follower" struct_name kv_i)
- ) kernels
- ) xs;
-
- let array = Array.map (
- fun row ->
- match Array.to_list row with
- | [] | (Missing _|Follower _) :: _ -> assert false
- | KernelVersion kernel_version :: followers -> kernel_version, followers
- ) array in
-
- let map = List.fold_left (
- fun map (kernel_version, followers) ->
- let followers = List.map (
- function
- | Follower fname ->
- <:expr< $lid:fname$ >>
-
- (* no follower for this kernel/struct combination *)
- | Missing struct_name ->
+let generate_followers names xs =
+ (* A follower function for every structure. *)
+ let bindings = List.map (
+ fun (struct_name, all_fields) ->
+ let followers = List.fold_right (
+ fun (name, (typ, always_available)) rest ->
+ let is_shape_field =
+ match typ with
+ | PP.FListHeadPointer None -> true
+ | PP.FListHeadPointer (Some (struct_name, _))
+ | PP.FStructPointer struct_name
+ when List.mem struct_name names -> true
+ | _ -> false in
+ if not is_shape_field then rest
+ else (
+ let dest_struct_name =
+ match typ with
+ | PP.FListHeadPointer None -> struct_name
+ | PP.FListHeadPointer (Some (struct_name, _)) -> struct_name
+ | PP.FStructPointer struct_name -> struct_name
+ | _ -> assert false in
+
+ let body =
+ match typ with
+ | PP.FListHeadPointer _ ->
+ <:expr<
+ (* For list head pointers, add the address of the base
+ * of this virtual structure to the map, then adjust
+ * the pointer.
+ *)
+ let offset = data.$lid:struct_name^"_"^name^"_offset"$
+ and adj = data.$lid:struct_name^"_"^name^"_adjustment"$ in
+ let offset = Int64.of_int offset
+ and adj = Int64.of_int adj in
+
+ (* 'addr' is base of the virtual struct, but when
+ * adding it to the map make sure we don't splat
+ * the real structure (can happen if offset=adj).
+ *)
+ let map =
+ if offset <> adj then (
+ let addr = Int64.sub (Int64.add addr offset) adj in
+ AddrMap.add addr ($str:dest_struct_name$, None) map
+ ) else map in
+
+ (* 'dest_addr' is the destination address of
+ * this pointer. It needs the usual list_head
+ * adjustment applied.
+ *)
+ let dest_addr = Int64.sub dest_addr adj in
+ let map =
+ $lid:dest_struct_name^"_follower"$
+ kernel_version load map dest_addr in
+ map
+ >>
+
+ | PP.FStructPointer _ ->
+ <:expr<
+ let map =
+ $lid:dest_struct_name^"_follower"$
+ kernel_version load map dest_addr in
+ map
+ >>
+
+ | _ -> assert false in
+
+ if always_available then