diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for ghc-debug-stub -## 0.1.0.0 -- YYYY-mm-dd +## 0.2.0.0 -- 2021-12-06 -* First version. Released on an unsuspecting world. +* Second version + +## 0.1.0.0 -- 2021-06-14 + +* First version diff --git a/LargeThunk.hs b/LargeThunk.hs deleted file mode 100644 --- a/LargeThunk.hs +++ /dev/null @@ -1,172 +0,0 @@ - -{-# 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/Test.hs b/Test.hs deleted file mode 100644 --- a/Test.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# 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/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.1.0.0 +version: 0.2.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,10 +20,6 @@ Default: False Manual: True -flag testexes - Description: Build test executables - Default: False - library exposed-modules: GHC.Debug.Stub hs-source-dirs: src @@ -31,7 +27,7 @@ , directory ^>= 1.3 , filepath ^>= 1.4 , ghc-prim ^>= 0.8 - , ghc-debug-convention ^>= 0.1 + , ghc-debug-convention ^>= 0.2 default-language: Haskell2010 cxx-sources: cbits/stub.cpp, cbits/socket.cpp, cbits/trace.cpp cxx-options: -std=gnu++11 -O3 -g3 -DTHREADED_RTS @@ -40,24 +36,3 @@ 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