diff --git a/src/lib_stdlib/logging.ml b/src/lib_stdlib/logging.ml
index 5739e9ca8..6b5b99726 100644
--- a/src/lib_stdlib/logging.ml
+++ b/src/lib_stdlib/logging.ml
@@ -7,8 +7,284 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module Tag = struct
+
+  type _ selector = ..
+
+  module type DEF_ARG = sig
+    val name : string
+    type t
+    val doc : string
+    val pp : Format.formatter -> t -> unit
+  end
+
+  module type DEF = sig
+    include DEF_ARG
+
+    type id
+    val id: id
+    type _ selector += Me : t selector
+
+    val uid : int
+
+  end
+
+  module Def (X : DEF_ARG): DEF with type t = X.t = struct
+    include X
+
+    type id = Id
+    let id = Id
+    type _ selector += Me : t selector
+
+    let uid = Obj.(extension_id @@ extension_constructor @@ Me)
+
+  end
+
+  type 'a def = (module DEF with type t = 'a)
+
+  let def (type a) ?(doc = "undocumented") name pp =
+    (module Def(struct let name = name type t = a let doc = doc let pp = pp end): DEF with type t = a)
+
+  type (_,_) eq = Refl : ('a,'a) eq
+
+  let maybe_eq : type a b. a def -> b def -> (a,b) eq option =
+    fun s t ->
+      let module S = (val s) in
+      let module T = (val t) in
+      match S.Me with
+      | T.Me -> Some Refl
+      | _ -> None
+
+  let selector_of : type a. a def -> a selector = fun d -> let module D = (val d) in D.Me
+  let name : type a. a def -> string = fun d -> let module D = (val d) in D.name
+  let doc : type a. a def -> string = fun d -> let module D = (val d) in D.doc
+  let printer : type a. a def -> Format.formatter -> a -> unit = fun d -> let module D = (val d) in D.pp
+  let pp_def ppf d = Format.fprintf ppf "tag:%s" (name d)
+
+  module Key = struct
+    type t = V : 'a def -> t
+    type s = S : 'a selector -> s
+    let compare (V k0) (V k1) = compare (S (selector_of k0)) (S (selector_of k1))
+  end
+
+  module TagSet = Map.Make(Key)
+
+  type t = V : 'a def * 'a -> t
+  type binding = t
+  type set = binding TagSet.t
+
+  let pp ppf (V (tag, v)) =
+    Format.fprintf ppf "@[<1>(%a@ @[%a@])@]" pp_def tag (printer tag) v
+
+  let option_map f = function
+    | None -> None
+    | Some v -> Some (f v)
+
+  let option_bind f = function
+    | None -> None
+    | Some v -> f v
+
+  let reveal2 : type a b. a def -> b def -> b -> a option = fun t u v ->
+    match maybe_eq t u with
+    | None -> None
+    | Some Refl -> Some v
+
+  let reveal : 'a. 'a def -> binding -> 'a option = fun tag -> function
+    | V (another, v) -> reveal2 tag another v
+
+  let unveil : 'a. 'a def -> binding option -> 'a option = fun tag -> option_bind @@ reveal tag
+
+  let conceal : 'a. 'a def -> 'a -> binding = fun tag v -> V (tag, v)
+
+  let veil : 'a. 'a def -> 'a option -> binding option = fun tag -> option_map @@ conceal tag
+
+  let empty = TagSet.empty
+  let is_empty = TagSet.is_empty
+  let mem tag = TagSet.mem (Key.V tag)
+  let add tag v = TagSet.add (Key.V tag) (V (tag, v))
+  let update tag f = TagSet.update (Key.V tag) (fun b -> veil tag @@ f @@ unveil tag b)
+  let singleton tag v = TagSet.singleton (Key.V tag) (V (tag, v))
+  let remove tag = TagSet.remove (Key.V tag)
+  let rem = remove
+  type merger = { merger : 'a. 'a def -> 'a option -> 'a option -> 'a option }
+  let merge f = TagSet.merge @@ function
+    | Key.V tag -> fun a b -> veil tag @@ f.merger tag (unveil tag a) (unveil tag b)
+  type unioner = { unioner : 'a . 'a def -> 'a -> 'a -> 'a }
+  let union f = merge { merger = fun tag a b ->
+      match (a,b) with
+      | (Some aa, Some bb) -> Some (f.unioner tag aa bb)
+      | (Some _, None) -> a
+      | (None, _) -> b
+    }
+  (* no compare and equal, compare especially makes little sense *)
+  let iter f = TagSet.iter (fun _ -> f)
+  let fold f = TagSet.fold (fun _ -> f)
+  let for_all p = TagSet.for_all (fun _ -> p)
+  let exists p = TagSet.exists (fun _ -> p)
+  let filter p = TagSet.filter (fun _ -> p)
+  let partition p = TagSet.partition (fun _ -> p)
+  let cardinal = TagSet.cardinal
+  let bindings s = List.map snd @@ TagSet.bindings s
+  let min_binding s = snd @@ TagSet.min_binding s
+  let min_binding_opt s = option_map snd @@ TagSet.min_binding_opt s
+  let max_binding s = snd @@ TagSet.max_binding s
+  let max_binding_opt s = option_map snd @@ TagSet.max_binding_opt s
+  let choose s = snd @@ TagSet.choose s
+  let choose_opt s = option_map snd @@ TagSet.choose_opt s
+  let split tag s = (fun (l,m,r) -> (l,unveil tag m,r)) @@ TagSet.split (Key.V tag) s
+  (* XXX find should be different from find_opt but Logs has find_opt called find *)
+  let find tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
+  let find_opt tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s
+  let get tag s = find_opt tag s |> function
+    | None -> invalid_arg (Format.asprintf "tag named %s not found in set" (name tag))
+    | Some v -> v
+  let find_first p s = snd @@ TagSet.find_first p s
+  let find_first_opt p s = option_map snd @@ TagSet.find_first_opt p s
+  let find_last p s = snd @@ TagSet.find_last p s
+  let find_last_opt p s = option_map snd @@ TagSet.find_last_opt p s
+  let map = TagSet.map
+  let mapi = TagSet.map
+  let pp_set ppf s = Format.(
+      fprintf ppf "@[<1>{";
+      pp_print_list pp ppf (bindings s);
+      Format.fprintf ppf "}@]")
+
+  module DSL = struct
+    type (_,_,_,_) arg = | A : ('x def * 'x) -> (('b -> 'x -> 'c) -> 'x -> 'd, 'b, 'c, 'd) arg
+                         | S : ('x def * 'x) -> ('x -> 'd, 'b, 'c, 'd) arg
+                         | T : ('x def * 'x) -> ('d, 'b, 'c, 'd) arg
+    let a tag v = A (tag,v)
+    let s tag v = S (tag,v)
+    let t tag v = T (tag,v)
+
+    let pp_of_def (type a) tag = let module Tg = (val tag : DEF with type t = a) in Tg.pp
+
+    let (-%): type a d. (?tags:set -> a) -> (a,Format.formatter,unit,d) arg -> (?tags:set -> d) = fun f -> function
+      | A (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags) (pp_of_def tag) v) [@warning "-16"]
+      | S (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags) v) [@warning "-16"]
+      | T (tag,v) -> (fun ?(tags=empty) -> f ~tags:(add tag v tags)) [@warning "-16"]
+  end
+
+end
+
+type ('a, 'b) msgf =
+  (('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) -> ?tags:Tag.set -> 'b
+
+type ('a, 'b) log = ('a, 'b) msgf -> 'b
+
+module type MESSAGE = sig
+  val name: string
+end
+
+type log_section = ..
+
+type log_message = {
+  section : log_section ;
+  text : string ;
+  tags : Tag.set ;
+}
+
+let taps : (log_message -> unit) list ref = ref []
+
+let tap f = taps := f :: !taps
+
+let call_taps v = List.iter (fun f -> f v) !taps
+
+module type SEMLOG = sig
+
+  type log_section += Section
+
+  module Tag = Tag
+
+  val debug: ('a, unit) log
+  val log_info: ('a, unit) log
+  val log_notice: ('a, unit) log
+  val warn: ('a, unit) log
+  val log_error: ('a, unit) log
+  val fatal_error: ('a, unit) log
+
+  val lwt_debug: ('a, unit Lwt.t) log
+  val lwt_log_info: ('a, unit Lwt.t) log
+  val lwt_log_notice: ('a, unit Lwt.t) log
+  val lwt_warn: ('a, unit Lwt.t) log
+  val lwt_log_error: ('a, unit Lwt.t) log
+  val lwt_fatal_error: ('a, unit Lwt.t) log
+
+  val event : string Tag.def
+  val exn : exn Tag.def
+
+end
+
+let sections = ref []
+
+let event = Tag.def ~doc:"String identifier for the class of event being logged" "event" Format.pp_print_text
+let exn = Tag.def ~doc:"Exception which was detected" "exception" (fun f e -> Format.pp_print_text f (Printexc.to_string e))
+
+module Make_semantic(S : MESSAGE) : SEMLOG = struct
+
+  include S
+
+  type log_section += Section
+
+  module Tag = Tag
+
+  let () = sections := S.name :: !sections
+  let section = Lwt_log_core.Section.make S.name
+
+
+  let log_f ~level =
+    if level >= Lwt_log_core.Section.level section then
+      fun format ?(tags=Tag.empty) ->
+        Format.kasprintf
+          (fun text ->
+             call_taps { section = Section ; text ; tags };
+             Lwt_log_core.log ~section ~level text)
+          format
+    else
+      fun format ?(tags=Tag.empty) ->
+        Format.ikfprintf
+          (fun _ -> call_taps { section = Section ; text = "" ; tags }; Lwt.return_unit)
+          Format.std_formatter
+          format
+
+  let ign_log_f ~level =
+    if level >= Lwt_log_core.Section.level section then
+      fun format ?(tags=Tag.empty) ->
+        Format.kasprintf
+          (fun text ->
+             call_taps { section = Section ; text ; tags };
+             Lwt_log_core.ign_log ~section ~level text)
+          format
+    else
+      fun format ?(tags=Tag.empty) ->
+        Format.ikfprintf
+          (fun _ -> call_taps { section = Section ; text = "" ; tags })
+          Format.std_formatter
+          format
+
+  let debug f = f (ign_log_f ~level:Lwt_log_core.Debug) ?tags:(Some Tag.empty)
+  let log_info f = f (ign_log_f ~level:Lwt_log_core.Info) ?tags:(Some Tag.empty)
+  let log_notice f = f (ign_log_f ~level:Lwt_log_core.Notice) ?tags:(Some Tag.empty)
+  let warn f = f (ign_log_f ~level:Lwt_log_core.Warning) ?tags:(Some Tag.empty)
+  let log_error f = f (ign_log_f ~level:Lwt_log_core.Error) ?tags:(Some Tag.empty)
+  let fatal_error f = f (ign_log_f ~level:Lwt_log_core.Fatal) ?tags:(Some Tag.empty)
+
+  let lwt_debug f = f (log_f ~level:Lwt_log_core.Debug) ?tags:(Some Tag.empty)
+  let lwt_log_info f = f (log_f ~level:Lwt_log_core.Info) ?tags:(Some Tag.empty)
+  let lwt_log_notice f = f (log_f ~level:Lwt_log_core.Notice) ?tags:(Some Tag.empty)
+  let lwt_warn f = f (log_f ~level:Lwt_log_core.Warning) ?tags:(Some Tag.empty)
+  let lwt_log_error f = f (log_f ~level:Lwt_log_core.Error) ?tags:(Some Tag.empty)
+  let lwt_fatal_error f = f (log_f ~level:Lwt_log_core.Fatal) ?tags:(Some Tag.empty)
+
+  let event = event
+  let exn = exn
+
+end
+
 module type LOG = sig
 
+  type log_section += Section
+
   val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
   val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a
   val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a
@@ -25,29 +301,34 @@ module type LOG = sig
 
 end
 
-let log_f
-    ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format =
-  if level < Lwt_log_core.Section.level section then
-    Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format
-  else
-    Format.kasprintf
-      (fun msg -> Lwt_log_core.log ?exn ~section ?location ?logger ~level msg)
-      format
-
-let ign_log_f
-    ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format =
-  if level < Lwt_log_core.Section.level section then
-    Format.ikfprintf (fun _ -> ()) Format.std_formatter format
-  else
-    Format.kasprintf
-      (fun msg -> Lwt_log_core.ign_log ?exn ~section ?location ?logger ~level msg)
-      format
-
 let sections = ref []
 
 module Make_unregistered(S : sig val name: string end) : LOG = struct
 
   let section = Lwt_log_core.Section.make S.name
+  type log_section += Section
+
+  let log_f
+      ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format =
+    if level < Lwt_log_core.Section.level section then
+      Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format
+    else
+      Format.kasprintf
+        (fun msg ->
+           call_taps { section = Section ; text = msg ; tags = Tag.empty };
+           Lwt_log_core.log ?exn ~section ?location ?logger ~level msg)
+        format
+
+  let ign_log_f
+      ?exn ?(section = Lwt_log_core.Section.main) ?location ?logger ~level format =
+    if level < Lwt_log_core.Section.level section then
+      Format.ikfprintf (fun _ -> ()) Format.std_formatter format
+    else
+      Format.kasprintf
+        (fun msg ->
+           call_taps { section = Section ; text = msg ; tags = Tag.empty };
+           Lwt_log_core.ign_log ?exn ~section ?location ?logger ~level msg)
+        format
 
   let debug fmt = ign_log_f ~section ~level:Lwt_log_core.Debug fmt
   let log_info fmt = ign_log_f ~section ~level:Lwt_log_core.Info fmt
@@ -72,7 +353,11 @@ module Make(S : sig val name: string end) : LOG = struct
 
 end
 
-module Core = Make(struct let name = "core" end)
+module Core = struct
+  include Make_semantic(struct let name = "core" end)
+
+  let worker = Tag.def ~doc:"Name of affected worker" "worker" Format.pp_print_text
+end
 
 type level = Lwt_log_core.level =
   | Debug
diff --git a/src/lib_stdlib/logging.mli b/src/lib_stdlib/logging.mli
index 4f66c5cd0..2e48d5edc 100644
--- a/src/lib_stdlib/logging.mli
+++ b/src/lib_stdlib/logging.mli
@@ -7,8 +7,116 @@
 (*                                                                        *)
 (**************************************************************************)
 
+module Tag : sig
+  type _ def
+
+  val def : ?doc:string -> string -> (Format.formatter -> 'a -> unit) -> 'a def
+
+  val name : 'a def -> string
+  val doc : 'a def -> string
+  val printer : 'a def -> (Format.formatter -> 'a -> unit)
+  val pp_def : Format.formatter -> 'a def -> unit
+
+  type t = V : 'a def * 'a -> t
+  val pp : Format.formatter -> t -> unit
+
+  module Key : sig
+    type t = V : 'a def -> t
+  end
+  type set
+
+  val empty : set
+  val is_empty : set -> bool
+  val mem : 'a def -> set -> bool
+  val add : 'a def -> 'a -> set -> set
+  val update : 'a def -> ('a option -> 'a option) -> (set -> set)
+  val singleton : 'a def -> 'a -> set
+  val remove : 'a def -> set -> set
+  val rem : 'a def -> set -> set
+  type merger = { merger : 'a. 'a def -> 'a option -> 'a option -> 'a option }
+  val merge : merger -> set -> set -> set
+  type unioner = { unioner : 'a. 'a def -> 'a -> 'a -> 'a }
+  val union : unioner -> set -> set -> set
+  val iter : (t -> unit) -> set -> unit
+  val fold : (t -> 'b -> 'b) -> (set -> 'b -> 'b)
+  val for_all : (t -> bool) -> (set -> bool)
+  val exists : (t -> bool) -> (set -> bool)
+  val filter : (t -> bool) -> set -> set
+  val partition : (t -> bool) -> set -> (set * set)
+  val cardinal : set -> int
+  val min_binding : set -> t
+  val min_binding_opt : set -> t option
+  val max_binding : set -> t
+  val max_binding_opt : set -> t option
+  val choose : set -> t
+  val choose_opt : set -> t option
+  val split : 'a def -> set -> set * 'a option * set
+  val find : 'a def -> set -> 'a option
+  val get : 'a def -> set -> 'a
+  val find_first : (Key.t -> bool) -> set -> t
+  val find_first_opt : (Key.t -> bool) -> set -> t option
+  val find_last : (Key.t -> bool) -> set -> t
+  val find_last_opt : (Key.t -> bool) -> set -> t option
+  val map : (t -> t) -> set -> set
+  val mapi : (t -> t) -> set -> set
+  val pp_set : Format.formatter -> set -> unit
+
+  module DSL : sig
+    type (_,_,_,_) arg
+    val a : 'v def -> 'v -> (('b -> 'v -> 'c) -> 'v -> 'd, 'b, 'c, 'd) arg
+    val s : 'v def -> 'v -> ('v -> 'd, 'b, 'c, 'd) arg
+    val t : 'v def -> 'v -> ('d, 'b, 'c, 'd) arg
+    val (-%) : (?tags:set -> 'a) -> ('a,Format.formatter,unit,'d) arg -> (?tags:set -> 'd)
+  end
+
+end
+
+type log_section = private ..
+
+type log_message = {
+  section : log_section ;
+  text : string ;
+  tags : Tag.set ;
+}
+
+val tap : (log_message -> unit) -> unit
+
+type ('a,'b) msgf = (('a, Format.formatter, unit, 'b) format4 -> ?tags:Tag.set -> 'a) -> ?tags:Tag.set -> 'b
+type ('a,'b) log = ('a,'b) msgf -> 'b
+
+module type MESSAGE = sig
+  val name: string
+end
+
+module type SEMLOG = sig
+
+  type log_section += Section
+
+  module Tag = Tag
+
+  val debug: ('a, unit) log
+  val log_info: ('a, unit) log
+  val log_notice: ('a, unit) log
+  val warn: ('a, unit) log
+  val log_error: ('a, unit) log
+  val fatal_error: ('a, unit) log
+
+  val lwt_debug: ('a, unit Lwt.t) log
+  val lwt_log_info: ('a, unit Lwt.t) log
+  val lwt_log_notice: ('a, unit Lwt.t) log
+  val lwt_warn: ('a, unit Lwt.t) log
+  val lwt_log_error: ('a, unit Lwt.t) log
+  val lwt_fatal_error: ('a, unit Lwt.t) log
+
+  val event : string Tag.def
+  val exn : exn Tag.def
+
+end
+
 module type LOG = sig
 
+  type log_section += Section
+
   val debug: ('a, Format.formatter, unit, unit) format4 -> 'a
   val log_info: ('a, Format.formatter, unit, unit) format4 -> 'a
   val log_notice: ('a, Format.formatter, unit, unit) format4 -> 'a
@@ -25,11 +133,17 @@ module type LOG = sig
 
 end
 
-module Core : LOG
+module Core : sig
+  include SEMLOG
+
+  val worker : string Tag.def
+end
 
 module Make(S: sig val name: string end) : LOG
 module Make_unregistered(S: sig val name: string end) : LOG
 
+module Make_semantic(S: MESSAGE) : SEMLOG
+
 type level = Lwt_log_core.level =
   | Debug
   (** Debugging message. They can be automatically removed by the
diff --git a/src/lib_stdlib/lwt_utils.ml b/src/lib_stdlib/lwt_utils.ml
index aa6268ec1..389c6fa27 100644
--- a/src/lib_stdlib/lwt_utils.ml
+++ b/src/lib_stdlib/lwt_utils.ml
@@ -51,18 +51,28 @@ let trigger () : (unit -> unit) * (unit -> unit Lwt.t) =
 let worker name ~run ~cancel =
   let stop = LC.create () in
   let fail e =
-    log_error "%s worker failed with %s" name (Printexc.to_string e) ;
+    log_error Tag.DSL.(fun f ->
+        f "%s worker failed with %a"
+        -% t event "worker_failed"
+        -% s worker name
+        -% a exn e) ;
     cancel ()
   in
   let waiter = LC.wait stop in
-  log_info "%s worker started" name ;
+  log_info Tag.DSL.(fun f ->
+      f "%s worker started"
+      -% t event "worker_started"
+      -% s worker name) ;
   Lwt.async
     (fun () ->
        Lwt.catch run fail >>= fun () ->
        LC.signal stop ();
        Lwt.return_unit) ;
   waiter >>= fun () ->
-  log_info "%s worker ended" name ;
+  log_info Tag.DSL.(fun f ->
+      f "%s worker ended"
+      -% t event "worker_finished"
+      -% s worker name) ;
   Lwt.return_unit