From b4dd9f0ec4032b16b625b9f22b8cdff0446d1d85 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 10 Jan 2024 16:54:16 +0100 Subject: [PATCH] Fix selector thunk optimization Also prepare for release 0.2.1. --- ChangeLog.md | 6 ++++++ examples/selthunkopt2.hs | 20 ++++++++++++++++++++ src/CBN/SelThunkOpt.hs | 17 ++++++++++++++--- src/CBN/Trace.hs | 16 +++++++++------- src/CBN/Trace/Graph.hs | 14 +++++++------- src/CBN/Trace/JavaScript.hs | 14 +++++++------- src/CBN/Trace/Textual.hs | 23 +++++++++++++---------- visualize-cbn.cabal | 2 +- 8 files changed, 77 insertions(+), 35 deletions(-) create mode 100644 examples/selthunkopt2.hs diff --git a/ChangeLog.md b/ChangeLog.md index fae2f60..6223b48 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for visualize-cbn +## 0.2.1 -- 2024-01-10 + +* Fixes to the selector thunk optimization: also apply it at the top-level, + and correctly apply `--hide-selector-thunk-opt` (previously `--hide-gc` + was hiding selector thunk optimization steps by mistake). + ## 0.2.0 -- 2023-12-20 * Support multiple (mutually recursive) bindings in `let` diff --git a/examples/selthunkopt2.hs b/examples/selthunkopt2.hs new file mode 100644 index 0000000..3adebee --- /dev/null +++ b/examples/selthunkopt2.hs @@ -0,0 +1,20 @@ +break = (\xs -> + case xs of { + Nil -> Pair Nil Nil + ; Cons x xs' -> + if eq x 0 + then Pair Nil xs' + else let b = @break xs' + in Pair (Cons x (fst b)) (snd b) + } + ) + +last = (\def -> \xs -> + case xs of { + Nil -> def + ; Cons x' xs' -> @last x' xs' + } + ) + +main = let broken = @break (Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 0 (Cons 5 (Cons 6 (Cons 7 (Cons 8 Nil))))))))) + in eq (@last 0 (fst broken)) (@last 0 (snd broken)) \ No newline at end of file diff --git a/src/CBN/SelThunkOpt.hs b/src/CBN/SelThunkOpt.hs index 9038760..55fb5cd 100644 --- a/src/CBN/SelThunkOpt.hs +++ b/src/CBN/SelThunkOpt.hs @@ -11,6 +11,7 @@ Specifically section 2.5.7, "Selector optimization" - "Three runtime optimizations done by GHC's GC", Ömer Sinan Ağacan + Specifically section 3, "Selector thunk evaluation" - "GHC Commentary: The Layout of Heap Objects", section "Selector thunks" @@ -32,8 +33,18 @@ import CBN.Heap import CBN.Language -- | Apply selector thunk optimization -selThunkOpt :: Heap Term -> (Heap Term, Set Ptr) -selThunkOpt = findAll Set.empty +selThunkOpt :: Heap Term -> Term -> (Heap Term, Term, Bool, Set Ptr) +selThunkOpt hp0 e0 = + let (hp1, e1, atToplevel) = case applyInTerm hp0 e0 of + Nothing -> (hp0, e0, False) + Just (hp', e') -> (hp', e', True) + (hp2, ptrs) = applyInHeap hp1 + + in (hp2, e1, atToplevel, ptrs) + +-- | Apply selector thunk optimization +applyInHeap :: Heap Term -> (Heap Term, Set Ptr) +applyInHeap = findAll Set.empty where findAll :: Set Ptr -> Heap Term -> (Heap Term, Set Ptr) findAll acc hp = @@ -89,7 +100,7 @@ applyInTerm = \hp term -> do -- This code is a bit simpler than the corresponding code in evaluation, -- because we /only/ deal with selectors, not general case statements. This -- means we don't need to care about substitution, but can literally just - -- select the right argument (using + -- select the right argument. go term@(TCase e (Selector s)) = do (hp, _) <- get diff --git a/src/CBN/Trace.hs b/src/CBN/Trace.hs index cc97811..68e05a5 100644 --- a/src/CBN/Trace.hs +++ b/src/CBN/Trace.hs @@ -42,7 +42,9 @@ data TraceCont = | TraceGC (Set Ptr) Trace -- | The selector thunk optimization was applied - | TraceSelThunk (Set Ptr) Trace + -- + -- We separately record if the selector thunk was applied at the top-level. + | TraceSelThunk Bool (Set Ptr) Trace -- | We simplified the heap by inlining some definitions | TraceInline (Set Ptr) Trace @@ -58,11 +60,11 @@ traceTerm shouldGC shouldInline enableSelThunkOpt = go Step d (hp1, e1) -> let (traceSelThunkOpt, hp2, e2) | enableSelThunkOpt - = let (hp', optimized) = selThunkOpt hp1 - in if Set.null optimized then + = let (hp', e', atToplevel, optimized) = selThunkOpt hp1 e1 + in if not atToplevel && Set.null optimized then (id, hp1, e1) else - (Trace (hp1, e1) . TraceSelThunk optimized, hp', e1) + (Trace (hp1, e1) . TraceSelThunk atToplevel optimized, hp', e') | otherwise = (id, hp1, e1) in @@ -145,10 +147,10 @@ summarize SummarizeOptions{..} = go 0 if summarizeHideGC then go (n + 1) t' else showSrc $ TraceGC ps $ go (n + 1) t' - TraceSelThunk ps t' -> - if summarizeHideGC + TraceSelThunk atToplevel ps t' -> + if summarizeHideSelThunk then go (n + 1) t' - else showSrc $ TraceSelThunk ps $ go (n + 1) t' + else showSrc $ TraceSelThunk atToplevel ps $ go (n + 1) t' TraceInline ps t' -> if summarizeHideInlining then go (n + 1) t' diff --git a/src/CBN/Trace/Graph.hs b/src/CBN/Trace/Graph.hs index a1a1452..9471589 100644 --- a/src/CBN/Trace/Graph.hs +++ b/src/CBN/Trace/Graph.hs @@ -27,13 +27,13 @@ render tr = go :: Int -> Trace -> String go index (Trace (hp, t) cont) = case cont of - TraceWHNF _ -> mkFrame Set.empty Nothing "whnf" - TraceStuck err -> mkFrame Set.empty Nothing (mkErr err) - TraceStopped -> mkFrame Set.empty Nothing "stopped" - TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (mkDesc d) ++ go (index + 1) tr' - TraceGC ps tr' -> mkFrame ps Nothing "gc" ++ go (index + 1) tr' - TraceSelThunk ps tr' -> mkFrame ps Nothing "selector" ++ go (index + 1) tr' - TraceInline ps tr' -> mkFrame ps Nothing "inline" ++ go (index + 1) tr' + TraceWHNF _ -> mkFrame Set.empty Nothing "whnf" + TraceStuck err -> mkFrame Set.empty Nothing (mkErr err) + TraceStopped -> mkFrame Set.empty Nothing "stopped" + TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (mkDesc d) ++ go (index + 1) tr' + TraceGC ps tr' -> mkFrame ps Nothing "gc" ++ go (index + 1) tr' + TraceSelThunk _ ps tr' -> mkFrame ps Nothing "selector" ++ go (index + 1) tr' + TraceInline ps tr' -> mkFrame ps Nothing "inline" ++ go (index + 1) tr' where mkFrame :: Set Ptr -> Maybe Ptr -> T.Text -> String mkFrame garbage focus status = diff --git a/src/CBN/Trace/JavaScript.hs b/src/CBN/Trace/JavaScript.hs index 5416f3f..3c0ae97 100644 --- a/src/CBN/Trace/JavaScript.hs +++ b/src/CBN/Trace/JavaScript.hs @@ -42,13 +42,13 @@ render name graph = \tr -> go :: Int -> Trace -> String go n (Trace (hp, e) c) = case c of - TraceWHNF _ -> mkFrame Set.empty Nothing "whnf" - TraceStuck err -> mkFrame Set.empty Nothing (mkErr err) - TraceStopped -> mkFrame Set.empty Nothing "stopped" - TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (mkDesc d) ++ go (n + 1) tr' - TraceGC ps tr' -> mkFrame ps Nothing "gc" ++ go (n + 1) tr' - TraceSelThunk ps tr' -> mkFrame ps Nothing "selector" ++ go (n + 1) tr' - TraceInline ps tr' -> mkFrame ps Nothing "inline" ++ go (n + 1) tr' + TraceWHNF _ -> mkFrame Set.empty Nothing "whnf" + TraceStuck err -> mkFrame Set.empty Nothing (mkErr err) + TraceStopped -> mkFrame Set.empty Nothing "stopped" + TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (mkDesc d) ++ go (n + 1) tr' + TraceGC ps tr' -> mkFrame ps Nothing "gc" ++ go (n + 1) tr' + TraceSelThunk _ ps tr' -> mkFrame ps Nothing "selector" ++ go (n + 1) tr' + TraceInline ps tr' -> mkFrame ps Nothing "inline" ++ go (n + 1) tr' where mkFrame :: Set Ptr -> Maybe Ptr -> String -> String mkFrame garbage focus status = diff --git a/src/CBN/Trace/Textual.hs b/src/CBN/Trace/Textual.hs index a2a3fed..6ec13ef 100644 --- a/src/CBN/Trace/Textual.hs +++ b/src/CBN/Trace/Textual.hs @@ -22,13 +22,13 @@ renderIO disableAnsi = go 0 go :: Int -> Trace -> IO () go n (Trace (hp, e) c) = do case c of - TraceWHNF _ -> mkFrame Set.empty Nothing (putStr $ "whnf") - TraceStuck err -> mkFrame Set.empty Nothing (putStr $ "stuck: " ++ err) - TraceStopped -> mkFrame Set.empty Nothing (putStr $ "stopped") - TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (pretty d) >> go (n + 1) tr' - TraceGC ps tr' -> mkFrame ps Nothing (ptrs "collecting" ps) >> go (n + 1) tr' - TraceSelThunk ps tr' -> mkFrame ps Nothing (ptrs "apply selectors" ps) >> go (n + 1) tr' - TraceInline ps tr' -> mkFrame ps Nothing (ptrs "inlining" ps) >> go (n + 1) tr' + TraceWHNF _ -> mkFrame Set.empty Nothing (putStr $ "whnf") + TraceStuck err -> mkFrame Set.empty Nothing (putStr $ "stuck: " ++ err) + TraceStopped -> mkFrame Set.empty Nothing (putStr $ "stopped") + TraceStep d tr' -> mkFrame Set.empty (mkFocus d) (pretty d) >> go (n + 1) tr' + TraceGC ps tr' -> mkFrame ps Nothing (ptrs False "collecting" ps) >> go (n + 1) tr' + TraceSelThunk top ps tr' -> mkFrame ps Nothing (ptrs top "apply selectors" ps) >> go (n + 1) tr' + TraceInline ps tr' -> mkFrame ps Nothing (ptrs False "inlining" ps) >> go (n + 1) tr' where mkFrame :: Set Ptr -> Maybe Ptr -> IO () -> IO () mkFrame garbage focus msg = do @@ -38,10 +38,13 @@ renderIO disableAnsi = go 0 putChar '\n' putStr "(" ; msg ; putStrLn ")\n" - ptrs :: String -> Set Ptr -> IO () - ptrs label ps = do + ptrs :: Bool -> String -> Set Ptr -> IO () + ptrs atToplevel label ps = do putStr (label ++ " ") - sequence_ . intersperse (putStr ", ") . map pretty $ Set.toList ps + sequence_ . intersperse (putStr ", ") $ concat [ + [putStr "top-level" | atToplevel] + , map pretty $ Set.toList ps + ] pretty :: ToDoc a => a -> IO () pretty = diff --git a/visualize-cbn.cabal b/visualize-cbn.cabal index 87340e9..f917afa 100644 --- a/visualize-cbn.cabal +++ b/visualize-cbn.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: visualize-cbn -version: 0.2.0 +version: 0.2.1 synopsis: Visualize CBN reduction description: CBN interpretation and visualization tool. Exports in text format, coloured text (ANSI) or HTML/JavaScript.