Support for printing runtime variables in the debugger

src/astlowering/LoweringUtils.ml

@@ -58,3 +58,8 @@ let rep_typ rep =
       fail1 ~kind:"GenLlvm: rep_typ: not type annotated." ?inst:None rep.ea_loc
 
 let id_typ id = rep_typ (Identifier.get_rep id)
+
+(* Can this type hold a runtime value? (i.e., is not a closure) *)
+let is_runtime_value_type = function
+  | PrimType _ | Unit | Address _ | ADT _ | MapType _ -> true
+  | FunType _ | PolyFun _ | TypeVar _ -> false

src/astlowering/LoweringUtils.mli

@@ -48,3 +48,5 @@ val rep_typ :
 val id_typ :
   UncurriedSyntax.Uncurried_Syntax.eannot Identifier.t ->
   (UncurriedSyntax.Uncurried_Syntax.typ, scilla_error list) result
+
+val is_runtime_value_type : UncurriedSyntax.Uncurried_Syntax.typ -> bool

src/llvmgen/DebugInfo.ml

@@ -23,13 +23,15 @@
  *)
 
 open Core_kernel
+open Result.Let_syntax
 open Scilla_base
 open MonadUtil
 module Literal = Literal.GlobalLiteral
 module Type = Literal.LType
 module Identifier = Literal.LType.TIdentifier
 open UncurriedSyntax
-open ClosuredSyntax
+open TypeLLConv
+open LLGenUtils
 
 type scilla_dibuilder = DIEnabled of Llvm_debuginfo.lldibuilder | DIDisabled
 
@@ -67,9 +69,8 @@ let gen_common dibuilder llmod filename =
         Llvm_debuginfo.dibuild_create_compile_unit dibuilder
           Llvm_debuginfo.DWARFSourceLanguageKind.C89 ~file_ref:file_di
           ~producer:"Scilla Compiler" ~is_optimized:false ~flags:""
-          ~runtime_ver:0 ~split_name:""
-          Llvm_debuginfo.DWARFEmissionKind.LineTablesOnly ~dwoid:0
-          ~di_inlining:false ~di_profiling:false ~sys_root:"" ~sdk:""
+          ~runtime_ver:0 ~split_name:"" Llvm_debuginfo.DWARFEmissionKind.Full
+          ~dwoid:0 ~di_inlining:false ~di_profiling:false ~sys_root:"" ~sdk:""
       in
       let _ =
         Llvm_debuginfo.dibuild_create_module dibuilder ~parent_ref:cu_di
@@ -79,27 +80,30 @@ let gen_common dibuilder llmod filename =
       ()
   | DIDisabled -> ()
 
+let create_file_di dibuilder (loc : ErrorUtils.loc) =
+  Llvm_debuginfo.dibuild_create_file dibuilder
+    ~filename:(Filename.basename loc.fname)
+    ~directory:(Filename.dirname loc.fname)
+
+let flags_zero = Llvm_debuginfo.diflags_get Llvm_debuginfo.DIFlag.Zero
+
 let gen_fun_loc dibuilder ?(is_local_to_unit = true) name (loc : ErrorUtils.loc)
     fllval =
   match dibuilder with
   | DIEnabled dibuilder ->
       let void_dty =
         Llvm_debuginfo.dibuild_create_unspecified_type dibuilder ~name:"void"
       in
-      let flags = Llvm_debuginfo.diflags_get Llvm_debuginfo.DIFlag.Zero in
-      let file =
-        Llvm_debuginfo.dibuild_create_file dibuilder
-          ~filename:(Filename.basename loc.fname)
-          ~directory:(Filename.dirname loc.fname)
-      in
+      let file = create_file_di dibuilder loc in
       let ty =
         Llvm_debuginfo.dibuild_create_subroutine_type dibuilder ~file
-          ~param_types:[| void_dty |] flags
+          ~param_types:[| void_dty |] flags_zero
       in
       let sp =
         Llvm_debuginfo.dibuild_create_function dibuilder ~scope:file ~name
           ~linkage_name:name ~file ~line_no:loc.lnum ~ty ~is_local_to_unit
-          ~is_definition:true ~scope_line:loc.lnum ~flags ~is_optimized:false
+          ~is_definition:true ~scope_line:loc.lnum ~flags:flags_zero
+          ~is_optimized:false
       in
       let () = Llvm_debuginfo.set_subprogram fllval sp in
       sp
@@ -142,3 +146,96 @@ let create_sub_scope dibuilder scope (loc : ErrorUtils.loc) =
                scope"
             ?inst:None loc)
   | DIDisabled -> pure @@ Llvm_debuginfo.llmetadata_null ()
+
+(* Boxed types are represented with a pointer while unboxed
+   types are represented as "basic type". *)
+let create_ditype dl llmod dibuilder sty =
+  let llctx = Llvm.module_context llmod in
+  let%bind llty = genllvm_typ_fst llmod sty in
+  let name = Uncurried_Syntax.pp_typ sty in
+  let basety =
+    Llvm_debuginfo.dibuild_create_basic_type dibuilder ~name
+      ~size_in_bits:(llsizeof dl llty) ~encoding:0 flags_zero
+  in
+  match%bind is_boxed_typ sty with
+  | true ->
+      pure
+      @@ Llvm_debuginfo.dibuild_create_pointer_type dibuilder ~pointee_ty:basety
+           ~size_in_bits:(Llvm_target.DataLayout.pointer_size dl)
+           ~align_in_bits:
+             (Llvm_target.DataLayout.abi_align (void_ptr_type llctx) dl)
+           ~name ~address_space:0
+  | false -> pure basety
+
+let dibuild_insert_declare_after dibuilder ~storage ~var_info ~expr ~location
+    ~instr =
+  match Llvm.instr_succ instr with
+  | At_end block ->
+      Llvm_debuginfo.dibuild_insert_declare_at_end dibuilder ~storage ~var_info
+        ~expr ~location ~block
+  | Before instr ->
+      Llvm_debuginfo.dibuild_insert_declare_before dibuilder ~storage ~var_info
+        ~expr ~location ~instr
+
+let declare_variable dl llmod dibuilder scope v valloc =
+  let%bind vty = LoweringUtils.id_typ v in
+  match (dibuilder, Llvm.classify_value valloc) with
+  | DIEnabled dibuilder, Instruction opcode
+    when Base.Poly.(opcode = Alloca) && LoweringUtils.is_runtime_value_type vty
+    ->
+      let loc = (Identifier.get_rep v).ea_loc in
+      let file = create_file_di dibuilder loc in
+      let context = Llvm.module_context llmod in
+      let%bind ty = create_ditype dl llmod dibuilder vty in
+      let var_info =
+        Llvm_debuginfo.dibuild_create_auto_variable dibuilder ~scope
+          ~name:(Identifier.as_string v) ~file ~line:loc.lnum
+          ~always_preserve:false ~align_in_bits:0 ~ty flags_zero
+      in
+      let expr = Llvm_debuginfo.dibuild_expression dibuilder [||] in
+      let location =
+        Llvm_debuginfo.dibuild_create_debug_location context ~line:loc.lnum
+          ~column:loc.cnum ~scope
+      in
+      let _ =
+        dibuild_insert_declare_after dibuilder ~storage:valloc ~var_info ~expr
+          ~location ~instr:valloc
+      in
+      pure ()
+  | _ -> pure ()
+
+let declare_parameter dl llmod dibuilder scope p parg entry_block =
+  let%bind pty = LoweringUtils.id_typ p in
+  match (dibuilder, Llvm.classify_value parg) with
+  | DIEnabled dibuilder, Argument when LoweringUtils.is_runtime_value_type pty
+    ->
+      let loc = (Identifier.get_rep p).ea_loc in
+      let file = create_file_di dibuilder loc in
+      let context = Llvm.module_context llmod in
+      let%bind ty = create_ditype dl llmod dibuilder pty in
+      let var_info =
+        (* Note: dibuild_create_parameter_variable doesn't work. *)
+        Llvm_debuginfo.dibuild_create_auto_variable dibuilder ~scope
+          ~name:(Identifier.as_string p) ~file ~line:loc.lnum
+          ~always_preserve:false ~align_in_bits:0 ~ty flags_zero
+      in
+      let expr = Llvm_debuginfo.dibuild_expression dibuilder [||] in
+      let location =
+        Llvm_debuginfo.dibuild_create_debug_location context ~line:loc.lnum
+          ~column:loc.cnum ~scope
+      in
+      (* Insert an alloca and copy the parameter to it. Use that as the
+         location. LLVM doesn't seem to capture it otherwise. *)
+      let builder = Llvm.builder_at context (Llvm.instr_begin entry_block) in
+      let storage =
+        Llvm.build_alloca (Llvm.type_of parg)
+          (LoweringUtils.tempname (Identifier.as_string p))
+          builder
+      in
+      let store_inst = Llvm.build_store parg storage builder in
+      let _ =
+        dibuild_insert_declare_after dibuilder ~storage ~var_info ~expr
+          ~location ~instr:store_inst
+      in
+      pure ()
+  | _ -> pure ()

src/llvmgen/GenLlvm.ml

@@ -1025,6 +1025,7 @@ let rec genllvm_stmts genv builder dibuilder discope stmts =
       ~kind:("GenLlvm: genllvm_stmts: internal error: " ^ msg)
       ?inst:None loc
   in
+  let dl = Llvm_target.DataLayout.of_string (Llvm.data_layout llmod) in
 
   (* Check that the LLVM struct type for an env matches the list of env vars we know. *)
   let validate_envvars_type env_ty evars =
@@ -1050,6 +1051,9 @@ let rec genllvm_stmts genv builder dibuilder discope stmts =
             let%bind xll =
               build_alloca xty_ll (Identifier.as_string x) builder
             in
+            let%bind () =
+              DebugInfo.declare_variable dl llmod dibuilder discope x xll
+            in
             pure @@ { accenv with llvals = (x, Local xll) :: accenv.llvals }
         | LibVarDecl v ->
             let%bind vty_ll = id_typ_ll llmod v in
@@ -1756,7 +1760,7 @@ let genllvm_closures dibuilder llmod tydescrs tidxs topfuns =
     forallM fdecl_cr_l ~f:(fun ((fname, f), cr) ->
         let fid = !(cr.thisfun).fname in
         (* The function f doesn't have a body yet, so insert a basic block. *)
-        let _ = Llvm.append_block ctx "entry" f in
+        let entry_block = Llvm.append_block ctx "entry" f in
         let builder = Llvm.builder_at_end ctx (Llvm.entry_block f) in
         let sfdef_args = !(cr.thisfun).fargs in
         let f_params = Llvm.params f in
@@ -1781,10 +1785,10 @@ let genllvm_closures dibuilder llmod tydescrs tidxs topfuns =
               (Identifier.get_rep fid).ea_loc
         in
         (* Now bind each function argument. *)
-        let%bind genv_args, _ =
+        let%bind genv_args, _, params_dbg =
           foldrM sfdef_args
-            ~init:(genv_retp, List.length sfdef_args - 1)
-            ~f:(fun (accum_genv, idx) (varg, sty) ->
+            ~init:(genv_retp, List.length sfdef_args - 1, [])
+            ~f:(fun (accum_genv, idx, accum_dbgvals) (varg, sty) ->
               let%bind arg_llval = array_get f_params (args_begin + idx) in
               let%bind sty_llty = genllvm_typ_fst llmod sty in
               let arg_mismatch_err =
@@ -1818,12 +1822,24 @@ let genllvm_closures dibuilder llmod tydescrs tidxs topfuns =
                     accum_genv with
                     llvals = (varg, FunArg arg_llval') :: accum_genv.llvals;
                   },
-                  idx - 1 ))
+                  idx - 1,
+                  (varg, arg_llval) :: accum_dbgvals ))
         in
         let md_subprogram = DebugInfo.gen_fun dibuilder !(cr.thisfun).fname f in
         (* We now have the environment to generate the function body. *)
-        genllvm_block genv_args builder dibuilder md_subprogram
-          !(cr.thisfun).fbody)
+        let%bind () =
+          genllvm_block genv_args builder dibuilder md_subprogram
+            !(cr.thisfun).fbody
+        in
+        (* Generate debug values for the parameters. *)
+        let%bind () =
+          forallM
+            ~f:(fun (vparam, llparam) ->
+              DebugInfo.declare_parameter dl llmod dibuilder md_subprogram
+                vparam llparam entry_block)
+            params_dbg
+        in
+        pure ())
   in
 
   pure genv_fdecls
@@ -1977,6 +1993,14 @@ let genllvm_component dibuilder genv llmod comp =
       genllvm_block ~nosucc_retvoid:true genv_args builder dibuilder di_fun
         comp.comp_body
     in
+    (* Generate debug values for the parameters. *)
+    let%bind () =
+      forallM
+        ~f:(fun ((vparam, _, _), llparam) ->
+          DebugInfo.declare_parameter dl llmod dibuilder di_fun vparam llparam
+            (Llvm.entry_block f))
+        params_args
+    in
     (* Bind the component name for later use. *)
     let genv_comp =
       { genv with llvals = (comp.comp_name, FunDecl f) :: genv.llvals }