CCSDS TM Transfer Frames (CCSDS 132.0-B-3)
feat(wire): add bitfield support to Wire.Codec and converting fields
Add bitfield auto-grouping to the GADT record codec so protocol headers
can be defined declaratively with named fields instead of manual bit
manipulation. Consecutive same-base bitfield types are packed into shared
base words automatically.
Also adds Wire.bit/is_set helpers for bool<->int conversion, and a
cfield combinator for typed conversions (e.g., enums) in codec fields.
Rewrites CLCW, Space Packet, and TM packed types from opaque words to
named semantic field records using the new bitfield codec.
Gates EverParse differential tests behind BUILD_EVERPARSE=1 env var
so that `dune build` never triggers the slow EverParse toolchain.
+124
-97
+5
-5
bench/bench_tm.ml
+5
-5
bench/bench_tm.ml
···
39
39
test_headers_str
40
40
41
41
let test_wire_headers =
42
-
Array.map (fun b -> Tm.Packed_header.decode_exn b 0) test_headers
42
+
Array.map (fun b -> Tm.decode_packed_header b 0) test_headers
43
43
44
44
(** {1 Original Tm (string-based)} *)
45
45
···
68
68
69
69
let wire_decode () =
70
70
for i = 0 to Array.length test_headers - 1 do
71
-
let _ = Tm.Packed_header.decode_exn test_headers.(i) 0 in
71
+
let _ = Tm.decode_packed_header test_headers.(i) 0 in
72
72
()
73
73
done
74
74
75
75
let wire_encode () =
76
76
for i = 0 to Array.length test_wire_headers - 1 do
77
77
let buf = Bytes.create 6 in
78
-
Tm.Packed_header.encode test_wire_headers.(i) buf 0;
78
+
Tm.encode_packed_header test_wire_headers.(i) buf 0;
79
79
let _ = buf in
80
80
()
81
81
done
82
82
83
83
let wire_roundtrip () =
84
84
for i = 0 to Array.length test_headers - 1 do
85
-
let t = Tm.Packed_header.decode_exn test_headers.(i) 0 in
85
+
let t = Tm.decode_packed_header test_headers.(i) 0 in
86
86
let buf = Bytes.create 6 in
87
-
Tm.Packed_header.encode t buf 0;
87
+
Tm.encode_packed_header t buf 0;
88
88
let _ = buf in
89
89
()
90
90
done
+99
-61
lib/tm.ml
+99
-61
lib/tm.ml
···
420
420
421
421
(* {1 Packed Header Wire Representation} *)
422
422
423
-
type packed_header = { w0 : int; w1 : int; w2 : int }
424
-
425
-
module Packed_header = struct
426
-
type t = packed_header = { w0 : int; w1 : int; w2 : int }
427
-
428
-
let equal a b = a.w0 = b.w0 && a.w1 = b.w1 && a.w2 = b.w2
423
+
type packed_header = {
424
+
version : int;
425
+
scid : int;
426
+
vcid : int;
427
+
ocf_flag : int;
428
+
mcfc : int;
429
+
vcfc : int;
430
+
sec_hdr : int;
431
+
sync_flag : int;
432
+
pkt_order : int;
433
+
seg_len_id : int;
434
+
first_hdr_ptr : int;
435
+
}
429
436
430
-
(* Field Accessors *)
431
-
let version t = (t.w0 lsr 14) land 0x3
432
-
let scid t = (t.w0 lsr 4) land 0x3FF
433
-
let vcid t = (t.w0 lsr 1) land 0x7
434
-
let ocf_flag t = t.w0 land 0x1 = 1
435
-
let mcfc t = (t.w1 lsr 8) land 0xFF
436
-
let vcfc t = t.w1 land 0xFF
437
-
let sec_hdr t = (t.w2 lsr 15) land 0x1 = 1
438
-
let sync_flag t = (t.w2 lsr 14) land 0x1 = 1
439
-
let pkt_order t = (t.w2 lsr 13) land 0x1 = 1
440
-
let seg_len_id t = (t.w2 lsr 11) land 0x3
441
-
let first_hdr_ptr t = t.w2 land 0x7FF
437
+
let equal_packed_header a b =
438
+
a.version = b.version && a.scid = b.scid && a.vcid = b.vcid
439
+
&& a.ocf_flag = b.ocf_flag && a.mcfc = b.mcfc && a.vcfc = b.vcfc
440
+
&& a.sec_hdr = b.sec_hdr && a.sync_flag = b.sync_flag
441
+
&& a.pkt_order = b.pkt_order
442
+
&& a.seg_len_id = b.seg_len_id
443
+
&& a.first_hdr_ptr = b.first_hdr_ptr
442
444
443
-
(* Wire Codec *)
444
-
let codec =
445
-
let open Wire.Codec in
446
-
record "TmHeader" (fun w0 w1 w2 -> { w0; w1; w2 })
447
-
|+ field "w0" Wire.uint16be (fun t -> t.w0)
448
-
|+ field "w1" Wire.uint16be (fun t -> t.w1)
449
-
|+ field "w2" Wire.uint16be (fun t -> t.w2)
450
-
|> seal
445
+
(* Wire Codec *)
446
+
let codec =
447
+
let open Wire.Codec in
448
+
record "TmHeader"
449
+
(fun
450
+
version
451
+
scid
452
+
vcid
453
+
ocf_flag
454
+
mcfc
455
+
vcfc
456
+
sec_hdr
457
+
sync_flag
458
+
pkt_order
459
+
seg_len_id
460
+
first_hdr_ptr
461
+
->
462
+
{
463
+
version;
464
+
scid;
465
+
vcid;
466
+
ocf_flag;
467
+
mcfc;
468
+
vcfc;
469
+
sec_hdr;
470
+
sync_flag;
471
+
pkt_order;
472
+
seg_len_id;
473
+
first_hdr_ptr;
474
+
})
475
+
|+ field "version" (Wire.bits ~width:2 Wire.bf_uint16be) (fun t -> t.version)
476
+
|+ field "scid" (Wire.bits ~width:10 Wire.bf_uint16be) (fun t -> t.scid)
477
+
|+ field "vcid" (Wire.bits ~width:3 Wire.bf_uint16be) (fun t -> t.vcid)
478
+
|+ field "ocf_flag" (Wire.bits ~width:1 Wire.bf_uint16be) (fun t ->
479
+
t.ocf_flag)
480
+
|+ field "mcfc" (Wire.bits ~width:8 Wire.bf_uint16be) (fun t -> t.mcfc)
481
+
|+ field "vcfc" (Wire.bits ~width:8 Wire.bf_uint16be) (fun t -> t.vcfc)
482
+
|+ field "sec_hdr" (Wire.bits ~width:1 Wire.bf_uint16be) (fun t -> t.sec_hdr)
483
+
|+ field "sync_flag" (Wire.bits ~width:1 Wire.bf_uint16be) (fun t ->
484
+
t.sync_flag)
485
+
|+ field "pkt_order" (Wire.bits ~width:1 Wire.bf_uint16be) (fun t ->
486
+
t.pkt_order)
487
+
|+ field "seg_len_id" (Wire.bits ~width:2 Wire.bf_uint16be) (fun t ->
488
+
t.seg_len_id)
489
+
|+ field "first_hdr_ptr" (Wire.bits ~width:11 Wire.bf_uint16be) (fun t ->
490
+
t.first_hdr_ptr)
491
+
|> seal
451
492
452
-
let struct_ = Wire.Codec.to_struct codec
493
+
let struct_ = Wire.Codec.to_struct codec
453
494
454
-
let module_ =
455
-
Wire.module_ ~doc:"CCSDS TM Transfer Frame Primary Header (132.0-B-3)"
456
-
"TmHeader"
457
-
[ Wire.typedef ~entrypoint:true struct_ ]
495
+
let module_ =
496
+
Wire.module_ ~doc:"CCSDS TM Transfer Frame Primary Header (132.0-B-3)"
497
+
"TmHeader"
498
+
[ Wire.typedef ~entrypoint:true struct_ ]
458
499
459
-
(* Parse/Encode *)
460
-
let decode_exn = Wire.Codec.decode codec
461
-
let encode = Wire.Codec.encode codec
462
-
end
500
+
(* Wire Parse/Encode *)
501
+
let decode_packed_header = Wire.Codec.decode codec
502
+
let encode_packed_header = Wire.Codec.encode codec
463
503
464
504
let to_packed_header (h : header) : packed_header =
465
-
let w0 =
466
-
((h.version land 0x3) lsl 14)
467
-
lor ((scid_to_int h.scid land 0x3FF) lsl 4)
468
-
lor ((vcid_to_int h.vcid land 0x7) lsl 1)
469
-
lor if h.ocf_flag then 1 else 0
470
-
in
471
-
let w1 = ((h.mcfc land 0xFF) lsl 8) lor (h.vcfc land 0xFF) in
472
-
let w2 =
473
-
((if h.sec_hdr then 1 else 0) lsl 15)
474
-
lor ((if h.sync_flag then 1 else 0) lsl 14)
475
-
lor ((if h.pkt_order then 1 else 0) lsl 13)
476
-
lor ((h.seg_len_id land 0x3) lsl 11)
477
-
lor (h.first_hdr_ptr land 0x7FF)
478
-
in
479
-
{ w0; w1; w2 }
505
+
{
506
+
version = h.version;
507
+
scid = scid_to_int h.scid;
508
+
vcid = vcid_to_int h.vcid;
509
+
ocf_flag = Wire.bit h.ocf_flag;
510
+
mcfc = h.mcfc;
511
+
vcfc = h.vcfc;
512
+
sec_hdr = Wire.bit h.sec_hdr;
513
+
sync_flag = Wire.bit h.sync_flag;
514
+
pkt_order = Wire.bit h.pkt_order;
515
+
seg_len_id = h.seg_len_id;
516
+
first_hdr_ptr = h.first_hdr_ptr;
517
+
}
480
518
481
519
let of_packed_header (t : packed_header) :
482
520
(header, [ `Invalid_scid | `Invalid_vcid ]) result =
483
-
match scid (Packed_header.scid t) with
521
+
match scid t.scid with
484
522
| None -> Error `Invalid_scid
485
523
| Some scid_val -> (
486
-
match vcid (Packed_header.vcid t) with
524
+
match vcid t.vcid with
487
525
| None -> Error `Invalid_vcid
488
526
| Some vcid_val ->
489
527
Ok
490
528
{
491
-
version = Packed_header.version t;
529
+
version = t.version;
492
530
scid = scid_val;
493
531
vcid = vcid_val;
494
-
ocf_flag = Packed_header.ocf_flag t;
495
-
mcfc = Packed_header.mcfc t;
496
-
vcfc = Packed_header.vcfc t;
497
-
sec_hdr = Packed_header.sec_hdr t;
498
-
sync_flag = Packed_header.sync_flag t;
499
-
pkt_order = Packed_header.pkt_order t;
500
-
seg_len_id = Packed_header.seg_len_id t;
501
-
first_hdr_ptr = Packed_header.first_hdr_ptr t;
532
+
ocf_flag = Wire.is_set t.ocf_flag;
533
+
mcfc = t.mcfc;
534
+
vcfc = t.vcfc;
535
+
sec_hdr = Wire.is_set t.sec_hdr;
536
+
sync_flag = Wire.is_set t.sync_flag;
537
+
pkt_order = Wire.is_set t.pkt_order;
538
+
seg_len_id = t.seg_len_id;
539
+
first_hdr_ptr = t.first_hdr_ptr;
502
540
})
+20
-31
lib/tm.mli
+20
-31
lib/tm.mli
···
261
261
(** {1 Packed Header Wire Representation} *)
262
262
263
263
type packed_header = {
264
-
w0 : int; (** Word 0: version(2), scid(10), vcid(3), ocf_flag(1) *)
265
-
w1 : int; (** Word 1: mcfc(8), vcfc(8) *)
266
-
w2 : int;
267
-
(** Word 2: sec_hdr(1), sync(1), pkt_order(1), seg_len(2), fhp(11) *)
264
+
version : int; (** Transfer frame version (2 bits). *)
265
+
scid : int; (** Spacecraft ID (10 bits). *)
266
+
vcid : int; (** Virtual channel ID (3 bits). *)
267
+
ocf_flag : int; (** OCF flag (1 bit). *)
268
+
mcfc : int; (** Master channel frame count (8 bits). *)
269
+
vcfc : int; (** Virtual channel frame count (8 bits). *)
270
+
sec_hdr : int; (** Secondary header flag (1 bit). *)
271
+
sync_flag : int; (** Synchronization flag (1 bit). *)
272
+
pkt_order : int; (** Packet order flag (1 bit). *)
273
+
seg_len_id : int; (** Segment length identifier (2 bits). *)
274
+
first_hdr_ptr : int; (** First header pointer (11 bits). *)
268
275
}
269
-
(** Raw TM header stored as three 16-bit big-endian values (6 bytes total). *)
276
+
(** Raw TM header with bitfields decoded into named record fields (6 bytes). *)
270
277
271
278
val to_packed_header : header -> packed_header
272
279
(** [to_packed_header h] converts a TM header to its packed representation. *)
···
276
283
(** [of_packed_header t] converts a packed header back to a structured header.
277
284
*)
278
285
279
-
module Packed_header : sig
280
-
type t = packed_header = { w0 : int; w1 : int; w2 : int }
286
+
val equal_packed_header : packed_header -> packed_header -> bool
281
287
282
-
val equal : t -> t -> bool
288
+
(** {1 Wire Codec} *)
283
289
284
-
(** {1 Field Accessors} *)
290
+
val codec : packed_header Wire.Codec.t
291
+
val struct_ : Wire.struct_
292
+
val module_ : Wire.module_
285
293
286
-
val version : t -> int
287
-
val scid : t -> int
288
-
val vcid : t -> int
289
-
val ocf_flag : t -> bool
290
-
val mcfc : t -> int
291
-
val vcfc : t -> int
292
-
val sec_hdr : t -> bool
293
-
val sync_flag : t -> bool
294
-
val pkt_order : t -> bool
295
-
val seg_len_id : t -> int
296
-
val first_hdr_ptr : t -> int
294
+
(** {1 Wire Parse/Encode} *)
297
295
298
-
(** {1 Wire Codec} *)
299
-
300
-
val codec : t Wire.Codec.t
301
-
val struct_ : Wire.struct_
302
-
val module_ : Wire.module_
303
-
304
-
(** {1 Parse/Encode} *)
305
-
306
-
val decode_exn : bytes -> int -> t
307
-
val encode : t -> bytes -> int -> unit
308
-
end
296
+
val decode_packed_header : bytes -> int -> packed_header
297
+
val encode_packed_header : packed_header -> bytes -> int -> unit