diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ghc-debug-stub + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Ben Gamari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ben Gamari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/LargeThunk.hs b/LargeThunk.hs new file mode 100644 --- /dev/null +++ b/LargeThunk.hs @@ -0,0 +1,172 @@ + +{-# Language BangPatterns #-} +{-# Language DeriveAnyClass #-} +{-# Language DerivingStrategies #-} +{-# Language DuplicateRecordFields #-} +{-# LANGUAGE DeriveGeneric #-} +{-# Language GeneralizedNewtypeDeriving #-} +{-# Language LambdaCase #-} +{-# Language ParallelListComp #-} + +import System.Environment (getArgs) +import Data.List (foldl', maximumBy, permutations, sortBy) +import Data.Function +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Control.DeepSeq +import GHC.Generics (Generic) + +import GHC.Debug.Stub + +import Debug.Trace + +data MovieDB = MovieDB + { users :: !(Map UserID User) + , movies :: !(Map MovieID Movie) + , ratings :: ![Rating] + } + deriving stock (Generic) + deriving anyclass (NFData) + +newtype UserID = UserID Int + deriving newtype (Eq,Ord,Num,Enum) + deriving stock (Generic) + deriving anyclass (NFData) + +data User = User + { name :: !String + , trust :: !Double -- ^ How trusted this user is. In range [0,1]. Higher is more trustworthy. + } + deriving stock (Generic) + deriving anyclass (NFData) + +newtype MovieID = MovieID Int + deriving newtype (Eq,Ord,Num,Enum) + deriving stock (Generic, Show) + deriving anyclass (NFData) + +type Movie = String + +data Rating = Rating + { user :: !UserID -- ^ Who rated this movie. + , movie :: !MovieID -- ^ Movie being rated. + , rating :: !Double -- ^ Rating In range [1,10]. Higher is better. + } + deriving stock (Generic) + deriving anyclass (NFData) + +main :: IO () +main = withGhcDebug $ do + -- Parse DB size from arguments + [nUsersStr, nMoviesStr, nRatingsStr] <- getArgs + let + nUsers = read nUsersStr + nMovies = read nMoviesStr + nRatings = read nRatingsStr + + -- Create the DB + putStrLn $ "Creating the DB with size (" + ++ show nUsers ++ " users," + ++ show nMovies ++ " movies," + ++ show nRatings ++ " ratings)" + let !movieDB = let + users = M.fromList + $ zip + [0..] + [ User name trust + | name <- take nUsers + $ fmap unwords + $ cycle + $ permutations ["abcdefghijklmnopqrstuvwxyz"] + | trust <- cycle [0.0, 0.1 .. 1.0] + ] + + movies = M.fromList + $ zip + [0..] + (take nMovies + $ fmap unwords + $ cycle + $ permutations ["The", "Cat", "In", "The", "Hat", "House", "Mouse", "Story", "Legend"] + ) + + ratings = take nRatings + $ cycle + $ zipWith3 + Rating + (cycle (M.keys users)) + (cycle (M.keys movies)) + (cycle [1.0, 1.01 .. 9]) + + in force $ MovieDB + { users = users + , movies = movies + , ratings = ratings + } + + do + let msg = "DB created." + traceEventIO msg + putStrLn msg + putStrLn "Hit ENTER to continue." + _ <- getLine + + + -- A single user's favorite movie. + do + let + (userIDA, userA) = M.assocs (users movieDB) !! 0 + favoriteMovieID + = snd + $ maximumBy (compare `on` fst) + [ (rating, movieID) + | Rating userIDB movieID rating <- ratings movieDB + , userIDA == userIDB + ] + + putStrLn $ "User '" ++ name userA ++ "''s favorite movie: " ++ (movies movieDB M.! favoriteMovieID) + + -- Top rated movies + -- each rating is weighted by the user's trust score. + do + let + weight_movies = foldl' go M.empty (ratings movieDB) + + go :: Map MovieID (Double, Double) -> Rating -> Map MovieID (Double, Double) + go weights (Rating userID movieID score) = M.alter + (\case + Nothing -> Just (userTrust * score, userTrust) + Just (weightedScore, weight) -> let + weightedScore' = weightedScore + (userTrust * score) + weight' = weight + userTrust + in Just (weightedScore', weight') + ) + movieID + weights + where + userTrust = trust ((users movieDB) M.! userID) + + saveClosures [Box weight_movies] + putStrLn "Pausing" + getLine + + -- (Movie ID, rating) sorted by rating. + let movieRatings :: [(MovieID, Double)] + movieRatings + = sortBy (compare `on` snd) + $ fmap (\(movieID, (weightedRating, weight)) -> (movieID, weightedRating / weight)) + $ filter (\(_, (_, weight)) -> weight /= 0) + $ M.assocs weight_movies + + putStrLn "Top 10 movies:" + putStrLn $ unlines $ fmap show $ take 10 $ reverse $ movieRatings + + traceEventIO "Top 10 movies done." + putStrLn "Hit ENTER to continue." + _ <- getLine + + touch movieDB + +{-# NOINLINE touch #-} +touch :: a -> IO () +touch a = return () diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Debug.Stub +import Control.Concurrent +import System.Mem.StableName +import Foreign.StablePtr +import System.Mem +import qualified Data.Sequence +import qualified Data.HashMap.Strict +import qualified Data.Map as M +--import qualified Data.Map.Strict as M + +loop :: IO () +loop = go 0 + where + go 5 = pause >> go 11 + go x = print x >> threadDelay 1000000 >> go (x + 1) + go 100 = return () + +data A = A Int deriving Show + +v :: Int +v = 5 +{-# NOINLINE v #-} + +type TestMap = M.Map String Int + + +main :: IO () +main = withGhcDebug $ do +-- print "Enter Name" +-- name <- getLine +-- print "Enter Name" +-- name2 <- getLine +-- let !m = M.insert name (length name) (M.insert name2 (length name2) M.empty) + + --let !y = Data.Sequence.fromList [1..5] + let !y = [1..1000000] + print (length y) + performGC +-- saveClosures [Box y] + saveClosures [Box y] + print "start" + loop + print y + + + + diff --git a/cbits/parser.h b/cbits/parser.h new file mode 100644 --- /dev/null +++ b/cbits/parser.h @@ -0,0 +1,35 @@ +#pragma once + +#include + +class Parser { + private: + const char *buf; + size_t remaining; + + public: + inline Parser(const char *buf, size_t len) : buf(buf), remaining(len) { } + + class EndOfInput {}; + + inline bool end() const { + return this->remaining == 0; + } + + inline size_t available() const { + return this->remaining; + } + + template + T get() { + if (this->remaining < sizeof(T)) { + throw EndOfInput(); + } else { + T x = *(T *) this->buf; + this->buf += sizeof(T); + this->remaining -= sizeof(T); + return x; + } + } +}; + diff --git a/cbits/socket.cpp b/cbits/socket.cpp new file mode 100644 --- /dev/null +++ b/cbits/socket.cpp @@ -0,0 +1,38 @@ +#include "socket.h" +#include +#include + +SocketError::SocketError(int err_no, std::string what) + : err_no(err_no), what(what) { } + +Socket::Socket(int fd) + : fd(fd) { } + +void Socket::read(char *buf, size_t len) { + while (len > 0) { + ssize_t ret = ::read(this->fd, (void *) buf, len); + if (ret < 0) { + throw SocketError(errno, "read"); + } + len -= ret; + buf += ret; + } +} + +void Socket::write(const char *buf, size_t len) { +// debugBelch("WRITING %s %d\n", buf, len); +// for (int i = 0; i < len; i++) +// { +// debugBelch("%02X", buf[i]); +// } +// debugBelch("\n"); + while (len > 0) { + ssize_t ret = ::write(this->fd, buf, len); + if (ret < 0) { + throw SocketError(errno, "write"); + } + len -= ret; + buf += ret; + } +} + diff --git a/cbits/socket.h b/cbits/socket.h new file mode 100644 --- /dev/null +++ b/cbits/socket.h @@ -0,0 +1,22 @@ +#pragma once + +#include +#include + +class SocketError { + private: + int err_no; + std::string what; + public: + SocketError(int err_no, std::string what); +}; + +class Socket { + private: + const int fd; + public: + Socket(int fd); + /* read len bytes into the given buffer */ + void read(char *buf, size_t len); + void write(const char *buf, size_t len); +}; diff --git a/cbits/stub.cpp b/cbits/stub.cpp new file mode 100644 --- /dev/null +++ b/cbits/stub.cpp @@ -0,0 +1,733 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + + +#include +#include + +#include +#include "socket.h" +#include "trace.h" +#include "parser.h" +#include +#include + +#if !defined(THREADED_RTS) +#error You must use a patched version of cabal-install which includes - https://github.com/haskell/cabal/pull/7183 +#endif + +// This used to be 4096 but that was too small +#define MAX_CMD_SIZE 10000 + +#define WORD_SIZE sizeof(unsigned long) +#define INFO_TABLE_SIZE sizeof(StgInfoTable) + +/* + * Wire format: + * + * Request from debugger consists of + * - uint32_t frame length + * - uint16_t command + * - payload + * + * Response consists of one of more frames of the form + * - uint32_t frame length + * - uint16_t response_code + * - payload + * + * Payload may be split across multiple frames + * + */ + +enum commands { + CMD_VERSION = 1, + CMD_PAUSE = 2, + CMD_RESUME = 3, + CMD_GET_ROOTS = 4, + CMD_GET_CLOSURES = 5, + CMD_GET_INFO_TABLES = 6, + CMD_GET_BITMAP = 7, + CMD_POLL = 8, + CMD_SAVED_OBJECTS = 9, + CMD_FIND_PTR = 10, + CMD_CON_DESCR = 11, + CMD_SOURCE_INFO = 12, + CMD_BLOCKS = 14, + CMD_BLOCK = 15, + CMD_FUN_BITMAP = 16 +}; + +enum response_code { + RESP_OKAY = 0, + RESP_OKAY_CONTINUES = 1, + // Error responses + RESP_BAD_COMMAND = 0x100, + RESP_BAD_STACK = 0x104, + RESP_ALREADY_PAUSED = 0x101, + RESP_NOT_PAUSED = 0x102, + RESP_NO_RESUME = 0x103, +}; + +extern "C" Capability **capabilities; + +const int maxSavedObjects = 20; + +// Whether to fork on pause or not. +static bool use_fork = false; + +static struct savedObjectsState { + StgWord n_objects; + StgStablePtr objects[maxSavedObjects]; +} g_savedObjectState; + +class Response { + private: + Socket &sock; + size_t buf_size; + char *const buf; + char *tail; + + struct Header { + uint32_t len; + uint16_t status; // 0 == success + }; + + void flush(response_code status) { + if (status != RESP_OKAY_CONTINUES || this->tail != this->buf + sizeof(Header)) { + size_t len = this->tail - this->buf; + trace("LEN: %lu", len); + uint32_t len_payload; + uint16_t status_payload; + len_payload=htonl(len); + status_payload = htons(status); + trace("STATUS: %d\n", status); + // Header is the length + this->sock.write((char *) &len_payload, sizeof(uint32_t)); + // Then status + this->sock.write((char *) &status_payload, sizeof(uint16_t)); + // then the body, usually empty + trace("FLUSHING(%lu)( ", len); + for (int i = 0; i < len; i++) + { + trace("%02X", buf[i]); + } + trace("\n"); + this->sock.write(this->buf, len); + this->tail = this->buf; + } + } + + public: + Response(Socket &sock) : Response(sock, 1024) { } + + Response(Socket &sock, size_t buf_size) + : sock(sock), + buf_size(buf_size), + buf(new char[buf_size]), + tail(buf) + { } + + ~Response() { + delete[] this->buf; + } + + template + void write(T x) { + write((const char *) &x, sizeof(T)); + } + + void write(const char *buf, size_t len) { + if (len > this->buf_size) { + trace("LEN TOO BIG %lu, %lu\n", len, this->buf_size); + this->flush(RESP_OKAY_CONTINUES); + uint32_t len_payload; + uint16_t status_payload; + len_payload=htonl(len); + status_payload = htons(RESP_OKAY_CONTINUES); + // Header is the length + this->sock.write((char *) &len_payload, sizeof(uint32_t)); + // Then status + this->sock.write((char *) &status_payload, sizeof(uint16_t)); + trace("WROTE HEADER\n"); + this->sock.write(buf, len); + trace("WRITING BIG CLOSURE\n"); + } else { + if (this->tail + len >= this->buf + this->buf_size) { + trace("FLUSHING: "); + this->flush(RESP_OKAY_CONTINUES); + } + + //trace("ADDING(%lu)( ", len); + //for (int i = 0; i < len; ++i) std::cout << std::hex << (int) buf[i] << ' '; + //std::cout << std::dec << std::endl ; + memcpy(this->tail, buf, len); + this->tail += len; + } + } + + void finish(enum response_code status) { + trace("FINISH: %d\n", status); + this->flush(status); + } + + Response(Response &x) = delete; +}; + +static bool paused = false; +static PauseToken * r_paused; +static Response * r_poll_pause_resp = NULL; + +static StgStablePtr rts_saved_closure = NULL; + + +extern "C" +void pause_mutator() { + pid_t pid; + if (use_fork){ + pid = fork(); + } else { + pid = 0; + } + // Only pause the child process, the parent blocks until the child has finished. + if (pid == 0){ + r_paused = rts_pause(); + if (r_poll_pause_resp != NULL){ + r_poll_pause_resp->finish(RESP_OKAY); + } + paused = true; + } + else { + int status = 0; + wait(&status); + use_fork = false; + } +} + +extern "C" +void resume_mutator() { + //trace("Resuming %p %p\n", r_paused.pausing_task, r_paused.capabilities); + if (use_fork){ + // Exit, the parent is blocked until we are finished. + exit(0); + } else { + rts_resume(r_paused); + paused = false; + } +} + + +void collect_threads(std::function f) { + for (int g=0; g < RtsFlags.GcFlags.generations; g++) { + StgTSO *tso = generations[g].threads; + while (tso != END_TSO_QUEUE) { + f(tso); + tso = tso->global_link; + } + } +} + +// helper evac_fn +void evac_fn_helper(void *user, StgClosure **root) { + std::function *f = static_cast*>(user); + (*f)(*root); +} + +void collect_threads_callback(void *user, StgTSO * tso){ + ((Response *) user)->write((uint64_t) tso); +} + +void collect_misc_callback(void *user, StgClosure * clos){ + ((Response *) user)->write((uint64_t) clos); +} + +void inform_callback(void *user, PauseToken * p){ + ((Response *) user)->finish(RESP_OKAY); + r_paused = p; + //trace("Informed %p %p\n", r_paused.pausing_task, r_paused.capabilities); + paused = true; +} + +static void write_large_bitmap(Response& resp, StgLargeBitmap *large_bitmap, StgWord size) { + uint32_t b = 0; + uint32_t size_payload; + size_payload=htonl(size); + trace("SIZE %lu", size); + resp.write((uint32_t) size_payload); + + for (uint32_t i = 0; i < size; b++) { + StgWord bitmap = large_bitmap->bitmap[b]; + uint32_t j = stg_min(size-i, BITS_IN(W_)); + i += j; + for (; j > 0; j--) { + resp.write((uint8_t) !(bitmap & 1)); + bitmap = bitmap >> 1; + } + } +} + +static void write_small_bitmap(Response& resp, StgWord bitmap, StgWord size) { + uint32_t i = 0; + + // Small bitmap + uint32_t size_payload; + size_payload=htonl(size); + trace("SIZE %lu", size); + resp.write((uint32_t) size_payload); + while (size > 0) { + resp.write((uint8_t) ! (bitmap & 1)); + bitmap = bitmap >> 1; + size--; + } +} + +static void write_fun_bitmap(Response& resp, StgWord size, StgClosure * fun){ + + const StgFunInfoTable *fun_info; + fun_info = get_fun_itbl(UNTAG_CONST_CLOSURE(fun)); + switch (fun_info->f.fun_type) { + case ARG_GEN: + write_small_bitmap + (resp, BITMAP_BITS(fun_info->f.b.bitmap), size); + break; + case ARG_GEN_BIG: + write_large_bitmap(resp, GET_FUN_LARGE_BITMAP(fun_info), size); + break; + default: + write_small_bitmap(resp, BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]), size); + break; + } +} + + +static void write_string(Response& resp, const char * s){ + uint32_t len_payload; + len_payload=htonl(strlen(s)); + resp.write(len_payload); + trace("SIZE: %lu", strlen(s)); + uint32_t i; + trace("WRITING: %s\n", s); + for (i = 0; i < strlen(s); i++){ + resp.write(s[i]); + } +} + + +static void write_block(Response * resp, bdescr * bd){ + resp->write(bd->flags); + resp->write(bd->start); + uint32_t len_payload = htonl(BLOCK_SIZE * bd->blocks); + resp->write(len_payload); + resp->write((const char *) bd->start, BLOCK_SIZE * bd->blocks); +} + +static void write_blocks(Response * resp, bdescr * bd){ + for (; bd != NULL; bd = bd->link){ + write_block(resp, bd); + } +} + +void list_blocks_callback(void *user, bdescr * bd){ + write_blocks((Response *) user, bd); +} + +/* return non-zero on error */ +static int handle_command(Socket& sock, const char *buf, uint32_t cmd_len) { + trace("HANDLE: %d\n", cmd_len); + Parser p(buf, cmd_len); + Response resp(sock); + trace("P %lu\n", p.available()); + uint32_t cmd = ntohl(p.get()); + trace("CMD: %d\n", cmd); + switch (cmd) { + case CMD_VERSION: + uint32_t ver_payload; + ver_payload=htonl(0); + resp.write(ver_payload); + resp.finish(RESP_OKAY); + break; + + case CMD_PAUSE: + use_fork = (bool)ntohl(p.get()); + trace("PAUSE: %d", paused); + trace("PAUSE(FORK): %d", use_fork); + if (paused) { + trace("ALREADY"); + resp.finish(RESP_ALREADY_PAUSED); + } else { + pause_mutator(); + resp.finish(RESP_OKAY); + } + break; + + case CMD_RESUME: + if (!paused) { + resp.finish(RESP_NOT_PAUSED); + } else if (r_poll_pause_resp){ + // See #7, resuming after the Haskell process pauses + // is a direct train to a segfault and I can't work out how to fix + // it. Therefore it's just disallowed for now. + resp.finish(RESP_NO_RESUME); + } else { + resume_mutator(); + resp.finish(RESP_OKAY); + } + break; + + case CMD_GET_ROOTS: + if (!paused) { + resp.finish(RESP_NOT_PAUSED); + } else { + rts_listThreads(&collect_threads_callback, &resp); + rts_listMiscRoots(&collect_misc_callback, &resp); + resp.finish(RESP_OKAY); + } + break; + + case CMD_GET_CLOSURES: + if (!paused) { + resp.finish(RESP_NOT_PAUSED); + } else { + + trace("GET_CLOSURE\n"); + uint16_t n_raw = p.get(); + uint16_t n = htons(n_raw); + uint16_t n_start = n; + for (; n > 0; n--) { + trace("GET_CLOSURE_GET %d\n", n); + StgClosure *ptr = UNTAG_CLOSURE((StgClosure *) p.get()); + trace("GET_CLOSURE_LEN %d/%d\n", n, n_start); + trace("WORD_SIZE %lu\n", WORD_SIZE); + trace("CLOSURE_SIZE_PTR %p\n", ptr); + trace("CLOSURE_SIZE %u\n", closure_sizeW(ptr)); + trace("CLOSURE_TYPE %d\n", ptr->header.info->type); + + size_t len = closure_sizeW(ptr) * WORD_SIZE; + uint32_t len_payload = htonl(len); + trace("GET_CLOSURE_WRITE1 %lu\n", len); + resp.write(len_payload); + trace("GET_CLOSURE_WRITE2 %d\n", n); + resp.write((const char *) ptr, len); + } + resp.finish(RESP_OKAY); + } + break; + + case CMD_GET_INFO_TABLES: + // TODO: Info tables are immutable so we needn't pause for this request + if (!paused) { + resp.finish(RESP_NOT_PAUSED); + } else { + + trace("GET_INFO_TABLES\n"); + uint16_t n_raw = p.get(); + uint16_t n = htons(n_raw); + for (; n > 0; n--) { + trace("GET_INFO_GET %d\n", n); + StgInfoTable *ptr_end = (StgInfoTable *) p.get(); + // TODO this offset is wrong sometimes + // You have to subtract 1 so that you get the pointer to the + // start of the info table. + StgInfoTable *info = ptr_end - 1; + trace("INFO_TABLE_SIZE %lu\n", INFO_TABLE_SIZE); + trace("INFO_TABLE_PTR %p\n", info); + + size_t len = INFO_TABLE_SIZE; + uint32_t len_payload = htonl(len); + trace("GET_CLOSURE_WRITE1 %lu\n", len); + resp.write(len_payload); + resp.write((const char *) info, len); + } + resp.finish(RESP_OKAY); + } + break; + + case CMD_GET_BITMAP: + { + response_code code = RESP_OKAY; + StgClosure *s = (StgClosure *) p.get(); + uint32_t o = ntohl(p.get()); + // TODO this offset is wrong sometimes + // You have to subtract 1 so that you get the pointer to the + // start of the info table. + StgClosure *c = (StgClosure *)((uint64_t (s)) + ((uint64_t) o)); + trace("BITMAP %p %d %p\n", s, o, c); + const StgInfoTable *info = get_itbl(c); + switch (info->type) { + case CATCH_STM_FRAME: + case CATCH_RETRY_FRAME: + case ATOMICALLY_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: + case CATCH_FRAME: + case UPDATE_FRAME: + case RET_SMALL: + { + // Small bitmap + StgWord bitmap = BITMAP_BITS(info->layout.bitmap); + StgWord size = BITMAP_SIZE(info->layout.bitmap); + write_small_bitmap(resp, bitmap, size); + break; + } + + case RET_BCO: + { + StgBCO *bco = (StgBCO *) 0; // TODO: ugh + write_large_bitmap(resp, BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco)); + break; + } + + case RET_BIG: + { + StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info); + write_large_bitmap(resp, bitmap, bitmap->size); + break; + } + case RET_FUN: + { + StgRetFun *ret_fun; + + ret_fun = (StgRetFun *)c; + StgWord size = ret_fun->size; + write_fun_bitmap(resp, size, ret_fun->fun); + break; + } + + default: + trace("INFO %p %d", info, info->type); + code = RESP_BAD_STACK; + } + resp.finish(code); + break; + } + + case CMD_FUN_BITMAP: + { + StgClosure *fun = (StgClosure *) p.get(); + uint16_t n_raw = p.get(); + uint16_t n = htons(n_raw); + write_fun_bitmap(resp, n, fun); + } + resp.finish(RESP_OKAY); + break; + + + case CMD_POLL: + r_poll_pause_resp = &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; + + case CMD_SAVED_OBJECTS: + int i; + for (i = 0; i < g_savedObjectState.n_objects; i++) { + StgStablePtr v = g_savedObjectState.objects[i]; + resp.write((uint64_t)(UNTAG_CLOSURE((StgClosure *)deRefStablePtr(v)))); + } + resp.finish(RESP_OKAY); + break; + + //case CMD_FIND_PTR: + // trace("FIND_PTR\n"); + // StgClosure *ptr; + // ptr = UNTAG_CLOSURE((StgClosure *) p.get()); + // trace("FIND_PTR %p\n", ptr); + // trace("FIND_PTR_SIZE %u\n", closure_sizeW(ptr)); + // findPtrCb(&collect_misc_callback, &resp, (P_) ptr); + // resp.finish(RESP_OKAY); + // break; + + case CMD_CON_DESCR: + { + trace("CON_DESCR\n"); + StgConInfoTable *ptr_end = (StgConInfoTable *) p.get(); + trace("CON_DESC2 %p\n", ptr_end); + const char * con_desc = GET_CON_DESC(ptr_end - 1); + trace("CON_DESC: %p %lu\n", con_desc, strlen(con_desc)); + write_string(resp, con_desc); + resp.finish(RESP_OKAY); + break; + } + case CMD_SOURCE_INFO: + { + 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); + uint32_t len_payload; + if (!elt){ + trace("NOT FOUND\n"); + resp.write((uint32_t) 0); + } + else { + InfoProv ip = elt->prov; + trace("FOUND\n"); + + size_t len = 6; + uint32_t len_payload = htonl(len); + resp.write(len_payload); + + // Using the function just produces garbage.. no idea why + write_string(resp, ip.table_name); + write_string(resp, ip.closure_desc); + write_string(resp, ip.ty_desc); + write_string(resp, ip.label); + write_string(resp, ip.module); + write_string(resp, ip.srcloc); + } + resp.finish(RESP_OKAY); + break; + } + case CMD_BLOCKS: + { + printf("BD"); + listAllBlocks(list_blocks_callback, (void *) &resp); + resp.finish(RESP_OKAY); + break; + } + + case CMD_BLOCK: + { + // TODO: This doesn't work correctly for BF_NONMOVING blocks + // For those blocks you need to apply the NONMOVING_SEGMENT_MASK + // in order to find the start of the block. + bdescr *bd = Bdescr ((P_) p.get()); + trace("BD_ADDR: %p", bd); + write_block(&resp, bd); + resp.finish(RESP_OKAY); + break; + } + + + default: + return 1; + } + return 0; +} + + +static void handle_connection(const unsigned int sock_fd) { + Socket sock(sock_fd); + char *buf = new char[MAX_CMD_SIZE]; + while (true) { + uint32_t cmdlen_n, cmdlen; + + sock.read((char *)&cmdlen_n, 4); + cmdlen = ntohl(cmdlen_n); + + cmdlen = ntohl(cmdlen_n); + char *large_buf = buf; + bool use_large_buf = cmdlen > MAX_CMD_SIZE; + if (use_large_buf) { + large_buf = new char[cmdlen]; + } + + trace("LEN: %d\n", cmdlen); + sock.read(large_buf, cmdlen); + trace("CONT:%s\n", buf); + try { + trace("LEN2: %d\n", cmdlen); + handle_command(sock, large_buf, cmdlen); + } catch (Parser::EndOfInput e) { + barf("error"); + Response resp(sock); + resp.finish(RESP_BAD_COMMAND); + } + + if (use_large_buf) { + delete[] large_buf; + } + } + delete[] buf; +} + +/* return non-zero on error */ +/* +static void handle_connection(const unsigned int sock_fd) { + Socket sock(sock_fd); + char *buf = new char[MAX_CMD_SIZE]; + while (true) { + uint32_t cmdlen_n, cmdlen; + + sock.read((char *)&cmdlen_n, 4); + cmdlen = ntohl(cmdlen_n); + + trace("LEN: %d\n", cmdlen); + sock.read(buf, cmdlen); + trace("CONT:%s\n", buf); + try { + trace("LEN2: %d\n", cmdlen); + handle_command(sock, buf, cmdlen); + } catch (Parser::EndOfInput e) { + barf("error"); + Response resp(sock); + resp.finish(RESP_BAD_COMMAND); + } + } + delete[] buf; +} +*/ + +extern "C" +void start(const char* socket_path) { + trace("starting\n"); + struct sockaddr_un local, remote; + + if (strlen(socket_path) >= sizeof(local.sun_path)) { + barf("socket_path too long: \"%s\"", socket_path); + } + + int s = socket(AF_UNIX, SOCK_STREAM, 0); + if (s == -1) { + barf("socket failed"); + } + + // Bind socket + { + local.sun_family = AF_UNIX; + strncpy(local.sun_path, socket_path, sizeof(local.sun_path)); + unlink(local.sun_path); + if (bind(s, (struct sockaddr *) &local, sizeof(local)) != 0) { + barf("bind failed"); + } + } + + if (listen(s, 1) != 0) { + barf("listen failed"); + } + fflush(stdout); + while (true) { + socklen_t len; + int s2 = accept(s, (struct sockaddr *) &remote, &len); + if (s2 == -1) { + barf("accept failed %d", s2); + } + handle_connection(s2); + } +} + +extern "C" +StgWord saveClosures(StgWord n, HsStablePtr *sps) +{ + struct savedObjectsState *ps = &g_savedObjectState; + StgWord i; + + if(n > maxSavedObjects) + return maxSavedObjects; + + for (i = 0; i < n; i++) { + ps->objects[i] = sps[i]; + } + ps->n_objects = i; + return 0; +} + diff --git a/cbits/trace.cpp b/cbits/trace.cpp new file mode 100644 --- /dev/null +++ b/cbits/trace.cpp @@ -0,0 +1,16 @@ +#include +#include + +#ifdef TRACE +void trace(const char *fmt, ...) { + va_list args; + va_start(args, fmt); + vprintf(fmt, args); + va_end(args); +} +#else +void trace(const char * fmt, ...){ + (void) fmt; +} +#endif + diff --git a/cbits/trace.h b/cbits/trace.h new file mode 100644 --- /dev/null +++ b/cbits/trace.h @@ -0,0 +1,4 @@ +#pragma once + +void trace(const char *fmt, ...) + __attribute__((format (PRINTF, 1, 2))); diff --git a/ghc-debug-stub.cabal b/ghc-debug-stub.cabal new file mode 100644 --- /dev/null +++ b/ghc-debug-stub.cabal @@ -0,0 +1,63 @@ +cabal-version: 2.4 +name: ghc-debug-stub +version: 0.1.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 + be analysed with ghc-debug-common. +homepage: https://gitlab.haskell.org/ghc/ghc-debug +license: BSD-3-Clause +license-file: LICENSE +author: Ben Gamari, Matthew Pickering +maintainer: matthewtpickering@gmail.com +copyright: (c) 2019-2021 Ben Gamari, Matthew Pickering +category: Development +build-type: Simple +extra-source-files: CHANGELOG.md, cbits/socket.h, cbits/trace.h, cbits/parser.h + +flag trace + Description: Enable tracing + Default: False + Manual: True + +flag testexes + Description: Build test executables + Default: False + +library + exposed-modules: GHC.Debug.Stub + hs-source-dirs: src + build-depends: base >=4.12 && <4.14 + , directory ^>= 1.3 + , filepath ^>= 1.4 + , ghc-prim ^>= 0.8 + , ghc-debug-convention ^>= 0.1 + default-language: Haskell2010 + cxx-sources: cbits/stub.cpp, cbits/socket.cpp, cbits/trace.cpp + cxx-options: -std=gnu++11 -O3 -g3 -DTHREADED_RTS + extra-libraries: stdc++ + cpp-options: -DTHREADED_RTS + if flag(trace) + cpp-options: -DTRACE + +executable debug-test + if flag(testexes) + buildable: True + else + buildable: False + main-is: Test.hs + ghc-options: -threaded -g3 -O0 -finfo-table-map -fdistinct-constructor-tables + build-depends: base, + ghc-debug-stub, containers, unordered-containers + default-language: Haskell2010 + +executable large-thunk + if flag(testexes) + buildable: True + else + buildable: False + main-is: LargeThunk.hs + ghc-options: -threaded -g3 -O2 -finfo-table-map -fdistinct-constructor-tables -rtsopts + build-depends: base, + ghc-debug-stub, containers, deepseq + default-language: Haskell2010 diff --git a/src/GHC/Debug/Stub.hs b/src/GHC/Debug/Stub.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Debug/Stub.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-| +This module provides the functions you need to use to instrument your application +so it can be debugged using ghc-debug. Usually all you need to do is to +wrap the main function with the 'withGhcDebug' wrapper. + +@ + main = withGhcDebug $ do ... +@ + +Then when you application starts, a socket will be created which the debugger +can be attached to. The location of the socket is controlled by the @GHC_DEBUG_SOCKET@ +environment variable. +-} +module GHC.Debug.Stub (withGhcDebug, saveClosures, Box(..), pause, resume) where + +import Control.Applicative +import Control.Concurrent +import Control.Monad +import Data.Maybe (fromMaybe) +import Foreign.C.Types +import Foreign.C.String +import Foreign.Marshal.Array +import Foreign.StablePtr +import GHC.Exts +import GHC.Int +import GHC.IO +import GHC.Prim +import System.FilePath +import System.Directory +import System.Environment +import System.Mem +import System.IO + +import GHC.Debug.Convention (socketDirectory) + +foreign import ccall safe "start" + start_c :: CString -> IO () + +foreign import ccall safe "unistd.h getpid" + getpid_c :: IO CInt + +-- | Start listening for remote debugging. You should wrap your main thread +-- in this as it performs some cleanup on exit. If not used on the Main thread, +-- user interupt (Ctrl-C) may skip the cleanup step. +-- +-- By default the socket is created by referring to 'socketDirectory' which is +-- in your XDG data directory. +-- +-- The socket created can also be controlled using the @GHC_DEBUG_SOCKET@ +-- environment variable. +withGhcDebug :: IO a -> IO a +withGhcDebug main = do + -- Pick a socket file path. + socketPath <- do + socketOverride <- fromMaybe "" <$> lookupEnv "GHC_DEBUG_SOCKET" + if not (null socketOverride) + then return socketOverride + else do + dir <- socketDirectory + name <- getProgName + pid <- show <$> getpid_c + let socketName = pid ++ "-" ++ name + return (dir socketName) + + createDirectoryIfMissing True (takeDirectory socketPath) + hPutStrLn stderr $ "Starting ghc-debug on socket: " ++ socketPath + + -- Start a thread to handle requests + _threadId <- forkIO $ withCString socketPath start_c + + -- Run the main thread with cleanup + main + `finally` + (removeFile socketPath + <|> putStrLn ("ghc-debug: failed to cleanup socket: " ++ socketPath) + ) + +-- | Break program execution for debugging. +foreign import ccall safe "pause_mutator" + pause_c :: IO () + +pause :: IO () +pause = performGC >> pause_c + +-- | Resume program execution for debugging. +foreign import ccall safe "resume_mutator" + resume :: IO () + +foreign import ccall unsafe "saveClosures" c_saveClosures + :: CInt -> Ptr (Ptr ()) -> IO () + +data Box = forall a . Box a + +unbox :: (forall a . a -> b) -> Box -> b +unbox f (Box a) = f a + +-- | Mark a set of closures to be saved, they can then be retrieved from +-- the debugger using the 'RequestSavedClosures' requests. This can be +-- useful to transmit specific closures you care about (such as a cache or +-- large map). +saveClosures :: [Box] -> IO () +saveClosures xs = do + sps <- mapM (\(Box x) -> castStablePtrToPtr <$> newStablePtr x) xs + withArray sps $ \sps_arr -> + c_saveClosures (fromIntegral (length xs)) sps_arr