diff --git a/ocaml/xapi-idl/lib/debuginfo.ml b/ocaml/xapi-idl/lib/debuginfo.ml
index 1b6d92e6c3b..3b5306a50cd 100644
--- a/ocaml/xapi-idl/lib/debuginfo.ml
+++ b/ocaml/xapi-idl/lib/debuginfo.ml
@@ -47,3 +47,21 @@ let to_string t =
 
 (* Used for xapi-idl servers that do not yet accept tracing data in the debuginfo *)
 let to_log_string t = t.log
+
+(* Sets the logging context based on `dbg`.
+   Also adds a new tracing span, linked to the parent span from `dbg`, if available. *)
+let with_dbg ?(with_thread = false) ~module_name ~name ~dbg f =
+  let di = of_string dbg in
+  let f_with_trace () =
+    let name =
+      match module_name with "" -> name | _ -> module_name ^ "." ^ name
+    in
+    Tracing.with_tracing ~parent:di.tracing ~name (fun span ->
+        match span with Some _ -> f {di with tracing= span} | None -> f di
+    )
+  in
+  match with_thread with
+  | true ->
+      Debug.with_thread_associated di.log f_with_trace ()
+  | false ->
+      f_with_trace ()
diff --git a/ocaml/xapi-idl/lib/debuginfo.mli b/ocaml/xapi-idl/lib/debuginfo.mli
index b0589a58c1c..f50db605eb0 100644
--- a/ocaml/xapi-idl/lib/debuginfo.mli
+++ b/ocaml/xapi-idl/lib/debuginfo.mli
@@ -21,3 +21,11 @@ val of_string : string -> t
 val to_string : t -> string
 
 val to_log_string : t -> string
+
+val with_dbg :
+     ?with_thread:bool
+  -> module_name:string
+  -> name:string
+  -> dbg:string
+  -> (t -> 'a)
+  -> 'a
diff --git a/ocaml/xapi/sm.ml b/ocaml/xapi/sm.ml
index 2a18041f507..c55c2c423c3 100644
--- a/ocaml/xapi/sm.ml
+++ b/ocaml/xapi/sm.ml
@@ -59,6 +59,8 @@ let driver_filename driver =
 
 (*****************************************************************************)
 
+let with_dbg ~name ~dbg f = Debuginfo.with_dbg ~module_name:"SM" ~name ~dbg f
+
 let debug operation driver msg = debug "SM %s %s %s" driver operation msg
 
 let srmaster_only (_, dconf) =
@@ -132,9 +134,10 @@ let sr_update dconf driver sr =
   let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_update" [] in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_create dconf driver sr sm_config vdi_type size name_label
+let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label
     name_description metadata_of_pool is_a_snapshot snapshot_time snapshot_of
     read_only =
+  with_dbg ~dbg ~name:"vdi_create" @@ fun _ ->
   debug "vdi_create" driver
     (sprintf "sr=%s sm_config=[%s] type=[%s] size=%Ld" (Ref.string_of sr)
        (String.concat "; " (List.map (fun (k, v) -> k ^ "=" ^ v) sm_config))
@@ -157,13 +160,15 @@ let vdi_create dconf driver sr sm_config vdi_type size name_label
   in
   Sm_exec.parse_vdi_info (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_update dconf driver sr vdi =
+let vdi_update ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_update" @@ fun _ ->
   debug "vdi_update" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   let call = Sm_exec.make_call ~sr_ref:sr ~vdi_ref:vdi dconf "vdi_update" [] in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_introduce dconf driver sr new_uuid sm_config location =
+let vdi_introduce ~dbg dconf driver sr new_uuid sm_config location =
+  with_dbg ~dbg ~name:"vdi_introduce" @@ fun _ ->
   debug "vdi_introduce" driver
     (sprintf "sr=%s new_uuid=%s sm_config=[%s] location=%s" (Ref.string_of sr)
        new_uuid
@@ -176,14 +181,16 @@ let vdi_introduce dconf driver sr new_uuid sm_config location =
   in
   Sm_exec.parse_vdi_info (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_delete dconf driver sr vdi =
+let vdi_delete ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_delete" @@ fun _ ->
   debug "vdi_delete" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   srmaster_only dconf ;
   let call = Sm_exec.make_call ~sr_ref:sr ~vdi_ref:vdi dconf "vdi_delete" [] in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_attach dconf driver sr vdi writable =
+let vdi_attach ~dbg dconf driver sr vdi writable =
+  with_dbg ~dbg ~name:"vdi_attach" @@ fun _ ->
   debug "vdi_attach" driver
     (sprintf "sr=%s vdi=%s writable=%b" (Ref.string_of sr) (Ref.string_of vdi)
        writable
@@ -195,13 +202,15 @@ let vdi_attach dconf driver sr vdi writable =
   let result = Sm_exec.exec_xmlrpc (driver_filename driver) call in
   Sm_exec.parse_attach_result result
 
-let vdi_detach dconf driver sr vdi =
+let vdi_detach ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_detach" @@ fun _ ->
   debug "vdi_detach" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   let call = Sm_exec.make_call ~sr_ref:sr ~vdi_ref:vdi dconf "vdi_detach" [] in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_activate dconf driver sr vdi writable =
+let vdi_activate ~dbg dconf driver sr vdi writable =
+  with_dbg ~dbg ~name:"vdi_activate" @@ fun _ ->
   debug "vdi_activate" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   let call =
@@ -210,7 +219,8 @@ let vdi_activate dconf driver sr vdi writable =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_deactivate dconf driver sr vdi =
+let vdi_deactivate ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_deactivate" @@ fun _ ->
   debug "vdi_deactivate" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   let call =
@@ -218,7 +228,8 @@ let vdi_deactivate dconf driver sr vdi =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_snapshot dconf driver driver_params sr vdi =
+let vdi_snapshot ~dbg dconf driver driver_params sr vdi =
+  with_dbg ~dbg ~name:"vdi_snapshot" @@ fun _ ->
   debug "vdi_snapshot" driver
     (sprintf "sr=%s vdi=%s driver_params=[%s]" (Ref.string_of sr)
        (Ref.string_of vdi)
@@ -231,7 +242,8 @@ let vdi_snapshot dconf driver driver_params sr vdi =
   in
   Sm_exec.parse_vdi_info (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_clone dconf driver driver_params sr vdi =
+let vdi_clone ~dbg dconf driver driver_params sr vdi =
+  with_dbg ~dbg ~name:"vdi_clone" @@ fun _ ->
   debug "vdi_clone" driver
     (sprintf "sr=%s vdi=%s driver_params=[%s]" (Ref.string_of sr)
        (Ref.string_of vdi)
@@ -244,7 +256,8 @@ let vdi_clone dconf driver driver_params sr vdi =
   in
   Sm_exec.parse_vdi_info (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_resize dconf driver sr vdi newsize =
+let vdi_resize ~dbg dconf driver sr vdi newsize =
+  with_dbg ~dbg ~name:"vdi_resize" @@ fun _ ->
   debug "vdi_resize" driver
     (sprintf "sr=%s vdi=%s newsize=%Ld" (Ref.string_of sr) (Ref.string_of vdi)
        newsize
@@ -264,7 +277,8 @@ let vdi_generate_config dconf driver sr vdi =
   in
   Sm_exec.parse_string (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_compose dconf driver sr vdi1 vdi2 =
+let vdi_compose ~dbg dconf driver sr vdi1 vdi2 =
+  with_dbg ~dbg ~name:"vdi_compose" @@ fun _ ->
   debug "vdi_compose" driver
     (sprintf "sr=%s vdi1=%s vdi2=%s" (Ref.string_of sr) (Ref.string_of vdi1)
        (Ref.string_of vdi2)
@@ -276,7 +290,8 @@ let vdi_compose dconf driver sr vdi1 vdi2 =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_epoch_begin dconf driver sr vdi =
+let vdi_epoch_begin ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_epoch_begin" @@ fun _ ->
   debug "vdi_epoch_begin" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   let call =
@@ -284,7 +299,8 @@ let vdi_epoch_begin dconf driver sr vdi =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_epoch_end dconf driver sr vdi =
+let vdi_epoch_end ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_epoch_end" @@ fun _ ->
   debug "vdi_epoch_end" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   let call =
@@ -292,7 +308,8 @@ let vdi_epoch_end dconf driver sr vdi =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_enable_cbt dconf driver sr vdi =
+let vdi_enable_cbt ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_enable_cbt" @@ fun _ ->
   debug "vdi_enable_cbt" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   srmaster_only dconf ;
@@ -301,7 +318,8 @@ let vdi_enable_cbt dconf driver sr vdi =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_disable_cbt dconf driver sr vdi =
+let vdi_disable_cbt ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_disable_cbt" @@ fun _ ->
   debug "vdi_disable_cbt" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   srmaster_only dconf ;
@@ -310,7 +328,8 @@ let vdi_disable_cbt dconf driver sr vdi =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_data_destroy dconf driver sr vdi =
+let vdi_data_destroy ~dbg dconf driver sr vdi =
+  with_dbg ~dbg ~name:"vdi_data_destroy" @@ fun _ ->
   debug "vdi_data_destroy" driver
     (sprintf "sr=%s vdi=%s" (Ref.string_of sr) (Ref.string_of vdi)) ;
   srmaster_only dconf ;
@@ -319,7 +338,8 @@ let vdi_data_destroy dconf driver sr vdi =
   in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc (driver_filename driver) call)
 
-let vdi_list_changed_blocks dconf driver sr ~vdi_from ~vdi_to =
+let vdi_list_changed_blocks ~dbg dconf driver sr ~vdi_from ~vdi_to =
+  with_dbg ~dbg ~name:"vdi_list_changed_blocks" @@ fun _ ->
   debug "vdi_list_changed_blocks" driver
     (sprintf "sr=%s vdi_from=%s vdi_to=%s" (Ref.string_of sr)
        (Ref.string_of vdi_from) (Ref.string_of vdi_to)
diff --git a/ocaml/xapi/static_vdis.ml b/ocaml/xapi/static_vdis.ml
index 672c67a8855..5ed45c95e16 100644
--- a/ocaml/xapi/static_vdis.ml
+++ b/ocaml/xapi/static_vdis.ml
@@ -77,7 +77,8 @@ let permanent_vdi_deactivate_by_uuid ~__context ~uuid =
   try
     let vdi = Db.VDI.get_by_uuid ~__context ~uuid in
     Sm.call_sm_vdi_functions ~__context ~vdi (fun srconf srtype sr ->
-        Sm.vdi_deactivate srconf srtype sr vdi
+        let dbg = Context.string_of_task_and_tracing __context in
+        Sm.vdi_deactivate ~dbg srconf srtype sr vdi
     )
   with e ->
     warn
diff --git a/ocaml/xapi/storage_smapiv1.ml b/ocaml/xapi/storage_smapiv1.ml
index 8705896d719..4c7c382f250 100644
--- a/ocaml/xapi/storage_smapiv1.ml
+++ b/ocaml/xapi/storage_smapiv1.ml
@@ -27,6 +27,9 @@ let s_of_sr = Sr.string_of
 
 let with_lock = Xapi_stdext_threads.Threadext.Mutex.execute
 
+let with_dbg ~name ~dbg f =
+  Debuginfo.with_dbg ~module_name:"SMAPIv1" ~name ~dbg f
+
 (* Find a VDI given a storage-layer SR and VDI *)
 let find_vdi ~__context sr vdi =
   let sr = s_of_sr sr in
@@ -492,21 +495,23 @@ module SMAPIv1 : Server_impl = struct
       per_host_key ~__context ~prefix:"read-caching-reason"
 
     let epoch_begin _context ~dbg ~sr ~vdi ~vm:_ ~persistent:_ =
+      with_dbg ~name:"VDI.epoch_begin" ~dbg @@ fun _ ->
       try
         for_vdi ~dbg ~sr ~vdi "VDI.epoch_begin"
           (fun device_config _type sr self ->
-            Sm.vdi_epoch_begin device_config _type sr self
+            Sm.vdi_epoch_begin ~dbg device_config _type sr self
         )
       with Api_errors.Server_error (code, params) ->
         raise (Storage_error (Backend_error (code, params)))
 
     let attach2 _context ~dbg ~dp:_ ~sr ~vdi ~read_write =
+      with_dbg ~name:"VDI.attach2" ~dbg @@ fun _ ->
       try
         let backend =
           for_vdi ~dbg ~sr ~vdi "VDI.attach2"
             (fun device_config _type sr self ->
               let attach_info_v1 =
-                Sm.vdi_attach device_config _type sr self read_write
+                Sm.vdi_attach ~dbg device_config _type sr self read_write
               in
               (* Record whether the VDI is benefiting from read caching *)
               Server_helpers.exec_with_new_task "VDI.attach2"
@@ -565,6 +570,7 @@ module SMAPIv1 : Server_impl = struct
         raise (Storage_error (Backend_error (code, params)))
 
     let attach3 context ~dbg ~dp ~sr ~vdi ~vm:_ ~read_write =
+      with_dbg ~name:"VDI.attach3" ~dbg @@ fun _ ->
       (*Throw away vm argument as does nothing in SMAPIv1*)
       attach2 context ~dbg ~dp ~sr ~vdi ~read_write
 
@@ -574,6 +580,7 @@ module SMAPIv1 : Server_impl = struct
          Storage_smapiv1_wrapper.Wrapper"
 
     let activate _context ~dbg ~dp ~sr ~vdi =
+      with_dbg ~name:"VDI.activate" ~dbg @@ fun _ ->
       try
         let read_write =
           with_lock vdi_read_write_m (fun () ->
@@ -593,7 +600,7 @@ module SMAPIv1 : Server_impl = struct
             (* If the backend doesn't advertise the capability then do nothing *)
             if List.mem_assoc Smint.Vdi_activate (Sm.features_of_driver _type)
             then
-              Sm.vdi_activate device_config _type sr self read_write
+              Sm.vdi_activate ~dbg device_config _type sr self read_write
             else
               info "%s sr:%s does not support vdi_activate: doing nothing" dp
                 (Ref.string_of sr)
@@ -602,11 +609,13 @@ module SMAPIv1 : Server_impl = struct
         raise (Storage_error (Backend_error (code, params)))
 
     let activate3 context ~dbg ~dp ~sr ~vdi ~vm:_ =
+      with_dbg ~name:"VDI.activate3" ~dbg @@ fun _ ->
       activate context ~dbg ~dp ~sr ~vdi
 
     let activate_readonly = activate3
 
     let deactivate _context ~dbg ~dp ~sr ~vdi ~vm:_ =
+      with_dbg ~name:"VDI.deactivate" ~dbg @@ fun _ ->
       try
         for_vdi ~dbg ~sr ~vdi "VDI.deactivate"
           (fun device_config _type sr self ->
@@ -620,7 +629,7 @@ module SMAPIv1 : Server_impl = struct
             (* If the backend doesn't advertise the capability then do nothing *)
             if List.mem_assoc Smint.Vdi_deactivate (Sm.features_of_driver _type)
             then
-              Sm.vdi_deactivate device_config _type sr self
+              Sm.vdi_deactivate ~dbg device_config _type sr self
             else
               info "%s sr:%s does not support vdi_deactivate: doing nothing" dp
                 (Ref.string_of sr)
@@ -629,9 +638,10 @@ module SMAPIv1 : Server_impl = struct
         raise (Storage_error (Backend_error (code, params)))
 
     let detach _context ~dbg ~dp:_ ~sr ~vdi ~vm:_ =
+      with_dbg ~name:"VDI.detach" ~dbg @@ fun _ ->
       try
         for_vdi ~dbg ~sr ~vdi "VDI.detach" (fun device_config _type sr self ->
-            Sm.vdi_detach device_config _type sr self ;
+            Sm.vdi_detach ~dbg device_config _type sr self ;
             Server_helpers.exec_with_new_task "VDI.detach"
               ~subtask_of:(Ref.of_string dbg) (fun __context ->
                 let on_key = read_caching_key ~__context in
@@ -650,10 +660,11 @@ module SMAPIv1 : Server_impl = struct
         raise (Storage_error (Backend_error (code, params)))
 
     let epoch_end _context ~dbg ~sr ~vdi ~vm:_ =
+      with_dbg ~name:"VDI.epoch_end" ~dbg @@ fun _ ->
       try
         for_vdi ~dbg ~sr ~vdi "VDI.epoch_end"
           (fun device_config _type sr self ->
-            Sm.vdi_epoch_end device_config _type sr self
+            Sm.vdi_epoch_end ~dbg device_config _type sr self
         )
       with Api_errors.Server_error (code, params) ->
         raise (Storage_error (Backend_error (code, params)))
@@ -671,13 +682,14 @@ module SMAPIv1 : Server_impl = struct
       vdi_info_from_db ~__context (Db.VDI.get_by_uuid ~__context ~uuid)
 
     let create _context ~dbg ~sr ~vdi_info =
+      with_dbg ~name:"VDI.create" ~dbg @@ fun _ ->
       try
         Server_helpers.exec_with_new_task "VDI.create"
           ~subtask_of:(Ref.of_string dbg) (fun __context ->
             let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in
             let vi =
               Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type ->
-                  Sm.vdi_create device_config _type sr vdi_info.sm_config
+                  Sm.vdi_create ~dbg device_config _type sr vdi_info.sm_config
                     vdi_info.ty vdi_info.virtual_size vdi_info.name_label
                     vdi_info.name_description vdi_info.metadata_of_pool
                     vdi_info.is_a_snapshot vdi_info.snapshot_time
@@ -698,13 +710,14 @@ module SMAPIv1 : Server_impl = struct
 
     let snapshot_and_clone call_name call_f is_a_snapshot _context ~dbg ~sr
         ~vdi_info =
+      with_dbg ~name:"VDI.snapshot_and_clone" ~dbg @@ fun _ ->
       try
         Server_helpers.exec_with_new_task call_name
           ~subtask_of:(Ref.of_string dbg) (fun __context ->
             let vi =
               for_vdi ~dbg ~sr ~vdi:vdi_info.vdi call_name
                 (fun device_config _type sr self ->
-                  call_f device_config _type vdi_info.sm_config sr self
+                  call_f ~dbg device_config _type vdi_info.sm_config sr self
               )
             in
             (* PR-1255: modify clone, snapshot to take the same parameters as create? *)
@@ -743,7 +756,7 @@ module SMAPIv1 : Server_impl = struct
             for_vdi ~dbg ~sr
               ~vdi:(Storage_interface.Vdi.of_string vi.Smint.vdi_info_location)
               "VDI.update" (fun device_config _type sr self ->
-                Sm.vdi_update device_config _type sr self
+                Sm.vdi_update ~dbg device_config _type sr self
             ) ;
             let vdi = vdi_info_from_db ~__context self in
             debug "vdi = %s" (string_of_vdi_info vdi) ;
@@ -762,6 +775,7 @@ module SMAPIv1 : Server_impl = struct
     let clone = snapshot_and_clone "VDI.clone" Sm.vdi_clone false
 
     let set_name_label _context ~dbg ~sr ~vdi ~new_name_label =
+      with_dbg ~name:"VDI.set_name_label" ~dbg @@ fun _ ->
       Server_helpers.exec_with_new_task "VDI.set_name_label"
         ~subtask_of:(Ref.of_string dbg) (fun __context ->
           let self, _ = find_vdi ~__context sr vdi in
@@ -769,6 +783,7 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let set_name_description _context ~dbg ~sr ~vdi ~new_name_description =
+      with_dbg ~name:"VDI.set_name_description" ~dbg @@ fun _ ->
       Server_helpers.exec_with_new_task "VDI.set_name_description"
         ~subtask_of:(Ref.of_string dbg) (fun __context ->
           let self, _ = find_vdi ~__context sr vdi in
@@ -777,10 +792,11 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let resize _context ~dbg ~sr ~vdi ~new_size =
+      with_dbg ~name:"VDI.resize" ~dbg @@ fun _ ->
       try
         let vi =
           for_vdi ~dbg ~sr ~vdi "VDI.resize" (fun device_config _type sr self ->
-              Sm.vdi_resize device_config _type sr self new_size
+              Sm.vdi_resize ~dbg device_config _type sr self new_size
           )
         in
         Server_helpers.exec_with_new_task "VDI.resize"
@@ -800,9 +816,10 @@ module SMAPIv1 : Server_impl = struct
           redirect sr
 
     let destroy _context ~dbg ~sr ~vdi =
+      with_dbg ~name:"VDI.destroy" ~dbg @@ fun _ ->
       try
         for_vdi ~dbg ~sr ~vdi "VDI.destroy" (fun device_config _type sr self ->
-            Sm.vdi_delete device_config _type sr self
+            Sm.vdi_delete ~dbg device_config _type sr self
         ) ;
         with_lock vdi_read_write_m (fun () ->
             Hashtbl.remove vdi_read_write (sr, vdi)
@@ -816,11 +833,12 @@ module SMAPIv1 : Server_impl = struct
           redirect sr
 
     let stat _context ~dbg ~sr ~vdi =
+      with_dbg ~name:"VDI.stat" ~dbg @@ fun _ ->
       try
         Server_helpers.exec_with_new_task "VDI.stat"
           ~subtask_of:(Ref.of_string dbg) (fun __context ->
             for_vdi ~dbg ~sr ~vdi "VDI.stat" (fun device_config _type sr self ->
-                Sm.vdi_update device_config _type sr self ;
+                Sm.vdi_update ~dbg device_config _type sr self ;
                 vdi_info_of_vdi_rec __context
                   (Db.VDI.get_record ~__context ~self)
             )
@@ -830,6 +848,7 @@ module SMAPIv1 : Server_impl = struct
         raise (Storage_error (Vdi_does_not_exist (s_of_vdi vdi)))
 
     let introduce _context ~dbg ~sr ~uuid ~sm_config ~location =
+      with_dbg ~name:"VDI.introduce" ~dbg @@ fun _ ->
       try
         Server_helpers.exec_with_new_task "VDI.introduce"
           ~subtask_of:(Ref.of_string dbg) (fun __context ->
@@ -837,7 +856,7 @@ module SMAPIv1 : Server_impl = struct
             let vi =
               Sm.call_sm_functions ~__context ~sR:sr
                 (fun device_config sr_type ->
-                  Sm.vdi_introduce device_config sr_type sr uuid sm_config
+                  Sm.vdi_introduce ~dbg device_config sr_type sr uuid sm_config
                     location
               )
             in
@@ -848,6 +867,7 @@ module SMAPIv1 : Server_impl = struct
         raise (Storage_error (Vdi_does_not_exist location))
 
     let set_persistent _context ~dbg ~sr ~vdi ~persistent =
+      with_dbg ~name:"VDI.set_persistent" ~dbg @@ fun _ ->
       try
         Server_helpers.exec_with_new_task "VDI.set_persistent"
           ~subtask_of:(Ref.of_string dbg) (fun __context ->
@@ -858,13 +878,13 @@ module SMAPIv1 : Server_impl = struct
               let new_vdi =
                 for_vdi ~dbg ~sr ~vdi "VDI.clone"
                   (fun device_config _type sr self ->
-                    let vi = Sm.vdi_clone device_config _type [] sr self in
+                    let vi = Sm.vdi_clone ~dbg device_config _type [] sr self in
                     Storage_interface.Vdi.of_string vi.Smint.vdi_info_location
                 )
               in
               for_vdi ~dbg ~sr ~vdi:new_vdi "VDI.destroy"
                 (fun device_config _type sr self ->
-                  Sm.vdi_delete device_config _type sr self
+                  Sm.vdi_delete ~dbg device_config _type sr self
               )
             )
         )
@@ -875,7 +895,8 @@ module SMAPIv1 : Server_impl = struct
           redirect sr
 
     let get_by_name _context ~dbg ~sr ~name =
-      info "VDI.get_by_name dbg:%s sr:%s name:%s" dbg (s_of_sr sr) name ;
+      with_dbg ~name:"VDI.get_by_name" ~dbg @@ fun {log; _} ->
+      info "VDI.get_by_name dbg:%s sr:%s name:%s" log (s_of_sr sr) name ;
       (* PR-1255: the backend should do this for us *)
       Server_helpers.exec_with_new_task "VDI.get_by_name"
         ~subtask_of:(Ref.of_string dbg) (fun __context ->
@@ -891,7 +912,8 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let set_content_id _context ~dbg ~sr ~vdi ~content_id =
-      info "VDI.get_by_content dbg:%s sr:%s vdi:%s content_id:%s" dbg
+      with_dbg ~name:"VDI.set_content_id" ~dbg @@ fun {log; _} ->
+      info "VDI.get_by_content dbg:%s sr:%s vdi:%s content_id:%s" log
         (s_of_sr sr) (s_of_vdi vdi) content_id ;
       (* PR-1255: the backend should do this for us *)
       Server_helpers.exec_with_new_task "VDI.set_content_id"
@@ -903,7 +925,8 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let similar_content _context ~dbg ~sr ~vdi =
-      info "VDI.similar_content dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr)
+      with_dbg ~name:"VDI.similar_content" ~dbg @@ fun {log; _} ->
+      info "VDI.similar_content dbg:%s sr:%s vdi:%s" log (s_of_sr sr)
         (s_of_vdi vdi) ;
       Server_helpers.exec_with_new_task "VDI.similar_content"
         ~subtask_of:(Ref.of_string dbg) (fun __context ->
@@ -1013,7 +1036,8 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let compose _context ~dbg ~sr ~vdi1 ~vdi2 =
-      info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" dbg (s_of_sr sr)
+      with_dbg ~name:"VDI.compose" ~dbg @@ fun {log; _} ->
+      info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" log (s_of_sr sr)
         (s_of_vdi vdi1) (s_of_vdi vdi2) ;
       try
         Server_helpers.exec_with_new_task "VDI.compose"
@@ -1022,7 +1046,7 @@ module SMAPIv1 : Server_impl = struct
             let vdi1 = find_vdi ~__context sr vdi1 |> fst in
             for_vdi ~dbg ~sr ~vdi:vdi2 "VDI.compose"
               (fun device_config _type sr self ->
-                Sm.vdi_compose device_config _type sr vdi1 self
+                Sm.vdi_compose ~dbg device_config _type sr vdi1 self
             )
         )
       with
@@ -1039,7 +1063,8 @@ module SMAPIv1 : Server_impl = struct
           redirect sr
 
     let add_to_sm_config _context ~dbg ~sr ~vdi ~key ~value =
-      info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" dbg
+      with_dbg ~name:"VDI.add_to_sm_config" ~dbg @@ fun {log; _} ->
+      info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" log
         (s_of_sr sr) (s_of_vdi vdi) key value ;
       Server_helpers.exec_with_new_task "VDI.add_to_sm_config"
         ~subtask_of:(Ref.of_string dbg) (fun __context ->
@@ -1048,7 +1073,8 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let remove_from_sm_config _context ~dbg ~sr ~vdi ~key =
-      info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" dbg
+      with_dbg ~name:"VDI.remove_from_sm_config" ~dbg @@ fun {log; _} ->
+      info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" log
         (s_of_sr sr) (s_of_vdi vdi) key ;
       Server_helpers.exec_with_new_task "VDI.remove_from_sm_config"
         ~subtask_of:(Ref.of_string dbg) (fun __context ->
@@ -1057,7 +1083,8 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let get_url _context ~dbg ~sr ~vdi =
-      info "VDI.get_url dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ;
+      with_dbg ~name:"VDI.get_url" ~dbg @@ fun {log; _} ->
+      info "VDI.get_url dbg:%s sr:%s vdi:%s" log (s_of_sr sr) (s_of_vdi vdi) ;
       (* XXX: PR-1255: tapdisk shouldn't hardcode xapi urls *)
       (* peer_ip/session_ref/vdi_ref *)
       Server_helpers.exec_with_new_task "VDI.get_url"
@@ -1077,9 +1104,10 @@ module SMAPIv1 : Server_impl = struct
       )
 
     let call_cbt_function _context ~f ~f_name ~dbg ~sr ~vdi =
+      with_dbg ~name:"VDI.call_cbt_function" ~dbg @@ fun _ ->
       try
         for_vdi ~dbg ~sr ~vdi f_name (fun device_config _type sr self ->
-            f device_config _type sr self
+            f ~dbg device_config _type sr self
         )
       with
       | Smint.Not_implemented_in_backend ->
@@ -1107,13 +1135,14 @@ module SMAPIv1 : Server_impl = struct
         ~content_id:"/No content: this is a cbt_metadata VDI/"
 
     let list_changed_blocks _context ~dbg ~sr ~vdi_from ~vdi_to =
+      with_dbg ~name:"VDI.list_changed_blocks" ~dbg @@ fun _ ->
       try
         Server_helpers.exec_with_new_task "VDI.list_changed_blocks"
           ~subtask_of:(Ref.of_string dbg) (fun __context ->
             let vdi_from = find_vdi ~__context sr vdi_from |> fst in
             for_vdi ~dbg ~sr ~vdi:vdi_to "VDI.list_changed_blocks"
               (fun device_config _type sr vdi_to ->
-                Sm.vdi_list_changed_blocks device_config _type sr ~vdi_from
+                Sm.vdi_list_changed_blocks ~dbg device_config _type sr ~vdi_from
                   ~vdi_to
             )
         )
diff --git a/ocaml/xapi/storage_smapiv1_wrapper.ml b/ocaml/xapi/storage_smapiv1_wrapper.ml
index 3f2cdc7f619..c854c761250 100644
--- a/ocaml/xapi/storage_smapiv1_wrapper.ml
+++ b/ocaml/xapi/storage_smapiv1_wrapper.ml
@@ -92,26 +92,9 @@ let indent x = "    " ^ x
 
 let string_of_date x = Date.to_string (Date.of_float x)
 
-(* Sets the logging context based on `dbg`.
-   Also adds a new tracing span, linked to the parent span from `dbg`, if available. *)
 let with_dbg ~name ~dbg f =
-  let open Debuginfo in
-  let di = of_string dbg in
-  Debug.with_thread_associated di.log
-    (fun () ->
-      let name = "SMAPIv1." ^ name in
-      let tracer = Tracing.get_tracer ~name in
-      let span = Tracing.Tracer.start ~tracer ~name ~parent:di.tracing () in
-      match span with
-      | Ok span_context ->
-          let result = f {di with tracing= span_context} in
-          let _ = Tracing.Tracer.finish span_context in
-          result
-      | Error e ->
-          D.warn "Failed to start tracing: %s" (Printexc.to_string e) ;
-          f di
-    )
-    ()
+  Debuginfo.with_dbg ~with_thread:true ~module_name:"SMAPIv1-Wrapper" ~name ~dbg
+    f
 
 let rpc_fns keyty valty =
   let rpc_of hashtbl =
@@ -603,8 +586,8 @@ functor
         match failures with [] -> next () | f :: _ -> raise f
 
       let epoch_begin context ~dbg ~sr ~vdi ~vm ~persistent =
-        with_dbg ~name:"VDI.epoch_begin" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.epoch_begin dbg:%s sr:%s vdi:%s vm:%s persistent:%b" dbg
+        with_dbg ~name:"VDI.epoch_begin" ~dbg @@ fun {log; _} ->
+        info "VDI.epoch_begin dbg:%s sr:%s vdi:%s vm:%s persistent:%b" log
           (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) persistent ;
         with_vdi sr vdi (fun () ->
             remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked
@@ -614,8 +597,8 @@ functor
         )
 
       let attach3 context ~dbg ~dp ~sr ~vdi ~vm ~read_write =
-        with_dbg ~name:"VDI.attach3" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.attach3 dbg:%s dp:%s sr:%s vdi:%s vm:%s read_write:%b" dbg dp
+        with_dbg ~name:"VDI.attach3" ~dbg @@ fun {log; _} ->
+        info "VDI.attach3 dbg:%s dp:%s sr:%s vdi:%s vm:%s read_write:%b" log dp
           (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) read_write ;
         with_vdi sr vdi (fun () ->
             remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked
@@ -635,16 +618,16 @@ functor
         )
 
       let attach2 context ~dbg ~dp ~sr ~vdi ~read_write =
-        with_dbg ~name:"VDI.attach2" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.attach2 dbg:%s dp:%s sr:%s vdi:%s read_write:%b" dbg dp
+        with_dbg ~name:"VDI.attach2" ~dbg @@ fun {log; _} ->
+        info "VDI.attach2 dbg:%s dp:%s sr:%s vdi:%s read_write:%b" log dp
           (s_of_sr sr) (s_of_vdi vdi) read_write ;
         (*Support calls from older XAPI during migrate operation (dom 0 attach )*)
         let vm = vm_of_s "0" in
         attach3 context ~dbg ~dp ~sr ~vdi ~vm ~read_write
 
       let attach context ~dbg ~dp ~sr ~vdi ~read_write =
-        with_dbg ~name:"VDI.attach" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.attach dbg:%s dp:%s sr:%s vdi:%s read_write:%b" dbg dp
+        with_dbg ~name:"VDI.attach" ~dbg @@ fun {log; _} ->
+        info "VDI.attach dbg:%s dp:%s sr:%s vdi:%s read_write:%b" log dp
           (s_of_sr sr) (s_of_vdi vdi) read_write ;
         let vm = vm_of_s "0" in
         let backend = attach3 context ~dbg ~dp ~sr ~vdi ~vm ~read_write in
@@ -687,8 +670,8 @@ functor
               )
 
       let activate3 context ~dbg ~dp ~sr ~vdi ~vm =
-        with_dbg ~name:"VDI.activate3" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.activate3 dbg:%s dp:%s sr:%s vdi:%s vm:%s" dbg dp (s_of_sr sr)
+        with_dbg ~name:"VDI.activate3" ~dbg @@ fun {log; _} ->
+        info "VDI.activate3 dbg:%s dp:%s sr:%s vdi:%s vm:%s" log dp (s_of_sr sr)
           (s_of_vdi vdi) (s_of_vm vm) ;
         with_vdi sr vdi (fun () ->
             remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked
@@ -703,16 +686,16 @@ functor
       let activate_readonly = activate3
 
       let activate context ~dbg ~dp ~sr ~vdi =
-        with_dbg ~name:"VDI.activate" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.activate dbg:%s dp:%s sr:%s vdi:%s " dbg dp (s_of_sr sr)
+        with_dbg ~name:"VDI.activate" ~dbg @@ fun {log; _} ->
+        info "VDI.activate dbg:%s dp:%s sr:%s vdi:%s " log dp (s_of_sr sr)
           (s_of_vdi vdi) ;
         (*Support calls from older XAPI during migrate operation (dom 0 attach )*)
         let vm = vm_of_s "0" in
         activate3 context ~dbg ~dp ~sr ~vdi ~vm
 
       let deactivate context ~dbg ~dp ~sr ~vdi ~vm =
-        with_dbg ~name:"VDI.deactivate" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.deactivate dbg:%s dp:%s sr:%s vdi:%s vm:%s" dbg dp
+        with_dbg ~name:"VDI.deactivate" ~dbg @@ fun {log; _} ->
+        info "VDI.deactivate dbg:%s dp:%s sr:%s vdi:%s vm:%s" log dp
           (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) ;
         with_vdi sr vdi (fun () ->
             remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked
@@ -725,8 +708,8 @@ functor
         )
 
       let detach context ~dbg ~dp ~sr ~vdi ~vm =
-        with_dbg ~name:"VDI.detach" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.detach dbg:%s dp:%s sr:%s vdi:%s vm:%s" dbg dp (s_of_sr sr)
+        with_dbg ~name:"VDI.detach" ~dbg @@ fun {log; _} ->
+        info "VDI.detach dbg:%s dp:%s sr:%s vdi:%s vm:%s" log dp (s_of_sr sr)
           (s_of_vdi vdi) (s_of_vm vm) ;
         with_vdi sr vdi (fun () ->
             remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked
@@ -739,8 +722,8 @@ functor
         )
 
       let epoch_end context ~dbg ~sr ~vdi ~vm =
-        with_dbg ~name:"VDI.epoch_end" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.epoch_end dbg:%s sr:%s vdi:%s vm:%s" dbg (s_of_sr sr)
+        with_dbg ~name:"VDI.epoch_end" ~dbg @@ fun {log; _} ->
+        info "VDI.epoch_end dbg:%s sr:%s vdi:%s vm:%s" log (s_of_sr sr)
           (s_of_vdi vdi) (s_of_vm vm) ;
         with_vdi sr vdi (fun () ->
             remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi ~vm Vdi.leaked
@@ -749,8 +732,8 @@ functor
         )
 
       let create context ~dbg ~sr ~vdi_info =
-        with_dbg ~name:"VDI.create" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.create dbg:%s sr:%s vdi_info:%s" dbg (s_of_sr sr)
+        with_dbg ~name:"VDI.create" ~dbg @@ fun {log; _} ->
+        info "VDI.create dbg:%s sr:%s vdi_info:%s" log (s_of_sr sr)
           (string_of_vdi_info vdi_info) ;
         let result = Impl.VDI.create context ~dbg ~sr ~vdi_info in
         match result with
@@ -774,8 +757,8 @@ functor
             result
 
       let snapshot_and_clone call_name call_f context ~dbg ~sr ~vdi_info =
-        with_dbg ~name:call_name ~dbg @@ fun {log= dbg; _} ->
-        info "%s dbg:%s sr:%s vdi_info:%s" call_name dbg (s_of_sr sr)
+        with_dbg ~name:call_name ~dbg @@ fun {log; _} ->
+        info "%s dbg:%s sr:%s vdi_info:%s" call_name log (s_of_sr sr)
           (string_of_vdi_info vdi_info) ;
         with_vdi sr vdi_info.vdi (fun () -> call_f context ~dbg ~sr ~vdi_info)
 
@@ -784,34 +767,34 @@ functor
       let clone = snapshot_and_clone "VDI.clone" Impl.VDI.clone
 
       let set_name_label context ~dbg ~sr ~vdi ~new_name_label =
-        with_dbg ~name:"VDI.set_name_label" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.set_name_label dbg:%s sr:%s vdi:%s new_name_label:%s" dbg
+        with_dbg ~name:"VDI.set_name_label" ~dbg @@ fun {log; _} ->
+        info "VDI.set_name_label dbg:%s sr:%s vdi:%s new_name_label:%s" log
           (s_of_sr sr) (s_of_vdi vdi) new_name_label ;
         with_vdi sr vdi (fun () ->
             Impl.VDI.set_name_label context ~dbg ~sr ~vdi ~new_name_label
         )
 
       let set_name_description context ~dbg ~sr ~vdi ~new_name_description =
-        with_dbg ~name:"VDI.set_name_description" ~dbg @@ fun {log= dbg; _} ->
+        with_dbg ~name:"VDI.set_name_description" ~dbg @@ fun {log; _} ->
         info
           "VDI.set_name_description dbg:%s sr:%s vdi:%s new_name_description:%s"
-          dbg (s_of_sr sr) (s_of_vdi vdi) new_name_description ;
+          log (s_of_sr sr) (s_of_vdi vdi) new_name_description ;
         with_vdi sr vdi (fun () ->
             Impl.VDI.set_name_description context ~dbg ~sr ~vdi
               ~new_name_description
         )
 
       let resize context ~dbg ~sr ~vdi ~new_size =
-        with_dbg ~name:"VDI.resize" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.resize dbg:%s sr:%s vdi:%s new_size:%Ld" dbg (s_of_sr sr)
+        with_dbg ~name:"VDI.resize" ~dbg @@ fun {log; _} ->
+        info "VDI.resize dbg:%s sr:%s vdi:%s new_size:%Ld" log (s_of_sr sr)
           (s_of_vdi vdi) new_size ;
         with_vdi sr vdi (fun () ->
             Impl.VDI.resize context ~dbg ~sr ~vdi ~new_size
         )
 
       let destroy_and_data_destroy call_name call_f context ~dbg ~sr ~vdi =
-        with_dbg ~name:call_name ~dbg @@ fun {log= dbg; _} ->
-        info "%s dbg:%s sr:%s vdi:%s" call_name dbg (s_of_sr sr) (s_of_vdi vdi) ;
+        with_dbg ~name:call_name ~dbg @@ fun {log; _} ->
+        info "%s dbg:%s sr:%s vdi:%s" call_name log (s_of_sr sr) (s_of_vdi vdi) ;
 
         with_vdi sr vdi (fun () ->
             remove_datapaths_andthen_nolock context ~dbg ~sr ~vdi Vdi.all
@@ -825,81 +808,81 @@ functor
         destroy_and_data_destroy "VDI.data_destroy" Impl.VDI.data_destroy
 
       let stat context ~dbg ~sr ~vdi =
-        with_dbg ~name:"VDI.stat" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.stat dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ;
+        with_dbg ~name:"VDI.stat" ~dbg @@ fun {log; _} ->
+        info "VDI.stat dbg:%s sr:%s vdi:%s" log (s_of_sr sr) (s_of_vdi vdi) ;
         Impl.VDI.stat context ~dbg ~sr ~vdi
 
       let introduce context ~dbg ~sr ~uuid ~sm_config ~location =
-        with_dbg ~name:"VDI.introduce" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.introduce dbg:%s sr:%s uuid:%s sm_config:%s location:%s" dbg
+        with_dbg ~name:"VDI.introduce" ~dbg @@ fun {log; _} ->
+        info "VDI.introduce dbg:%s sr:%s uuid:%s sm_config:%s location:%s" log
           (s_of_sr sr) uuid
           (String.concat ", " (List.map (fun (k, v) -> k ^ ":" ^ v) sm_config))
           location ;
         Impl.VDI.introduce context ~dbg ~sr ~uuid ~sm_config ~location
 
       let set_persistent context ~dbg ~sr ~vdi ~persistent =
-        with_dbg ~name:"VDI.set_persistent" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.set_persistent dbg:%s sr:%s vdi:%s persistent:%b" dbg
+        with_dbg ~name:"VDI.set_persistent" ~dbg @@ fun {log; _} ->
+        info "VDI.set_persistent dbg:%s sr:%s vdi:%s persistent:%b" log
           (s_of_sr sr) (s_of_vdi vdi) persistent ;
         with_vdi sr vdi (fun () ->
             Impl.VDI.set_persistent context ~dbg ~sr ~vdi ~persistent
         )
 
       let get_by_name context ~dbg ~sr ~name =
-        with_dbg ~name:"VDI.get_by_name" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.get_by_name dbg:%s sr:%s name:%s" dbg (s_of_sr sr) name ;
+        with_dbg ~name:"VDI.get_by_name" ~dbg @@ fun {log; _} ->
+        info "VDI.get_by_name dbg:%s sr:%s name:%s" log (s_of_sr sr) name ;
         Impl.VDI.get_by_name context ~dbg ~sr ~name
 
       let set_content_id context ~dbg ~sr ~vdi ~content_id =
-        with_dbg ~name:"VDI.set_content_id" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.set_content_id dbg:%s sr:%s vdi:%s content_id:%s" dbg
+        with_dbg ~name:"VDI.set_content_id" ~dbg @@ fun {log; _} ->
+        info "VDI.set_content_id dbg:%s sr:%s vdi:%s content_id:%s" log
           (s_of_sr sr) (s_of_vdi vdi) content_id ;
         Impl.VDI.set_content_id context ~dbg ~sr ~vdi ~content_id
 
       let similar_content context ~dbg ~sr ~vdi =
-        with_dbg ~name:"VDI.similar_content" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.similar_content dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr)
+        with_dbg ~name:"VDI.similar_content" ~dbg @@ fun {log; _} ->
+        info "VDI.similar_content dbg:%s sr:%s vdi:%s" log (s_of_sr sr)
           (s_of_vdi vdi) ;
         Impl.VDI.similar_content context ~dbg ~sr ~vdi
 
       let compose context ~dbg ~sr ~vdi1 ~vdi2 =
-        with_dbg ~name:"VDI.compose" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" dbg (s_of_sr sr)
+        with_dbg ~name:"VDI.compose" ~dbg @@ fun {log; _} ->
+        info "VDI.compose dbg:%s sr:%s vdi1:%s vdi2:%s" log (s_of_sr sr)
           (s_of_vdi vdi1) (s_of_vdi vdi2) ;
         Impl.VDI.compose context ~dbg ~sr ~vdi1 ~vdi2
 
       let add_to_sm_config context ~dbg ~sr ~vdi ~key ~value =
-        with_dbg ~name:"VDI.add_to_sm_config" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" dbg
+        with_dbg ~name:"VDI.add_to_sm_config" ~dbg @@ fun {log; _} ->
+        info "VDI.add_to_sm_config dbg:%s sr:%s vdi:%s key:%s value:%s" log
           (s_of_sr sr) (s_of_vdi vdi) key value ;
         Impl.VDI.add_to_sm_config context ~dbg ~sr ~vdi ~key ~value
 
       let remove_from_sm_config context ~dbg ~sr ~vdi ~key =
-        with_dbg ~name:"VDI.remove_from_sm_config" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" dbg
+        with_dbg ~name:"VDI.remove_from_sm_config" ~dbg @@ fun {log; _} ->
+        info "VDI.remove_from_sm_config dbg:%s sr:%s vdi:%s key:%s" log
           (s_of_sr sr) (s_of_vdi vdi) key ;
         Impl.VDI.remove_from_sm_config context ~dbg ~sr ~vdi ~key
 
       let get_url context ~dbg ~sr ~vdi =
-        with_dbg ~name:"VDI.get_url" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.get_url dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ;
+        with_dbg ~name:"VDI.get_url" ~dbg @@ fun {log; _} ->
+        info "VDI.get_url dbg:%s sr:%s vdi:%s" log (s_of_sr sr) (s_of_vdi vdi) ;
         Impl.VDI.get_url context ~dbg ~sr ~vdi
 
       let enable_cbt context ~dbg ~sr ~vdi =
-        with_dbg ~name:"VDI.enabled_cbt" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.enable_cbt dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr) (s_of_vdi vdi) ;
+        with_dbg ~name:"VDI.enabled_cbt" ~dbg @@ fun {log; _} ->
+        info "VDI.enable_cbt dbg:%s sr:%s vdi:%s" log (s_of_sr sr) (s_of_vdi vdi) ;
         with_vdi sr vdi (fun () -> Impl.VDI.enable_cbt context ~dbg ~sr ~vdi)
 
       let disable_cbt context ~dbg ~sr ~vdi =
-        with_dbg ~name:"VDI.disable_cbt" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.disable_cbt dbg:%s sr:%s vdi:%s" dbg (s_of_sr sr)
+        with_dbg ~name:"VDI.disable_cbt" ~dbg @@ fun {log; _} ->
+        info "VDI.disable_cbt dbg:%s sr:%s vdi:%s" log (s_of_sr sr)
           (s_of_vdi vdi) ;
         with_vdi sr vdi (fun () -> Impl.VDI.disable_cbt context ~dbg ~sr ~vdi)
 
       (** The [sr] parameter is the SR of VDI [vdi_to]. *)
       let list_changed_blocks context ~dbg ~sr ~vdi_from ~vdi_to =
-        with_dbg ~name:"VDI.list_changed_blocks" ~dbg @@ fun {log= dbg; _} ->
-        info "VDI.list_changed_blocks dbg:%s sr:%s vdi_from:%s vdi_to:%s" dbg
+        with_dbg ~name:"VDI.list_changed_blocks" ~dbg @@ fun {log; _} ->
+        info "VDI.list_changed_blocks dbg:%s sr:%s vdi_from:%s vdi_to:%s" log
           (s_of_sr sr) (s_of_vdi vdi_from) (s_of_vdi vdi_to) ;
         with_vdi sr vdi_to (fun () ->
             Impl.VDI.list_changed_blocks context ~dbg ~sr ~vdi_from ~vdi_to
@@ -907,8 +890,8 @@ functor
     end
 
     let get_by_name context ~dbg ~name =
-      with_dbg ~name:"get_by_name" ~dbg @@ fun {log= dbg; _} ->
-      debug "get_by_name dbg:%s name:%s" dbg name ;
+      with_dbg ~name:"get_by_name" ~dbg @@ fun {log; _} ->
+      debug "get_by_name dbg:%s name:%s" log name ;
       Impl.get_by_name context ~dbg ~name
 
     module DATA = struct
@@ -1091,8 +1074,8 @@ functor
         assert false
 
       let destroy2 context ~dbg ~dp ~sr ~vdi ~vm ~allow_leak =
-        with_dbg ~name:"DP.destroy2" ~dbg @@ fun {log= dbg; _} ->
-        info "DP.destroy2 dbg:%s dp:%s sr:%s vdi:%s vm:%s allow_leak:%b" dbg dp
+        with_dbg ~name:"DP.destroy2" ~dbg @@ fun {log; _} ->
+        info "DP.destroy2 dbg:%s dp:%s sr:%s vdi:%s vm:%s allow_leak:%b" log dp
           (s_of_sr sr) (s_of_vdi vdi) (s_of_vm vm) allow_leak ;
         destroy' context ~dbg ~dp ~allow_leak
 
@@ -1167,18 +1150,18 @@ functor
       let with_sr sr f = Storage_locks.with_instance_lock locks (s_of_sr sr) f
 
       let probe context ~dbg ~queue ~device_config ~sm_config =
-        with_dbg ~name:"SR.probe" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.probe dbg:%s" dbg ;
+        with_dbg ~name:"SR.probe" ~dbg @@ fun {log; _} ->
+        info "SR.probe dbg:%s" log ;
         Impl.SR.probe context ~dbg ~queue ~device_config ~sm_config
 
       let list _context ~dbg =
-        with_dbg ~name:"SR.list" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.list dbg:%s" dbg ;
+        with_dbg ~name:"SR.list" ~dbg @@ fun {log; _} ->
+        info "SR.list dbg:%s" log ;
         List.map fst (Host.list !Host.host)
 
       let stat context ~dbg ~sr =
-        with_dbg ~name:"SR.stat" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.stat dbg:%s sr:%s" dbg (s_of_sr sr) ;
+        with_dbg ~name:"SR.stat" ~dbg @@ fun {log; _} ->
+        info "SR.stat dbg:%s sr:%s" log (s_of_sr sr) ;
         with_sr sr (fun () ->
             match Host.find sr !Host.host with
             | None ->
@@ -1188,8 +1171,8 @@ functor
         )
 
       let scan context ~dbg ~sr =
-        with_dbg ~name:"SR.scan" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.scan dbg:%s sr:%s" dbg (s_of_sr sr) ;
+        with_dbg ~name:"SR.scan" ~dbg @@ fun {log; _} ->
+        info "SR.scan dbg:%s sr:%s" log (s_of_sr sr) ;
         with_sr sr (fun () ->
             match Host.find sr !Host.host with
             | None ->
@@ -1200,8 +1183,8 @@ functor
 
       let create context ~dbg ~sr ~name_label ~name_description ~device_config
           ~physical_size =
-        with_dbg ~name:"SR.create" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.create dbg:%s sr:%s name_label:%s" dbg (s_of_sr sr) name_label ;
+        with_dbg ~name:"SR.create" ~dbg @@ fun {log; _} ->
+        info "SR.create dbg:%s sr:%s name_label:%s" log (s_of_sr sr) name_label ;
         with_sr sr (fun () ->
             match Host.find sr !Host.host with
             | None ->
@@ -1213,19 +1196,19 @@ functor
         )
 
       let set_name_label context ~dbg ~sr ~new_name_label =
-        with_dbg ~name:"SR.set_name_label" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.set_name_label dbg:%s sr:%s new_name_label:%s" dbg (s_of_sr sr)
+        with_dbg ~name:"SR.set_name_label" ~dbg @@ fun {log; _} ->
+        info "SR.set_name_label dbg:%s sr:%s new_name_label:%s" log (s_of_sr sr)
           new_name_label ;
         Impl.SR.set_name_label context ~dbg ~sr ~new_name_label
 
       let set_name_description context ~dbg ~sr ~new_name_description =
-        with_dbg ~name:"SR.set_name_description" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.set_name_description dbg:%s sr:%s new_name_description:%s" dbg
+        with_dbg ~name:"SR.set_name_description" ~dbg @@ fun {log; _} ->
+        info "SR.set_name_description dbg:%s sr:%s new_name_description:%s" log
           (s_of_sr sr) new_name_description ;
         Impl.SR.set_name_description context ~dbg ~sr ~new_name_description
 
       let attach context ~dbg ~sr ~device_config =
-        with_dbg ~name:"SR.attach" ~dbg @@ fun {log= dbg; _} ->
+        with_dbg ~name:"SR.attach" ~dbg @@ fun {log; _} ->
         let censor_key = ["password"] in
         let device_config_str =
           String.concat "; "
@@ -1248,7 +1231,7 @@ functor
                device_config
             )
         in
-        info "SR.attach dbg:%s sr:%s device_config:[%s]" dbg (s_of_sr sr)
+        info "SR.attach dbg:%s sr:%s device_config:[%s]" log (s_of_sr sr)
           device_config_str ;
         with_sr sr (fun () ->
             match Host.find sr !Host.host with
@@ -1297,13 +1280,13 @@ functor
         )
 
       let detach context ~dbg ~sr =
-        with_dbg ~name:"SR.detach" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.detach dbg:%s sr:%s" dbg (s_of_sr sr) ;
+        with_dbg ~name:"SR.detach" ~dbg @@ fun {log; _} ->
+        info "SR.detach dbg:%s sr:%s" log (s_of_sr sr) ;
         detach_destroy_common context ~dbg ~sr Impl.SR.detach
 
       let reset _context ~dbg ~sr =
-        with_dbg ~name:"SR.reset" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.reset dbg:%s sr:%s" dbg (s_of_sr sr) ;
+        with_dbg ~name:"SR.reset" ~dbg @@ fun {log; _} ->
+        info "SR.reset dbg:%s sr:%s" log (s_of_sr sr) ;
         with_sr sr (fun () ->
             Host.remove sr !Host.host ;
             Everything.to_file !host_state_path (Everything.make ()) ;
@@ -1311,18 +1294,17 @@ functor
         )
 
       let destroy context ~dbg ~sr =
-        with_dbg ~name:"SR.destroy" ~dbg @@ fun {log= dbg; _} ->
-        info "SR.destroy dbg:%s sr:%s" dbg (s_of_sr sr) ;
+        with_dbg ~name:"SR.destroy" ~dbg @@ fun {log; _} ->
+        info "SR.destroy dbg:%s sr:%s" log (s_of_sr sr) ;
         detach_destroy_common context ~dbg ~sr Impl.SR.destroy
 
       let update_snapshot_info_src context ~dbg ~sr ~vdi ~url ~dest ~dest_vdi
           ~snapshot_pairs =
-        with_dbg ~name:"SR.update_snapshot_info_src" ~dbg
-        @@ fun {log= dbg; _} ->
+        with_dbg ~name:"SR.update_snapshot_info_src" ~dbg @@ fun {log; _} ->
         info
           "SR.update_snapshot_info_src dbg:%s sr:%s vdi:%s url:%s dest:%s \
            dest_vdi:%s snapshot_pairs:%s"
-          dbg (s_of_sr sr) (s_of_vdi vdi) url (s_of_sr dest) (s_of_vdi dest_vdi)
+          log (s_of_sr sr) (s_of_vdi vdi) url (s_of_sr dest) (s_of_vdi dest_vdi)
           (List.map
              (fun (local_snapshot, dest_snapshot) ->
                Printf.sprintf "local:%s, dest:%s" (s_of_vdi local_snapshot)
@@ -1337,12 +1319,11 @@ functor
 
       let update_snapshot_info_dest context ~dbg ~sr ~vdi ~src_vdi
           ~snapshot_pairs =
-        with_dbg ~name:"SR.update_snapshot_info_dest" ~dbg
-        @@ fun {log= dbg; _} ->
+        with_dbg ~name:"SR.update_snapshot_info_dest" ~dbg @@ fun {log; _} ->
         info
           "SR.update_snapshot_info_dest dbg:%s sr:%s vdi:%s ~src_vdi:%s \
            snapshot_pairs:%s"
-          dbg (s_of_sr sr) (s_of_vdi vdi) (s_of_vdi src_vdi.vdi)
+          log (s_of_sr sr) (s_of_vdi vdi) (s_of_vdi src_vdi.vdi)
           (List.map
              (fun (local_snapshot, src_snapshot_info) ->
                Printf.sprintf "local:%s, src:%s" (s_of_vdi local_snapshot)