diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for ghc-debug-stub +## 0.6.0.0 -- 2024-04-10 + +* Add requests for decoding cost centres and other profiling info +* Update support for GHC as of 9.11.20240410 + ## 0.5.0.0 -- 2023-06-06 * Add support for debugging over a TCP socket (`withGhcDebugTCP`) diff --git a/cbits/stub.cpp b/cbits/stub.cpp --- a/cbits/stub.cpp +++ b/cbits/stub.cpp @@ -92,7 +92,11 @@ CMD_BLOCKS = 14, CMD_BLOCK = 15, CMD_FUN_BITMAP = 16, - CMD_GET_SRT = 17 + CMD_GET_SRT = 17, + CMD_GET_CCS = 18, + CMD_GET_CC = 19, + CMD_GET_INDEX_TABLE = 20, + CMD_GET_CSS_MAIN = 21 }; enum response_code { @@ -208,8 +212,6 @@ trace("finishing with code: %d\n", status); this->flush(status); } - - Response(Response &x) = delete; }; static bool paused = false; @@ -220,7 +222,7 @@ extern "C" -void pause_mutator() { +pid_t pause_mutator() { trace("pausing mutator\n"); pid_t pid; if (use_fork){ @@ -238,9 +240,10 @@ } else { int status = 0; - wait(&status); + waitpid(pid,&status,0); use_fork = false; } + return pid; } extern "C" @@ -399,10 +402,36 @@ case CMD_VERSION: uint32_t ver_payload; uint32_t ver_payload1; + uint8_t ver_payload2; + uint8_t ver_payload3; ver_payload=htonl(__GLASGOW_HASKELL__) ; ver_payload1=htonl(__GLASGOW_HASKELL_PATCHLEVEL1__) ; + if (rts_isProfiled()) { + if (RtsFlags.ProfFlags.doHeapProfile == 0) { + ver_payload2 = 1; +#if defined(PROFILING) + // newer versions of GHC have doingRetainerProfiling(), doingLDVProfilingFunctions etc. + // but we don't use them because they aren't exported in GHCs <= 9.8. + } else if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER || RtsFlags.ProfFlags.retainerSelector != NULL) { + ver_payload2 = 2; + } else if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV || RtsFlags.ProfFlags.bioSelector != NULL) { + ver_payload2 = 3; +#if defined(GHC_SUPPORTS_ERAS) + } else if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_ERA || RtsFlags.ProfFlags.eraSelector != NULL) { + ver_payload2 = 4; +#endif +#endif + } else { + ver_payload2 = 5; + } + } else { + ver_payload2 = 0; + } + ver_payload3=TABLES_NEXT_TO_CODE; resp.write(ver_payload); resp.write(ver_payload1); + resp.write(ver_payload2); + resp.write(ver_payload3); resp.finish(RESP_OKAY); break; @@ -414,8 +443,10 @@ resp.finish(RESP_ALREADY_PAUSED); } else { trace("fork?: %s\n", use_fork ? "yes" : "no"); - pause_mutator(); - resp.finish(RESP_OKAY); + if(pause_mutator() == 0) { + // only respond in the child + resp.finish(RESP_OKAY); + } } break; @@ -606,7 +637,7 @@ case CMD_POLL: - r_poll_pause_resp = &resp; + r_poll_pause_resp = new Response(resp); // NOTE: Don't call finish so that the process blocks waiting for // a response. We will send the response when the process pauses. break; @@ -630,6 +661,66 @@ // resp.finish(RESP_OKAY); // break; + case CMD_GET_CCS: + { + trace("GET_CCS\n"); + CostCentreStack *ptr = (CostCentreStack *) p.get(); + resp.write((uint64_t)ptr -> ccsID); + resp.write((uint64_t)ptr -> cc); + resp.write((uint64_t)ptr -> prevStack); + resp.write((uint64_t)ptr -> indexTable); + resp.write((uint64_t)ptr -> root); + resp.write((uint64_t)ptr -> depth); + resp.write((uint64_t)ptr -> scc_count); + resp.write((uint64_t)ptr -> selected); + resp.write((uint64_t)ptr -> time_ticks); + resp.write((uint64_t)ptr -> mem_alloc); + resp.write((uint64_t)ptr -> inherited_alloc); + resp.write((uint64_t)ptr -> inherited_ticks); + resp.finish(RESP_OKAY); + break; + } + case CMD_GET_CC: + { + trace("GET_CC\n"); + CostCentre *ptr = (CostCentre *) p.get(); + resp.write((uint64_t)ptr -> ccID); + write_string(resp, ptr -> label); + write_string(resp, ptr -> module); + write_string(resp, ptr -> srcloc); + resp.write((uint64_t)ptr -> mem_alloc); + resp.write((uint64_t)ptr -> time_ticks); + resp.write((uint64_t)ptr -> is_caf); + resp.write((uint64_t)ptr -> link); + resp.finish(RESP_OKAY); + break; + } + case CMD_GET_INDEX_TABLE: + { + trace("CMD_GET_INDEX_TABLE\n"); +#if defined(PROFILING) + IndexTable_ *ptr = (IndexTable_ *) p.get(); + resp.write((uint64_t)ptr -> cc); + resp.write((uint64_t)ptr -> ccs); + resp.write((uint64_t)ptr -> next); + resp.write((uint8_t)ptr -> back_edge); + resp.finish(RESP_OKAY); +#else /* !PROFILING */ + resp.finish(RESP_BAD_COMMAND); +#endif /* PROFILING */ + break; + } + case CMD_GET_CSS_MAIN: + { + trace("GET_CSS_MAIN"); +#if defined(PROFILING) + resp.write((uint64_t) CCS_MAIN); + resp.finish(RESP_OKAY); +#else /* !PROFILING */ + resp.finish(RESP_BAD_COMMAND); +#endif /* PROFILING */ + break; + } case CMD_CON_DESCR: { trace("CON_DESCR\n"); @@ -646,17 +737,28 @@ trace("SOURCE_INFO\n"); StgInfoTable *info_table = (StgInfoTable *) p.get(); trace("INFO: %p\n", info_table); - InfoProvEnt * elt = lookupIPE(info_table); + + trace("ELT: %p\n", info_table); +#if MIN_VERSION_GLASGOW_HASKELL(9,11,20240401,0) + InfoProvEnt elt; + int elt_res = lookupIPE(info_table, &elt); +#else + InfoProvEnt * elt = lookupIPE(info_table); + int elt_res = (bool) elt; +#endif uint32_t len_payload; - if (!elt){ + if (!elt_res){ trace("NOT FOUND\n"); resp.write((uint32_t) 0); } else { +#if MIN_VERSION_GLASGOW_HASKELL(9,11,20240401,0) + InfoProv ip = elt.prov; +#else InfoProv ip = elt->prov; +#endif trace("FOUND\n"); - size_t len = 6; write_size(resp, len); diff --git a/ghc-debug-stub.cabal b/ghc-debug-stub.cabal --- a/ghc-debug-stub.cabal +++ b/ghc-debug-stub.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-debug-stub -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Functions for instrumenting your application so the heap can be analysed with ghc-debug-common. description: Functions for instrumenting your application so the heap can @@ -20,14 +20,19 @@ Default: False Manual: True +flag eras + Description: Enable eras + Default: False + Manual: True + library exposed-modules: GHC.Debug.Stub hs-source-dirs: src build-depends: base >=4.16 && < 5 , directory ^>= 1.3 - , filepath ^>= 1.4 - , ghc-prim >= 0.8 && < 0.11 - , ghc-debug-convention == 0.5.0.0 + , filepath >= 1.4 && < 1.6 + , ghc-prim >= 0.8 && < 0.12 + , ghc-debug-convention == 0.6.0.0 default-language: Haskell2010 cxx-sources: cbits/stub.cpp, cbits/socket.cpp, cbits/trace.cpp cxx-options: -std=gnu++11 -pthread -O3 -g3 -DTHREADED_RTS @@ -35,4 +40,6 @@ cpp-options: -DTHREADED_RTS if flag(trace) cxx-options: -DTRACE + if flag(eras) + cxx-options: -DGHC_SUPPORTS_ERAS