From dc51993374e9007020fdb614b3872543291791e2 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 14 Dec 2023 15:28:21 +0100 Subject: [PATCH 1/5] Circular substitution This also makes a number of other improvements: - Support multiple (mutually recursive) bindings in `let` - Fix pattern matching on heap-allocated objects (we were losing sharing) - Support heap inlining - Support for selectors (`fst`, `snd`) - Support the selector thunk optimization - Add `--disable-ansi` command line - Improve trace summarization (it previously generated confusing output; see details comments in the code) - Add some new primitive functions (`min`, `max`) --- examples/circular_hos.hs | 36 ++++++ examples/multiple-beta.hs | 7 ++ examples/mutual_rec.hs | 7 ++ examples/repmin.hs | 35 ++++++ examples/selthunkopt.hs | 28 +++++ src/CBN/Closure.hs | 16 +-- src/CBN/Eval.hs | 152 ++++++++++++++++++------ src/CBN/Free.hs | 48 +++++--- src/CBN/Heap.hs | 36 +++++- src/CBN/InlineHeap.hs | 47 ++++++++ src/CBN/Language.hs | 87 ++++++++++++-- src/CBN/Options.hs | 23 ++++ src/CBN/Parser.hs | 57 +++++++-- src/CBN/Pretty.hs | 58 +++++++--- src/CBN/SelThunkOpt.hs | 110 ++++++++++++++++++ src/CBN/Subst.hs | 172 +++++++++++++++++++--------- src/CBN/Trace.hs | 151 ++++++++++++++++++------ src/CBN/Trace/Graph.hs | 48 +++++--- src/CBN/Trace/HeapGraph.hs | 6 +- src/CBN/Trace/JavaScript.hs | 24 ++-- src/CBN/Trace/Textual.hs | 52 ++++++--- src/CBN/Util/Doc/Rendered/ANSI.hs | 5 +- src/CBN/Util/Doc/Rendered/HTML.hs | 7 +- src/CBN/Util/Doc/Rendered/String.hs | 9 +- src/CBN/Util/Doc/Style.hs | 1 + src/Main.hs | 11 +- stack.yaml | 66 ----------- visualize-cbn.cabal | 3 + 28 files changed, 993 insertions(+), 309 deletions(-) create mode 100644 examples/circular_hos.hs create mode 100644 examples/multiple-beta.hs create mode 100644 examples/mutual_rec.hs create mode 100644 examples/repmin.hs create mode 100644 examples/selthunkopt.hs create mode 100644 src/CBN/InlineHeap.hs create mode 100644 src/CBN/SelThunkOpt.hs delete mode 100644 stack.yaml diff --git a/examples/circular_hos.hs b/examples/circular_hos.hs new file mode 100644 index 0000000..8aefe32 --- /dev/null +++ b/examples/circular_hos.hs @@ -0,0 +1,36 @@ +-- See "Using Circular Programs for Higher-Order Syntax" +-- by Emil Axelsson and Koen Claessen (ICFP 2013) +-- +-- +-- See Unfolder episode 17 for more details. +-- +-- Suggested execution: +-- +-- > cabal run visualize-cbn -- \ +-- > --show-trace \ +-- > --hide-prelude \ +-- > --gc \ +-- > --selector-thunk-opt \ +-- > --inline-heap \ +-- > --hide-inlining \ +-- > --hide-gc \ +-- > --hide-selector-thunk-opt \ +-- > --javascript foo.js \ +-- > -i examples/circular_hos.hs +maxBV = (\exp -> + case exp of { + Var x -> 0 + ; App f e -> max (@maxBV f) (@maxBV e) + ; Lam n f -> n + } + ) + +lam = (\f -> + let { + body = f (Var n) + ; n = succ (@maxBV body) + } + in seq n (Lam n body) + ) + +main = @lam (\x -> App (App (@lam (\y -> y)) (@lam (\z -> z))) x) diff --git a/examples/multiple-beta.hs b/examples/multiple-beta.hs new file mode 100644 index 0000000..2215955 --- /dev/null +++ b/examples/multiple-beta.hs @@ -0,0 +1,7 @@ +f = (\x -> @g x) +g = (\x -> @h x) +h = (\x -> succ x) + +main = @f 1 + + diff --git a/examples/mutual_rec.hs b/examples/mutual_rec.hs new file mode 100644 index 0000000..68f3942 --- /dev/null +++ b/examples/mutual_rec.hs @@ -0,0 +1,7 @@ +-- Simple example of two mutually recursive functions +-- f x will return 0 if x is even and 1 if x is odd. +main = + let { + f = (\x -> if eq x 0 then 0 else g (sub x 1)) + ; g = (\x -> if eq x 0 then 1 else f (sub x 1)) + } in f 2 \ No newline at end of file diff --git a/examples/repmin.hs b/examples/repmin.hs new file mode 100644 index 0000000..ae28a32 --- /dev/null +++ b/examples/repmin.hs @@ -0,0 +1,35 @@ +-- The classic repMin circular program due to Richard Bird. +-- See Unfolder episode 17 for more details. +-- +-- Suggested execution: +-- +-- > cabal run visualize-cbn -- \ +-- > --show-trace \ +-- > --hide-prelude \ +-- > --gc \ +-- > --selector-thunk-opt \ +-- > --inline-heap \ +-- > --hide-inlining \ +-- > --hide-gc \ +-- > --hide-selector-thunk-opt \ +-- > --javascript foo.js \ +-- > -i examples/repmin.hs +worker = (\m -> \t -> + case t of { + Leaf x -> Pair x (Leaf m) + ; Branch l r -> + let { + resultLeft = @worker m l + ; resultRight = @worker m r + ; mb = min (fst resultLeft) (fst resultRight) + } + in seq mb (Pair mb (Branch (snd resultLeft) (snd resultRight))) + } + ) + +repMin = (\t -> + let result = @worker (fst result) t + in snd result + ) + +main = @repMin (Branch (Branch (Leaf 1) (Leaf 2)) (Branch (Leaf 3) (Leaf 4))) diff --git a/examples/selthunkopt.hs b/examples/selthunkopt.hs new file mode 100644 index 0000000..2dec509 --- /dev/null +++ b/examples/selthunkopt.hs @@ -0,0 +1,28 @@ +-- Demonstration of the need for the selector thunk optimization +-- This is the example from "Fixing some space leaks with a garbage collector". + +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) + } + ) + +-- strict version of concat (makes the example more clear) +concat = (\xs -> \ys -> + case xs of { + Nil -> ys + ; Cons x xs' -> let r = @concat xs' ys in seq r (Cons x r) + } + ) + +surprise = (\xs -> + let b = @break xs + in @concat (fst b) (@concat (Cons 4 (Cons 5 (Cons 6 Nil))) (snd b)) + ) + +main = @surprise (Cons 1 (Cons 2 (Cons 3 (Cons 0 (Cons 7 (Cons 8 (Cons 9 Nil))))))) diff --git a/src/CBN/Closure.hs b/src/CBN/Closure.hs index ba1be1d..9543a11 100644 --- a/src/CBN/Closure.hs +++ b/src/CBN/Closure.hs @@ -1,7 +1,7 @@ module CBN.Closure (toClosureGraph, Closure(..), Id) where import Data.Maybe (fromJust) -import Data.Graph as Graph +import Data.Graph as Graph hiding (edges) import Control.Monad.State import qualified Data.Set as Set import qualified Data.Map as Map @@ -9,7 +9,7 @@ import qualified Data.Tree as Tree import CBN.Language import CBN.Heap -import CBN.Trace +import CBN.Trace () -- Some Terms have a heap Pointer, but not an explicit CBN.Heap.Ptr. -- For example the closure `Cons 1 Nil` has a Pointer to `1` @@ -59,14 +59,14 @@ thunk term = ThunkClosure term $ Set.toList $ pointers term -- Heap could be used in the future to eliminate Indirections. toClosure :: (Heap Term, Term) -> Closure -toClosure (heap, term) = case term of +toClosure (_heap, term) = case term of TVar (Var x) -> ErrorClosure $ "free variable " ++ show x TLam _ _ -> FunClosure term ls where ls = Set.toList $ pointers term TCon (ConApp con terms) -> ConClosure con terms TPtr ptr -> IndirectionClosure ptr TPrim (PrimApp p es) -> PrimClosure p es - TLet _ _ _ -> thunk term + TLet _ _ -> thunk term TApp _ _ -> thunk term TCase _ _ -> thunk term TIf _ _ _ -> thunk term @@ -88,7 +88,7 @@ toClosureGraph (heap@(Heap _ hp), term) = -- If we ignore Heap.Ptrs, each heap term, defines a tree of other reachable -- terms. mkTree :: (Ptr, Term) -> [(Closure, Id, [Id])] - mkTree (ptr, term) = Tree.flatten $ addInternalEdges tree + mkTree (ptr, term') = Tree.flatten $ addInternalEdges tree where identify :: State Int Id identify = do @@ -104,15 +104,15 @@ toClosureGraph (heap@(Heap _ hp), term) = cont = map addInternalEdges subTrees tree :: Tree (Id, (Closure, [Id])) - tree = evalState (Tree.unfoldTreeM f term) 0 + tree = evalState (Tree.unfoldTreeM f term') 0 -- The [Id] here contains only the pointer ids and -- Not the Ids of the same Tree, as those are not assigned yet. -- They are added at `addInternalEdges`, after the creation of the whole tree. f :: Term -> State Int ((Id, (Closure, [Id])), [Term]) - f term = do + f term'' = do myid <- identify - let closure = toClosure (heap, term) + let closure = toClosure (heap, term'') let (ptrs, terms) = extractEdges closure return ((myid, (closure, map defaultId ptrs)), terms) diff --git a/src/CBN/Eval.hs b/src/CBN/Eval.hs index fa23c8e..62cfd91 100644 --- a/src/CBN/Eval.hs +++ b/src/CBN/Eval.hs @@ -4,18 +4,27 @@ module CBN.Eval ( , DescriptionWithContext(..) , Step(..) , step + -- * Case statements + , findMatch + , AllocdConArgs(..) + , allocConArgs ) where +import qualified Data.Map as M + import CBN.Language import CBN.Heap import CBN.Subst -import qualified Data.Map as M + +{------------------------------------------------------------------------------- + Small-step semantics +-------------------------------------------------------------------------------} type Error = String -- | Description of a step: what happened? data Description = - -- | We moved a let-bound variable to the heap + -- | We moved let-bound variables to the heap StepAlloc -- | Beta-reduction @@ -35,12 +44,17 @@ data Description = -- | Seq finished evaluating its left argument | StepSeq + + -- | We allocated constructor arguments to preserve sharing + | StepAllocConArgs deriving (Show) data DescriptionWithContext = - DescriptionWithContext Description [Ptr] + DescriptionWithContext Description Context deriving (Show) +type Context = [Ptr] + data Step = -- | Evaluation took a single step Step DescriptionWithContext (Heap Term, Term) @@ -79,15 +93,8 @@ step (hp, TPtr ptr) = Step d (hp', e') -> pushContext ptr d (mutate (hp', ptr) e', TPtr ptr) Stuck err -> Stuck err WHNF val -> WHNF val -step (hp, TLet x e1 (TSeq (TVar x') e2)) | x == x' = - -- special case for let x = e in seq x .. - -- rather than allocate we reduce inside the let - case step (hp, e1) of - Step d (hp', e1') -> Step d (hp', TLet x e1' (TSeq (TVar x) e2)) - Stuck err -> Stuck err - WHNF _ -> emptyContext StepSeq (hp, TLet x e1 e2) -step (hp, TLet x e1 e2) = - emptyContext StepAlloc $ allocSubst RecBinding [(x,e1)] (hp, e2) +step (hp, TLet bound e) = + emptyContext StepAlloc $ allocSubst bound (hp, e) step (hp, TApp e1 e2) = do let descr = case e1 of TPtr ptr -> StepApply ptr @@ -95,7 +102,7 @@ step (hp, TApp e1 e2) = do case step (hp, e1) of Step d (hp', e1') -> Step d (hp', TApp e1' e2) Stuck err -> Stuck err - WHNF (VLam x e1') -> emptyContext descr $ allocSubst NonRecBinding [(x,e2)] (hp, e1') + WHNF (VLam x e1') -> emptyContext descr $ allocSubst [(x,e2)] (hp, e1') WHNF _ -> Stuck "expected lambda" step (hp, TCase e ms) = case step (hp, e) of @@ -105,11 +112,23 @@ step (hp, TCase e ms) = WHNF (VPrim _) -> Stuck "cannot pattern match on primitive values" WHNF (VCon (ConApp c es)) -> case findMatch c ms of - Nothing -> Stuck "Non-exhaustive pattern match" - Just (xs, e') -> - if length xs == length es - then emptyContext (StepMatch c) $ allocSubst NonRecBinding (zip xs es) (hp, e') - else Stuck $ "Invalid pattern match (cannot match " ++ show (xs, es) ++ ")" + Nothing -> + Stuck "Non-exhaustive pattern match" + Just (xs, _) | length xs /= length es -> + Stuck $ "Cannot match " ++ show (xs, es) + Just (xs, rhs) -> + -- We /know/ that e is a con-app or a pointer to a con-app, but we + -- search /again/, this time with 'allocConArgs'. The reason we + -- search twice is that the first search enables us to find the + -- right variable names to use for allocation. This is not critical, + -- but makes the variables in the heap more human-friendly. + case allocConArgs xs (hp, e) of + ConArgsAllocFailed -> + error "step: impossible ConArgsAllocFailed" + ConArgsAllocUnnecessary _ -> + emptyContext (StepMatch c) $ allocSubst (zip xs es) (hp, rhs) + ConArgsAllocDone (ctxt, hp', e') _ -> + Step (DescriptionWithContext StepAllocConArgs ctxt) (hp', TCase e' ms) step (hp, TPrim (PrimApp p es)) = case stepPrimArgs hp es of PrimStep d hp' es' -> Step d (hp', TPrim (PrimApp p es')) @@ -131,6 +150,79 @@ step (hp, TSeq e1 e2) = Stuck err -> Stuck err WHNF _ -> emptyContext StepSeq (hp, e2) +{------------------------------------------------------------------------------- + Case statements +-------------------------------------------------------------------------------} + +findMatch :: Con -> Branches -> Maybe ([Var], Term) +findMatch c (Matches ms) = go ms + where + go :: [Match] -> Maybe ([Var], Term) + go [] = Nothing + go (Match (Pat c' xs) e:ms') | c == c' = Just (xs, e) + | otherwise = go ms' +findMatch c (Selector s) = + findMatch c $ Matches [selectorMatch s] + +data AllocdConArgs = + -- | No allocation was necessary + ConArgsAllocUnnecessary ConApp + + -- | The constructor arguments were heap-allocated + | ConArgsAllocDone (Context, Heap Term, Term) ConApp + + -- | The term was not a constructor application in WHNF or a pointer to + -- such a term + | ConArgsAllocFailed + +-- | Allocate constructor arguments +-- +-- This is necessary when doing a case statement on a value in the heap, to +-- avoid losing sharing. +allocConArgs :: + [Var] + -> (Heap Term, Term) + -> AllocdConArgs +allocConArgs xs = + go True + where + go :: Bool -> (Heap Term, Term) -> AllocdConArgs + go isTopLevel (hp, term) = + case term of + TPtr ptr | Just p <- deref (hp, ptr) -> do + case go False (hp, p) of + ConArgsAllocUnnecessary conApp -> + ConArgsAllocUnnecessary conApp + ConArgsAllocFailed -> + ConArgsAllocFailed + ConArgsAllocDone (ctxt, hp', e') conApp -> + ConArgsAllocDone + (ptr : ctxt, mutate (hp', ptr) e', TPtr ptr) + conApp + TCon conApp@(ConApp con args) | length args == length xs -> + if isTopLevel || all termIsSimple args then + ConArgsAllocUnnecessary conApp + else do + let (hp', args') = + allocMany + (zipWith prepareHeapEntry xs args) + processHeapEntries + hp + conApp' = ConApp con args' + ConArgsAllocDone ([], hp', TCon conApp') conApp' + _ -> + ConArgsAllocFailed + + prepareHeapEntry :: Var -> Term -> (Maybe String, Ptr -> (Ptr, Term)) + prepareHeapEntry x t = (Just (varName x), \ptr -> (ptr, t)) + + processHeapEntries :: [(Ptr, Term)] -> ([(Ptr, Term)], [Term]) + processHeapEntries entries = (entries, map (TPtr . fst) entries) + +{------------------------------------------------------------------------------- + Primitive operations +-------------------------------------------------------------------------------} + -- | The result of stepping the arguments to an n-ary primitive function data StepPrimArgs = -- Some term took a step @@ -157,19 +249,15 @@ stepPrimArgs hp = go [] where acc' = map (valueToTerm . VPrim) (reverse acc) -findMatch :: Con -> [Match] -> Maybe ([Var], Term) -findMatch c = go - where - go :: [Match] -> Maybe ([Var], Term) - go [] = Nothing - go (Match (Pat c' xs) e:ms) | c == c' = Just (xs, e) - | otherwise = go ms - delta :: Prim -> [Prim] -> Either Error Value -delta PIAdd [PInt n1, PInt n2] = Right $ liftInt $ n1 + n2 -delta PISub [PInt n1, PInt n2] = Right $ liftInt $ n1 - n2 -delta PIMul [PInt n1, PInt n2] = Right $ liftInt $ n1 * n2 -delta PIEq [PInt n1, PInt n2] = Right $ liftBool $ n1 == n2 -delta PILt [PInt n1, PInt n2] = Right $ liftBool $ n1 < n2 -delta PILe [PInt n1, PInt n2] = Right $ liftBool $ n1 <= n2 +delta PISucc [PInt n] = Right $ liftInt $ n + 1 +delta PIAdd [PInt n1, PInt n2] = Right $ liftInt $ n1 + n2 +delta PISub [PInt n1, PInt n2] = Right $ liftInt $ n1 - n2 +delta PIMul [PInt n1, PInt n2] = Right $ liftInt $ n1 * n2 +delta PIMin [PInt n1, PInt n2] = Right $ liftInt $ n1 `min` n2 +delta PIMax [PInt n1, PInt n2] = Right $ liftInt $ n1 `max` n2 +delta PIEq [PInt n1, PInt n2] = Right $ liftBool $ n1 == n2 +delta PILt [PInt n1, PInt n2] = Right $ liftBool $ n1 < n2 +delta PILe [PInt n1, PInt n2] = Right $ liftBool $ n1 <= n2 delta _op _args = Left $ "delta: cannot evaluate" + diff --git a/src/CBN/Free.hs b/src/CBN/Free.hs index a62b090..91b380d 100644 --- a/src/CBN/Free.hs +++ b/src/CBN/Free.hs @@ -28,6 +28,9 @@ instance Free Var where instance Free a => Free [a] where free = Map.unionsWith (+) . map free +instance (Free a, Free b) => Free (a, b) where + free (a, b) = Map.unionWith (+) (free a) (free b) + instance Free Match where free (Match (Pat _ xs) e) = Map.deleteKeys xs $ free e @@ -38,16 +41,24 @@ instance Free PrimApp where free (PrimApp _ es) = free es instance Free Term where - free (TVar x) = free x - free (TApp e1 e2) = free [e1, e2] - free (TLam x e) = Map.delete x $ free e - free (TPtr _) = Map.empty - free (TCon ces) = free ces - free (TCase e ms) = Map.unionWith (+) (free e) (free ms) - free (TLet x e1 e2) = Map.delete x $ free [e1, e2] - free (TPrim pes) = free pes - free (TIf c t f) = free [c, t, f] - free (TSeq e1 e2) = free [e1, e2] + free (TVar x) = free x + free (TApp e1 e2) = free [e1, e2] + free (TLam x e) = Map.delete x $ free e + free (TPtr _) = Map.empty + free (TCon ces) = free ces + free (TCase e ms) = free (e, ms) + free (TLet bound e2) = Map.filterWithKey (\x _ -> x `notElem` map fst bound) $ + free (map snd bound, e2) + free (TPrim pes) = free pes + free (TIf c t f) = free [c, t, f] + free (TSeq e1 e2) = free [e1, e2] + +instance Free Branches where + free (Matches ms) = free ms + free (Selector s) = free s + +instance Free Selector where + free _ = Map.empty {------------------------------------------------------------------------------- Used pointers @@ -59,6 +70,9 @@ instance Pointers Ptr where instance Pointers a => Pointers [a] where pointers = Set.unions . map pointers +instance (Pointers a, Pointers b) => Pointers (a, b) where + pointers (a, b) = Set.union (pointers a) (pointers b) + instance Pointers Match where pointers (Match _pat e) = pointers e @@ -66,7 +80,7 @@ instance Pointers ConApp where pointers (ConApp _ es) = pointers es instance Pointers PrimApp where - pointers (PrimApp _ es) = pointers es + pointers (PrimApp _ es) = pointers es instance Pointers Term where pointers (TVar _) = Set.empty @@ -74,8 +88,16 @@ instance Pointers Term where pointers (TLam _ e) = pointers e pointers (TPtr ptr) = pointers ptr pointers (TCon ces) = pointers ces - pointers (TCase e ms) = Set.union (pointers e) (pointers ms) - pointers (TLet _ e1 e2) = pointers [e1, e2] + pointers (TCase e ms) = pointers (e, ms) + pointers (TLet bound e) = pointers (map snd bound, e) pointers (TPrim pes) = pointers pes pointers (TIf c t f) = pointers [c, t, f] pointers (TSeq e1 e2) = pointers [e1, e2] + +instance Pointers Branches where + pointers (Matches ms) = pointers ms + pointers (Selector s) = pointers s + +instance Pointers Selector where + pointers _ = Set.empty + diff --git a/src/CBN/Heap.hs b/src/CBN/Heap.hs index 322766a..598e78f 100644 --- a/src/CBN/Heap.hs +++ b/src/CBN/Heap.hs @@ -8,6 +8,7 @@ module CBN.Heap ( , emptyHeap , deref , alloc + , allocMany , mutate , initHeap , pprintPtr @@ -72,12 +73,37 @@ emptyHeap = Heap 0 Map.empty -- | Allocate a new value on the heap -- -- The value is allowed to depend on the new heap pointer. -alloc :: Maybe String -> Heap a -> (Ptr -> a) -> (Heap a, Ptr) -alloc name (Heap next hp) e = - (Heap (next + 1) (Map.insert ptr (e ptr) hp), ptr) +alloc :: forall a. Maybe String -> Heap a -> (Ptr -> a) -> (Heap a, Ptr) +alloc name hp e = + allocMany [(name, \ptr -> (ptr, e ptr))] aux hp where - ptr :: Ptr - ptr = Ptr (Just next) name + aux :: [(Ptr, a)] -> ([(Ptr, a)], Ptr) + aux [(ptr, a)] = ([(ptr, a)], ptr) + aux _ = error "alloc: impossible" + +-- | Generalization of 'alloc' to multiple bindings +-- +-- This signature is carefully constructed such the allocation for each binding +-- can affect /all/ other bindings +allocMany :: forall a b r. + [(Maybe String, Ptr -> b)] -- ^ New entries (with to-be-allocated pointers) + -> ([b] -> ([(Ptr, a)], r)) -- ^ Process all bindings at once + -> Heap a -> (Heap a, r) +allocMany toAlloc procAllBindings (Heap next hp) = ( + Heap { + heapNextAvailable = next + length newEntries + , heapEntries = Map.union (Map.fromList newEntries) hp + } + , result + ) + where + newEntries :: [(Ptr, a)] + result :: r + (newEntries, result) = + procAllBindings $ zipWith aux toAlloc [next..] + where + aux :: (Maybe String, Ptr -> b) -> Int -> b + aux (name, f) n = f $ Ptr (Just n) name deref :: (Heap a, Ptr) -> Maybe a deref (Heap _ hp, ptr) = Map.lookup ptr hp diff --git a/src/CBN/InlineHeap.hs b/src/CBN/InlineHeap.hs new file mode 100644 index 0000000..5bdf7d2 --- /dev/null +++ b/src/CBN/InlineHeap.hs @@ -0,0 +1,47 @@ +module CBN.InlineHeap (inlineHeap) where + +import Data.Bifunctor +import Data.Set (Set) +import Data.List (partition) + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import CBN.Heap +import CBN.Language +import CBN.Subst + +{------------------------------------------------------------------------------- + Simplification + + We only heap allocate non-simple terms, to keep things readable. However, + during evaluation previously heap-allocated terms may /become/ simple. If + simplification is enabled, we then "remove" these from the heap by inlining + them. +-------------------------------------------------------------------------------} + +inlineHeap :: Heap Term -> Term -> (Heap Term, Term, Set Ptr) +inlineHeap (Heap next entries) e = ( + Heap { + heapNextAvailable = next + , heapEntries = Map.fromList $ + map (second (substPtrs toInline)) toKeep + } + , substPtrs toInline e + , Set.fromList $ map fst toInline + ) + where + toInline, toKeep :: [(Ptr, Term)] + (toInline, toKeep) = partition (canInline . snd) (Map.toList entries) + +canInline :: Term -> Bool +canInline TVar{} = False +canInline TApp{} = False +canInline TLam{} = False +canInline TLet{} = False +canInline TPtr{} = True +canInline TCase{} = False +canInline TIf{} = False +canInline TSeq{} = False +canInline (TPrim (PrimApp _ es)) = null es -- if args then is application +canInline (TCon (ConApp _ es)) = all canInline es \ No newline at end of file diff --git a/src/CBN/Language.hs b/src/CBN/Language.hs index 092f2ec..8021353 100644 --- a/src/CBN/Language.hs +++ b/src/CBN/Language.hs @@ -10,6 +10,15 @@ module CBN.Language ( , ConApp(..) , PrimApp(..) , Term(..) + , Branches(..) + , Selector(..) + -- * Classification + , termIsSimple + -- * Interpretation of selectors + , selectorCon + , selectorVars + , selectorIndex + , selectorMatch -- * Values , Value(..) , valueToTerm @@ -27,6 +36,7 @@ import Data.String (IsString) import CBN.Heap import CBN.Util.Snoc (Snoc) + import qualified CBN.Util.Snoc as Snoc {------------------------------------------------------------------------------- @@ -56,9 +66,12 @@ data Match = Match Pat Term -- | Primitives data Prim = PInt Integer + | PISucc | PIAdd | PISub | PIMul + | PIMin + | PIMax | PIEq | PILt | PILe @@ -74,18 +87,72 @@ data PrimApp = PrimApp Prim [Term] -- | Term data Term = - TVar Var -- ^ Variable - | TApp Term Term -- ^ Application - | TLam Var Term -- ^ Lambda abstraction - | TLet Var Term Term -- ^ (Recursive) let binding - | TPtr Ptr -- ^ Heap pointer - | TCon ConApp -- ^ Constructor application - | TCase Term [Match] -- ^ Pattern match - | TPrim PrimApp -- ^ Primitives (built-ins) - | TIf Term Term Term -- ^ Conditional - | TSeq Term Term -- ^ Force evaluation + TVar Var -- ^ Variable + | TApp Term Term -- ^ Application + | TLam Var Term -- ^ Lambda abstraction + | TLet [(Var, Term)] Term -- ^ (Mutually recursive) let binding + | TPtr Ptr -- ^ Heap pointer + | TCon ConApp -- ^ Constructor application + | TCase Term Branches -- ^ Pattern match + | TPrim PrimApp -- ^ Primitives (built-ins) + | TIf Term Term Term -- ^ Conditional + | TSeq Term Term -- ^ Force evaluation + deriving (Show, Data, Eq) + +-- | Branches of a case statement +data Branches = + -- | User-defined branches (normal case statement) + Matches [Match] + + -- | Selector + | Selector Selector deriving (Show, Data, Eq) +-- | Selectors +data Selector = + Fst + | Snd + deriving (Show, Data, Eq) + +{------------------------------------------------------------------------------- + Classification +-------------------------------------------------------------------------------} + +-- | Is this a "simple" term? +-- +-- A simple term is one that we can substitute freely, even if multiple times, +-- without losing sharing. +termIsSimple :: Term -> Bool +termIsSimple (TPtr _) = True +termIsSimple (TCon (ConApp _ [])) = True +termIsSimple (TPrim (PrimApp _ [])) = True +termIsSimple _ = False + +{------------------------------------------------------------------------------- + Interpretation of selectors +-------------------------------------------------------------------------------} + +-- | Constructor name this selector matches against +selectorCon :: Selector -> Con +selectorCon Fst = Con "Pair" +selectorCon Snd = Con "Pair" + +-- | Variable names for the implied case statement of this selector +selectorVars :: Selector -> [Var] +selectorVars Fst = [Var "x", Var "y"] +selectorVars Snd = [Var "x", Var "y"] + +-- | Which argument does this selector extract? +selectorIndex :: Selector -> Int +selectorIndex Fst = 0 +selectorIndex Snd = 1 + +selectorMatch :: Selector -> Match +selectorMatch s = + Match + (Pat (selectorCon s) (selectorVars s)) + (TVar $ selectorVars s !! selectorIndex s) + {------------------------------------------------------------------------------- Values -------------------------------------------------------------------------------} diff --git a/src/CBN/Options.hs b/src/CBN/Options.hs index 465106d..bf8dbc9 100644 --- a/src/CBN/Options.hs +++ b/src/CBN/Options.hs @@ -10,11 +10,14 @@ data Options = Options { optionsInput :: FilePath , optionsShowTrace :: Bool , optionsGC :: Bool + , optionsSelThunkOpt :: Bool + , optionsInlineHeap :: Bool , optionsSummarize :: SummarizeOptions , optionsJsOutput :: Maybe FilePath , optionsJsName :: String , optionsGraphOutput :: Maybe FilePath , optionsGraphTermsOutput :: Maybe FilePath + , optionsDisableAnsi :: Bool } deriving (Show) @@ -36,6 +39,14 @@ parseOptions = Options long "gc" , help "GC after each step" ]) + <*> (switch $ mconcat [ + long "selector-thunk-opt" + , help "Enable the selector thunk optimization" + ]) + <*> (switch $ mconcat [ + long "inline-heap" + , help "Simplify the heap by inlining simple terms after each step" + ]) <*> parseSummarizeOptions <*> (optional . strOption $ mconcat [ long "javascript" @@ -59,6 +70,10 @@ parseOptions = Options , help "Generate one graph representation file for each step" , metavar "PATH/FILES-PREFIX" ]) + <*> (switch $ mconcat [ + long "disable-ansi" + , help "Disable ANSI escapes codes for terminal output (no color)" + ]) parseSummarizeOptions :: Parser SummarizeOptions parseSummarizeOptions = SummarizeOptions @@ -85,3 +100,11 @@ parseSummarizeOptions = SummarizeOptions long "hide-gc" , help "Hide GC steps" ]) + <*> (switch $ mconcat [ + long "hide-selector-thunk-opt" + , help "Hide steps where the selector thunk optimization gets applied" + ]) + <*> (switch $ mconcat [ + long "hide-inlining" + , help "Hide heap inlining steps" + ]) diff --git a/src/CBN/Parser.hs b/src/CBN/Parser.hs index e9f4e7d..a6f6dc5 100644 --- a/src/CBN/Parser.hs +++ b/src/CBN/Parser.hs @@ -6,6 +6,7 @@ module CBN.Parser ( , parseIO ) where +import Control.Applicative (asum) import Control.Exception import Control.Monad import Data.Bifunctor @@ -15,8 +16,9 @@ import Text.Parsec import Text.Parsec.Language (haskellDef) import Text.Parsec.Pos (newPos) import Text.Parsec.String -import qualified Text.Parsec.Token as P + import qualified Language.Haskell.TH as TH +import qualified Text.Parsec.Token as P import CBN.Language import CBN.Heap @@ -88,9 +90,7 @@ parseTermNoApp = msum [ <* reservedOp "->" <*> parseTerm , TLet <$ reserved "let" - <*> parseVar - <* reservedOp "=" - <*> parseTerm + <*> parseLetBound <* reservedOp "in" <*> parseTerm , TIf <$ reserved "if" @@ -99,10 +99,12 @@ parseTermNoApp = msum [ <*> parseTerm <* reserved "else" <*> parseTerm - , TCase <$ reserved "case" + , case1 <$ reserved "case" <*> parseTerm <* reserved "of" <*> braces (parseMatch `sepBy` reservedOp ";") + , case2 <$> parseSelector + <*> parseTerm , TVar <$> parseVar , parens parseTerm ] @@ -113,15 +115,42 @@ parseTermNoApp = msum [ unaryTCon :: Con -> Term unaryTCon c = TCon (ConApp c []) + case1 :: Term -> [Match] -> Term + case1 t ms = TCase t (Matches ms) + + case2 :: Selector -> Term -> Term + case2 s t = TCase t (Selector s) + +parseSelector :: Parser Selector +parseSelector = msum [ + Fst <$ reserved "fst" + , Snd <$ reserved "snd" + ] + +parseLetBound :: Parser [(Var, Term)] +parseLetBound = asum [ + (:[]) <$> parseOne + , braces (parseOne `sepBy` reservedOp ";") + ] + where + parseOne :: Parser (Var, Term) + parseOne = + (,) <$> parseVar + <* reservedOp "=" + <*> parseTerm + parsePrim :: Parser Prim parsePrim = msum [ - PInt <$> natural - , PIAdd <$ reserved "add" - , PISub <$ reserved "sub" - , PIMul <$ reserved "mul" - , PILt <$ reserved "lt" - , PIEq <$ reserved "eq" - , PILe <$ reserved "le" + PInt <$> natural + , PISucc <$ reserved "succ" + , PIAdd <$ reserved "add" + , PISub <$ reserved "sub" + , PIMul <$ reserved "mul" + , PIMin <$ reserved "min" + , PIMax <$ reserved "max" + , PILt <$ reserved "lt" + , PIEq <$ reserved "eq" + , PILe <$ reserved "le" ] -- | Our input files consist of an initial heap and the term to be evaluated @@ -150,9 +179,11 @@ lexer = P.makeTokenParser haskellDef { , "of" , "let" , "in" + , "succ" , "add" , "sub" , "mul" + , "max" , "lt" , "eq" , "le" @@ -161,6 +192,8 @@ lexer = P.makeTokenParser haskellDef { , "else" , "main" , "seq" + , "fst" + , "snd" ] , P.reservedOpNames = [ "\\" diff --git a/src/CBN/Pretty.hs b/src/CBN/Pretty.hs index 56414f1..a108a64 100644 --- a/src/CBN/Pretty.hs +++ b/src/CBN/Pretty.hs @@ -1,11 +1,9 @@ {-# LANGUAGE CPP #-} module CBN.Pretty (ToDoc, toDoc, heapToDoc) where -#if !(MIN_VERSION_base(4,11,0)) -import Data.Monoid -#endif import Data.List (intersperse) import Data.Set (Set) + import qualified Data.Map as Map import qualified Data.Set as Set @@ -38,9 +36,12 @@ instance ToDoc Con where instance ToDoc Prim where toDoc (PInt n) = doc (show n) + toDoc PISucc = doc "succ" toDoc PIAdd = doc "add" toDoc PISub = doc "sub" toDoc PIMul = doc "mul" + toDoc PIMin = doc "min" + toDoc PIMax = doc "max" toDoc PIEq = doc "eq" toDoc PILt = doc "lt" toDoc PILe = doc "le" @@ -73,7 +74,7 @@ instance ToDoc Pat where toDoc (Pat (Con "Cons") [x, xs]) = toDoc x <> doc ":" <> toDoc xs toDoc (Pat (Con "Pair") [x, xs]) = parensIf True $ - toDoc x <> doc "," <> toDoc xs + toDoc x <> doc "," <+> toDoc xs toDoc (Pat c xs) = hsep (toDoc c : map toDoc xs) @@ -86,6 +87,10 @@ instance ToDoc Match where matchRow :: FixityContext -> Match -> [Doc Style String] matchRow fc (Match p rhs) = [toDoc p, doc " -> ", toDoc' fc rhs] +-- | Table-row for a multiple-binder let statement +letRow :: (Var, Term) -> [Doc Style String] +letRow (x, t) = [toDoc x, doc " = ", toDoc t] + -- | We make elements from the prelude blue instance ToDoc Ptr where toDoc (Ptr Nothing Nothing) = error "invalid pointer" @@ -118,7 +123,7 @@ instance ToDoc Term where doc "\\" <> hsep (map toDoc (x:xs)) <+> doc "->" <+> toDoc' (R Lam) e' where (xs, e') = collectArgs e - toDoc' fc (TLet x e1 e2) = parensIfChoice (needsParens fc Let) [ + toDoc' fc (TLet [(x, e1)] e2) = parensIfChoice (needsParens fc Let) [ stack [ kw "let" <+> x' <+> doc "=" <+> e1' <+> kw "in" , e2' @@ -129,7 +134,13 @@ instance ToDoc Term where x' = toDoc x e1' = toDoc' Top e1 e2' = toDoc' (R Let) e2 - toDoc' fc (TCase e ms) = parensIfChoice (needsParens fc Case) [ + toDoc' fc (TLet bound e) = parensIf (needsParens fc Let) $ + stack [ + kw "let" <+> doc "{" + , indent $ table $ map letRow bound + , doc "}" <+> kw "in" <+> toDoc' (R Let) e + ] + toDoc' fc (TCase e (Matches ms)) = parensIfChoice (needsParens fc Case) [ stack [ kw "case" <+> e' <+> kw "of" <+> doc "{" , indent $ table $ map (matchRow (R Case)) ms @@ -140,6 +151,8 @@ instance ToDoc Term where where e' = toDoc' (L Case) e ms' = map (toDoc' (R Case)) ms + toDoc' fc (TCase e (Selector s)) = parensIf (needsParens fc P.Ap) $ + toDoc' (L P.Ap) s <+> toDoc' (R P.Ap) e toDoc' fc (TIf c t f) = parensIfChoice (needsParens fc If) [ stack [ kw "if" <+> c' @@ -155,6 +168,10 @@ instance ToDoc Term where t' = toDoc' (R If) t f' = toDoc' (R If) f +instance ToDoc Selector where + toDoc Fst = doc "fst" + toDoc Snd = doc "snd" + instance ToDoc Closure where toDoc cl = case cl of ErrorClosure str -> doc "Error :" <+> doc str @@ -165,13 +182,14 @@ instance ToDoc Closure where PrimClosure prim _ -> doc "Primary :" <+> toDoc prim instance ToDoc Description where - toDoc StepAlloc = doc "allocate" - toDoc StepBeta = doc "beta reduction" - toDoc (StepApply f) = doc "apply" <+> toDoc f - toDoc (StepDelta pes) = doc "delta:" <+> toDoc pes - toDoc (StepMatch c) = doc "match" <+> toDoc c - toDoc (StepIf b) = doc "if" <+> doc (show b) - toDoc StepSeq = doc "seq" + toDoc StepAlloc = doc "allocate" + toDoc StepBeta = doc "beta reduction" + toDoc (StepApply f) = doc "apply" <+> toDoc f + toDoc (StepDelta pes) = doc "delta:" <+> toDoc pes + toDoc (StepMatch c) = doc "match" <+> toDoc c + toDoc (StepIf b) = doc "if" <+> doc (show b) + toDoc StepSeq = doc "seq" + toDoc StepAllocConArgs = doc "allocate constructor arguments" -- | Based on purescript implementation mintersperse :: (Monoid m) => m -> [m] -> m @@ -189,16 +207,20 @@ instance ToDoc DescriptionWithContext where ] -- | For the heap we need to know which pointers we are about to collect -heapToDoc :: forall a. ToDoc a => Set Ptr -> Heap a -> Doc Style String -heapToDoc garbage (Heap _next heap) = +heapToDoc :: forall a. ToDoc a + => Set Ptr -- ^ To be collected + -> Maybe Ptr -- ^ Focus (where are we going to take a step?) + -> Heap a -> Doc Style String +heapToDoc garbage focus (Heap _next heap) = table $ map go (Map.toList heap) where go :: (Ptr, a) -> [Doc Style String] - go (ptr, a) = [markGarbage ptr $ toDoc ptr, doc " = ", toDoc a] + go (ptr, a) = [mark ptr $ toDoc ptr, doc " = ", toDoc a] - markGarbage :: Ptr -> Doc Style String -> Doc Style String - markGarbage ptr + mark :: Ptr -> Doc Style String -> Doc Style String + mark ptr | ptr `Set.member` garbage = style $ \st -> st { styleBackground = Just Red } + | Just ptr == focus = style $ \st -> st { styleBackground = Just Green } | otherwise = id {------------------------------------------------------------------------------- diff --git a/src/CBN/SelThunkOpt.hs b/src/CBN/SelThunkOpt.hs new file mode 100644 index 0000000..44a8aad --- /dev/null +++ b/src/CBN/SelThunkOpt.hs @@ -0,0 +1,110 @@ +{------------------------------------------------------------------------------- + Selector (thunk) optimization + + References: + + - "Fixing some space leaks with a garbage collector", Philip Walder + + + - "A Concurrent Garbage Collector for the Glasgow Haskell Compiler", Ben Gamari + + 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" + +-------------------------------------------------------------------------------} + +module CBN.SelThunkOpt (selThunkOpt) where + +import Control.Applicative +import Control.Monad.State +import Data.Set (Set) + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import CBN.Eval +import CBN.Heap +import CBN.Language + +-- | Apply selector thunk optimization +selThunkOpt :: Heap Term -> (Heap Term, Set Ptr) +selThunkOpt = findAll Set.empty + where + findAll :: Set Ptr -> Heap Term -> (Heap Term, Set Ptr) + findAll acc hp = + case asum $ map (findOne hp) (Map.toList $ heapEntries hp) of + Nothing -> (hp, acc) + Just (ptr, hp') -> findAll (Set.insert ptr acc) hp' + + -- Find one term to step + findOne :: Heap Term -> (Ptr, Term) -> Maybe (Ptr, Heap Term) + findOne hp (ptr, e) = do + (hp', e') <- applyInTerm hp e + return (ptr, mutate (hp', ptr) e') + +-- | Apply selector-thunk optimization in this term +-- +-- Returns 'Nothing' if there were no opportunities to apply the optimization. +applyInTerm :: Heap Term -> Term -> Maybe (Heap Term, Term) +applyInTerm = \hp term -> do + let (term', (hp', isChanged)) = runState (go term) (hp, False) + guard isChanged + return (hp', term') + where + go :: Term -> State (Heap Term, Bool) Term + + -- Term that cannot change + + go term@TVar{} = return term + go term@TLam{} = return term -- We don't look inside binders + go term@TPtr{} = return term + + -- Propagation + + go (TCon (ConApp con args)) = + TCon . ConApp con <$> mapM go args + go (TPrim (PrimApp prim args)) = + TPrim . PrimApp prim <$> mapM go args + go (TLet bound e) = + TLet <$> mapM (\(x, t) -> (x,) <$> go t) bound <*> go e + go (TApp e1 e2) = + TApp <$> go e1 <*> go e2 + go (TIf c t f) = + TIf <$> go c <*> go t <*> go f + go (TSeq e1 e2) = + TSeq <$> go e1 <*> go e2 + go (TCase e (Matches ms)) = + TCase <$> go e <*> (Matches <$> mapM goMatch ms) + where + goMatch :: Match -> State (Heap Term, Bool) Match + goMatch (Match pat rhs) = Match pat <$> go rhs + + -- The interesting case + -- + -- 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 + + go term@(TCase e (Selector s)) = do + (hp, _) <- get + mConApp <- + case allocConArgs (selectorVars s) (hp, e) of + ConArgsAllocFailed -> + return Nothing + ConArgsAllocUnnecessary conApp -> + return $ Just conApp + ConArgsAllocDone (_ctxt, hp', _e') conApp -> do + put (hp', True) + return $ Just conApp + case mConApp of + Just (ConApp con args) | con == selectorCon s -> do + modify $ \(hp', _) -> (hp', True) + return $ args !! selectorIndex s + _otherwise -> + return term + diff --git a/src/CBN/Subst.hs b/src/CBN/Subst.hs index b45b0f7..ac33b9d 100644 --- a/src/CBN/Subst.hs +++ b/src/CBN/Subst.hs @@ -1,16 +1,26 @@ module CBN.Subst ( subst - , RecursiveBinding(..) + , substVar + , substPtr + , substVars + , substPtrs , allocSubst ) where +import Data.Bifunctor +import Data.List (partition) import Data.Map (Map) + import qualified Data.Map as Map import CBN.Free import CBN.Heap import CBN.Language +{------------------------------------------------------------------------------- + Substitution +-------------------------------------------------------------------------------} + -- | Substitution -- -- NOTE: Although we deal with shadowing here @(\x -> .. (\x -> .. ))@, we @@ -18,25 +28,39 @@ import CBN.Language -- under binders, we can never have free variables, and hence this is not -- something we need to worry about. class Subst a where - subst :: Var -> Term -> a -> a + subst :: Either Ptr Var -> Term -> a -> a + +substVar :: Subst a => Var -> Term -> a -> a +substVar = subst . Right + +substPtr :: Subst a => Ptr -> Term -> a -> a +substPtr = subst . Left + +{------------------------------------------------------------------------------- + Instances +-------------------------------------------------------------------------------} instance Subst a => Subst [a] where subst x e = map (subst x e) instance Subst Term where - subst _ _ (TPtr ptr') = TPtr ptr' - subst x e (TVar x') = if x == x' then e - else TVar x' - subst x e (TLam x' e1) = if x == x' then TLam x' e1 - else TLam x' (subst x e e1) - subst x e (TLet x' e1 e2) = if x == x' then TLet x' e1 e2 - else TLet x' (subst x e e1) (subst x e e2) - subst x e (TCon ces) = TCon (subst x e ces) - subst x e (TPrim pes) = TPrim (subst x e pes) - subst x e (TApp e1 e2) = TApp (subst x e e1) (subst x e e2) - subst x e (TCase e1 ms) = TCase (subst x e e1) (subst x e ms) - subst x e (TSeq e1 e2) = TSeq (subst x e e1) (subst x e e2) - subst x e (TIf c t f) = TIf (subst x e c) (subst x e t) (subst x e f) + subst x e term = + case term of + TPtr x' -> if x == Left x' then e else term + TVar x' -> if x == Right x' then e else term + TLam x' e1 -> if x == Right x' + then term + else TLam x' (subst x e e1) + TLet bound e' -> if x `elem` map (Right . fst) bound + then term + else TLet (map (second (subst x e)) bound) + (subst x e e') + TCon ces -> TCon (subst x e ces) + TPrim pes -> TPrim (subst x e pes) + TApp e1 e2 -> TApp (subst x e e1) (subst x e e2) + TCase e1 ms -> TCase (subst x e e1) (subst x e ms) + TSeq e1 e2 -> TSeq (subst x e e1) (subst x e e2) + TIf c t f -> TIf (subst x e c) (subst x e t) (subst x e f) instance Subst ConApp where subst x e (ConApp c es) = ConApp c (subst x e es) @@ -46,44 +70,90 @@ instance Subst PrimApp where instance Subst Match where subst x e (Match (Pat c xs) e') = - if x `elem` xs then Match (Pat c xs) e' - else Match (Pat c xs) (subst x e e') + if x `elem` map Right xs + then Match (Pat c xs) e' + else Match (Pat c xs) (subst x e e') + +instance Subst Branches where + subst x e (Matches ms) = Matches (map (subst x e) ms) + subst x e (Selector s) = Selector (subst x e s) + +instance Subst Selector where + subst _ _ = id + +{------------------------------------------------------------------------------- + Many-variable substitution +-------------------------------------------------------------------------------} + +substMany :: Subst a => [(Either Ptr Var, Term)] -> a -> a +substMany [] = id +substMany ((x, e):s) = substMany (map (second (subst x e)) s) . subst x e + +substVars :: Subst a => [(Var, Term)] -> a -> a +substVars = substMany . map (first Right) + +substPtrs :: Subst a => [(Ptr, Term)] -> a -> a +substPtrs = substMany . map (first Left) + +{------------------------------------------------------------------------------- + Heap allocation +-------------------------------------------------------------------------------} -data RecursiveBinding = RecBinding | NonRecBinding +allocSubst :: [(Var, Term)] -> (Heap Term, Term) -> (Heap Term, Term) +allocSubst bindings (heap, body) = + let toAlloc, toSubst :: [(Var, Term)] + (toAlloc, toSubst) = partition requiresAlloc bindings -allocSubst :: RecursiveBinding -> [(Var, Term)] -> (Heap Term, Term) -> (Heap Term, Term) -allocSubst recBind = go + body' :: Term + body' = substVars toSubst body + + heap' :: Heap Term + substAlloc :: [(Var, Term)] + (heap', substAlloc) = + allocMany + (map prepareHeapEntry $ map (second (substVars toSubst)) toAlloc) + processHeapEntries + heap + + in (heap', substVars substAlloc body') where - go :: [(Var, Term)] -> (Heap Term, Term) -> (Heap Term, Term) - go [] (hp, e) = (hp, e) - go ((x, s):ss) (hp, e) - | isSimple s = go ss (hp, subst x s e) - | singleUse x s e = go ss (hp, subst x s e) - | otherwise = - let (hp', ptr) = alloc (Just (varName x)) hp (substRec x s) - e' = subst x (TPtr ptr) e - in go ss (hp', e') - - -- Is this a "simple" term (one that we can substitute freely, even if - -- multiple times)? - isSimple :: Term -> Bool - isSimple (TPtr _) = True - isSimple (TCon (ConApp _ [])) = True - isSimple (TPrim (PrimApp _ [])) = True - isSimple _ = False - - -- Is there (at most) only one use of this term? - -- (If so, we substitute rather than allocate on the heap) - -- If there are recursive occurrences we return False by definition. - singleUse :: Var -> Term -> Term -> Bool - singleUse x s e - | RecBinding <- recBind, x `Map.member` free_s = False - | otherwise = Map.findWithDefault 0 x free_e <= 1 + -- We all all post-processing in 'processHeapEntries' + prepareHeapEntry :: (Var, Term) -> (Maybe String, Ptr -> (Var, Term, Ptr)) + prepareHeapEntry (x, t) = ( + Just (varName x) + , \ptr -> (x, t, ptr) + ) + + -- New heap entries, along with substitution for all heap-allocated vars + processHeapEntries :: [(Var, Term, Ptr)] -> ([(Ptr, Term)], [(Var, Term)]) + processHeapEntries entries = ( + map (\(_, t, ptr) -> (ptr, substVars substAlloc t)) entries + , substAlloc + ) + where + substAlloc :: [(Var, Term)] + substAlloc = map (\(x, _, ptr) -> (x, TPtr ptr)) entries + + -- Do we need to allocate this term? + requiresAlloc :: (Var, Term) -> Bool + requiresAlloc (x, t) = and [ + not $ termIsSimple t + , not $ isUsedOnceInBody x + ] + + -- Is this binding used only once, and only in the body? + isUsedOnceInBody :: Var -> Bool + isUsedOnceInBody x = and [ + x `notElem` Map.keys freeInBindings + , Map.findWithDefault 0 x freeInBody <= 1 + ] where - free_s, free_e :: Map Var Count - free_s = free s - free_e = free e + freeInBindings, freeInBody :: Map Var Count + freeInBindings = free $ map snd bindings + freeInBody = free body + + + + + - substRec :: Var -> Term -> Ptr -> Term - substRec x s ptr | RecBinding <- recBind = subst x (TPtr ptr) s - | otherwise = s diff --git a/src/CBN/Trace.hs b/src/CBN/Trace.hs index dc9e5f3..65c2dfd 100644 --- a/src/CBN/Trace.hs +++ b/src/CBN/Trace.hs @@ -15,7 +15,9 @@ import qualified Data.Set as Set import CBN.Eval import CBN.Free import CBN.Heap +import CBN.InlineHeap import CBN.Language +import CBN.SelThunkOpt {------------------------------------------------------------------------------- Constructing the trace @@ -39,21 +41,56 @@ data TraceCont = -- | The garbage collector removed some pointers | TraceGC (Set Ptr) Trace -traceTerm :: Bool -> (Heap Term, Term) -> Trace -traceTerm shouldGC = go + -- | The selector thunk optimization was applied + | TraceSelThunk (Set Ptr) Trace + + -- | We simplified the heap by inlining some definitions + | TraceInline (Set Ptr) Trace + +traceTerm :: Bool -> Bool -> Bool -> (Heap Term, Term) -> Trace +traceTerm shouldGC shouldInline enableSelThunkOpt = go where go :: (Heap Term, Term) -> Trace go (hp, e) = Trace (hp, e) $ case step (hp, e) of WHNF val -> TraceWHNF val Stuck err -> TraceStuck err - Step d (hp', e') -> TraceStep d $ - if shouldGC - then let (hp'', collected) = gc e' hp' - in if Set.null collected - then go (hp'', e') - else Trace (hp', e') $ TraceGC collected $ go (hp'', e') - else go (hp', e') + Step d (hp1, e1) -> + let (traceSelThunkOpt, hp2, e2) + | enableSelThunkOpt + = let (hp', optimized) = selThunkOpt hp1 + in if Set.null optimized then + (id, hp1, e1) + else + (Trace (hp1, e1) . TraceSelThunk optimized, hp', e1) + | otherwise + = (id, hp1, e1) in + + let (traceGC, hp3, e3) + | shouldGC + = let (hp', collected) = gc e2 hp2 + in if Set.null collected then + (id, hp2, e2) + else + (Trace (hp2, e2) . TraceGC collected, hp', e2) + + | otherwise + = (id, hp2, e2) in + + let (traceInlining, hp4, e4) + | shouldInline + = let (hp', e', inlined) = inlineHeap hp3 e3 + in if Set.null inlined then + (id, hp3, e3) + else + (Trace (hp3, e3) . TraceInline inlined, hp', e') + + | otherwise + = (id, hp3, e3) in + + TraceStep d + $ traceSelThunkOpt . traceGC . traceInlining + $ go (hp4, e4) gc :: Term -> Heap Term -> (Heap Term, Set Ptr) gc = markAndSweep . pointers @@ -68,39 +105,85 @@ data SummarizeOptions = SummarizeOptions { , summarizeHidePrelude :: Bool , summarizeHideTerms :: [String] , summarizeHideGC :: Bool + , summarizeHideSelThunk :: Bool + , summarizeHideInlining :: Bool } deriving (Show) summarize :: SummarizeOptions -> Trace -> Trace summarize SummarizeOptions{..} = go 0 where + -- If we have + -- + -- > step1 step2 + -- > x ------> y ------> z + -- + -- and we want to hide step2 (say, GC), then we want to get + -- + -- > x step1 + -- > x -------> z + -- + -- We will realize we want to hide this step when we look at @step2@; this + -- means that we may want to hide the /source/ of the step (@y@), and + -- instead show the destination (@z@). go :: Int -> Trace -> Trace - go n (Trace (hp, e) c) = Trace (goHeap hp, e) $ goCont n c - - goCont :: Int -> TraceCont -> TraceCont - goCont _ (TraceWHNF v) = TraceWHNF v - goCont _ (TraceStuck err) = TraceStuck err - goCont _ TraceStopped = TraceStopped - goCont n (TraceGC ps t'@(Trace _ c')) = - if summarizeHideGC - then goCont (n + 1) c' - else TraceGC ps $ go (n + 1) t' - goCont n (TraceStep dwc@(DescriptionWithContext d _) t) = - case d of - _ | n > summarizeMaxNumSteps -> - TraceStopped - StepApply _ | summarizeCollapseBeta -> - TraceStep dwc $ goBeta (n + 1) t - StepBeta | summarizeCollapseBeta -> - TraceStep dwc $ goBeta (n + 1) t - _otherwise -> - TraceStep dwc $ go (n + 1) t + go n (Trace (hp, e) c) = + case c of + -- End of the trace + + TraceWHNF v -> showSrc $ TraceWHNF v + TraceStuck err -> showSrc $ TraceStuck err + TraceStopped -> showSrc $ TraceStopped + TraceStep{} + | n > summarizeMaxNumSteps + -> showSrc $ TraceStopped + + + -- Potential hiding steps + + TraceGC ps t' -> + if summarizeHideGC + then go (n + 1) t' + else showSrc $ TraceGC ps $ go (n + 1) t' + TraceSelThunk ps t' -> + if summarizeHideGC + then go (n + 1) t' + else showSrc $ TraceSelThunk ps $ go (n + 1) t' + TraceInline ps t' -> + if summarizeHideInlining + then go (n + 1) t' + else showSrc $ TraceInline ps $ go (n + 1) t' + + -- Collapsing multiple beta-reductions + -- + -- This is a little different because we don't want to hide the + -- step from the trace entirely; we just want to collapse multiple + -- steps into one, but still marking that as a beta step. + + TraceStep dwc t' -> + if summarizeCollapseBeta && isBetaStep dwc + then Trace (hp, e) $ goBeta (n + 1) t' + else showSrc $ TraceStep dwc $ go (n + 1) t' + + where + showSrc :: TraceCont -> Trace + showSrc = Trace (goHeap hp, e) -- | We already saw one beta reduction; skip any subsequent ones - goBeta :: Int -> Trace -> Trace - goBeta n t@(Trace _ c) = case c of - TraceStep (DescriptionWithContext StepBeta _) t' -> goBeta (n + 1) t' - _otherwise -> go (n + 1) t + goBeta :: Int -> Trace -> TraceCont + goBeta n t@(Trace _ c) = + case c of + TraceStep dwc t' | isBetaStep dwc -> + goBeta (n + 1) t' + _otherwise -> + TraceStep (DescriptionWithContext StepBeta []) $ go n t + + isBetaStep :: DescriptionWithContext -> Bool + isBetaStep (DescriptionWithContext d _ctxt) = + case d of + StepBeta -> True + StepApply{} -> True + _otherwise -> False -- | Cleanup the heap goHeap :: Heap Term -> Heap Term @@ -113,3 +196,5 @@ summarize SummarizeOptions{..} = go 0 , not (name `elem` summarizeHideTerms) ] shouldShow (Ptr _ _) _ = True + + diff --git a/src/CBN/Trace/Graph.hs b/src/CBN/Trace/Graph.hs index d1e5cd5..a1a1452 100644 --- a/src/CBN/Trace/Graph.hs +++ b/src/CBN/Trace/Graph.hs @@ -2,17 +2,20 @@ module CBN.Trace.Graph (render) where -import CBN.Eval -import CBN.Heap -import CBN.Pretty -import CBN.Trace +import Data.Set (Set) +import Data.Maybe (listToMaybe) + +import qualified Data.Set as Set +import qualified Data.Text as T + +import CBN.Eval +import CBN.Heap +import CBN.Pretty +import CBN.Trace +import CBN.Util.Doc.Style + import qualified CBN.Util.Doc as Doc import qualified CBN.Util.Doc.Rendered as Rendered -import CBN.Util.Doc.Style -import Data.Monoid ((<>)) -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as T render :: Trace -> String render tr = @@ -24,14 +27,16 @@ render tr = go :: Int -> Trace -> String go index (Trace (hp, t) cont) = case cont of - TraceWHNF _ -> mkFrame Set.empty "whnf" - TraceStuck err -> mkFrame Set.empty (mkErr err) - TraceStopped -> mkFrame Set.empty "stopped" - TraceStep d tr' -> mkFrame Set.empty (mkDesc d) ++ go (index + 1) tr' - TraceGC ps tr' -> mkFrame ps "gc" ++ 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 -> T.Text -> String - mkFrame garbage status = + mkFrame :: Set Ptr -> Maybe Ptr -> T.Text -> String + mkFrame garbage focus status = T.unpack $ setLabel index ("<" <> rows <> "
>") <> "\n" @@ -39,7 +44,7 @@ render tr = where rows :: T.Text rows = mkRow (pretty t) - <> mkRow (pretty (heapToDoc garbage hp)) + <> mkRow (pretty (heapToDoc garbage focus hp)) <> mkRow status mkRow :: T.Text -> T.Text @@ -85,7 +90,14 @@ render tr = toDotHtml (Style Nothing _ True _, str) = "" <> escapeChars str <> "" toDotHtml (Style Nothing _ _ True, str) = "" <> escapeChars str <> "" toDotHtml (Style (Just fg) _ _ _, str) = - let color = case fg of Blue -> "blue"; Red -> "red" + let color = case fg of + Blue -> "blue" + Red -> "red" + Green -> "green" in " color <> "\">" <> escapeChars str <> "" toDotHtml (Style Nothing _ False False, str) = escapeChars str + + mkFocus :: DescriptionWithContext -> Maybe Ptr + mkFocus (DescriptionWithContext _ ctxt) = listToMaybe (reverse ctxt) + diff --git a/src/CBN/Trace/HeapGraph.hs b/src/CBN/Trace/HeapGraph.hs index b5ded41..655c4d8 100644 --- a/src/CBN/Trace/HeapGraph.hs +++ b/src/CBN/Trace/HeapGraph.hs @@ -6,7 +6,6 @@ module CBN.Trace.HeapGraph (toGraphFiles) where import Control.Monad import Data.Graph (Graph) -import Data.Monoid ((<>)) import qualified Data.Graph as Graph import qualified Data.Text as T @@ -77,7 +76,10 @@ renderMemoryGraph (graph, f, g) = toDotHtml (Style Nothing _ True _, str) = "" <> escapeChars str <> "" toDotHtml (Style Nothing _ _ True, str) = "" <> escapeChars str <> "" toDotHtml (Style (Just fg) _ _ _, str) = - let color = case fg of Blue -> "blue"; Red -> "red" + let color = case fg of + Blue -> "blue" + Red -> "red" + Green -> "green" in " color <> "\">" <> escapeChars str <> "" toDotHtml (Style Nothing _ False False, str) = escapeChars str diff --git a/src/CBN/Trace/JavaScript.hs b/src/CBN/Trace/JavaScript.hs index d4d0a6b..5416f3f 100644 --- a/src/CBN/Trace/JavaScript.hs +++ b/src/CBN/Trace/JavaScript.hs @@ -1,8 +1,10 @@ module CBN.Trace.JavaScript (render) where +import Data.Maybe (listToMaybe) import Data.Set (Set) import Text.Blaze.Html.Renderer.String import Text.Blaze.Html5 (toHtml) + import qualified Data.Set as Set import CBN.Eval @@ -10,6 +12,7 @@ import CBN.Heap import CBN.Pretty import CBN.Trace import CBN.Util.Doc.Rendered.HTML () + import qualified CBN.Util.Doc as Doc import qualified CBN.Util.Doc.Rendered as Rendered @@ -39,16 +42,18 @@ render name graph = \tr -> go :: Int -> Trace -> String go n (Trace (hp, e) c) = case c of - TraceWHNF _ -> mkFrame Set.empty "whnf" - TraceStuck err -> mkFrame Set.empty (mkErr err) - TraceStopped -> mkFrame Set.empty "stopped" - TraceStep d tr' -> mkFrame Set.empty (mkDesc d) ++ go (n + 1) tr' - TraceGC ps tr' -> mkFrame ps "gc" ++ 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 -> String -> String - mkFrame garbage status = + mkFrame :: Set Ptr -> Maybe Ptr -> String -> String + mkFrame garbage focus status = "if(frame == " ++ show n ++ ") {\n" - ++ set "heap" (pretty (heapToDoc garbage hp)) + ++ set "heap" (pretty (heapToDoc garbage focus hp)) ++ set "term" (pretty e) ++ set "status" status ++ "}\n" @@ -70,3 +75,6 @@ render name graph = \tr -> . toHtml . Doc.render (\r -> Rendered.width r <= 80) . toDoc + + mkFocus :: DescriptionWithContext -> Maybe Ptr + mkFocus (DescriptionWithContext _ ctxt) = listToMaybe (reverse ctxt) diff --git a/src/CBN/Trace/Textual.hs b/src/CBN/Trace/Textual.hs index e80255d..a2a3fed 100644 --- a/src/CBN/Trace/Textual.hs +++ b/src/CBN/Trace/Textual.hs @@ -1,40 +1,56 @@ module CBN.Trace.Textual (renderIO) where import Data.List (intersperse) +import Data.Maybe (listToMaybe) import Data.Set (Set) + import qualified Data.Set as Set +import CBN.Eval import CBN.Heap -import CBN.Trace import CBN.Pretty -import qualified CBN.Util.Doc as Doc -import qualified CBN.Util.Doc.Rendered as Rendered -import qualified CBN.Util.Doc.Rendered.ANSI as ANSI +import CBN.Trace -renderIO :: Trace -> IO () -renderIO = go 0 +import qualified CBN.Util.Doc as Doc +import qualified CBN.Util.Doc.Rendered as Rendered +import qualified CBN.Util.Doc.Rendered.ANSI as ANSI +import qualified CBN.Util.Doc.Rendered.String as String + +renderIO :: Bool -> Trace -> IO () +renderIO disableAnsi = go 0 where go :: Int -> Trace -> IO () go n (Trace (hp, e) c) = do case c of - TraceWHNF _ -> mkFrame Set.empty (putStr $ "whnf") - TraceStuck err -> mkFrame Set.empty (putStr $ "stuck: " ++ err) - TraceStopped -> mkFrame Set.empty (putStr $ "stopped") - TraceStep d tr' -> mkFrame Set.empty (pretty d) >> go (n + 1) tr' - TraceGC ps tr' -> mkFrame ps (goPtrs 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 "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' where - mkFrame :: Set Ptr -> IO () -> IO () - mkFrame garbage msg = do + mkFrame :: Set Ptr -> Maybe Ptr -> IO () -> IO () + mkFrame garbage focus msg = do putStrLn $ "** " ++ show n - pretty (heapToDoc garbage hp) ; putChar '\n' + pretty (heapToDoc garbage focus hp) ; putChar '\n' pretty e ; putChar '\n' putChar '\n' putStr "(" ; msg ; putStrLn ")\n" - goPtrs :: Set Ptr -> IO () - goPtrs ps = do - putStr "collecting " + ptrs :: String -> Set Ptr -> IO () + ptrs label ps = do + putStr (label ++ " ") sequence_ . intersperse (putStr ", ") . map pretty $ Set.toList ps pretty :: ToDoc a => a -> IO () - pretty = ANSI.write . Doc.render (\r -> Rendered.width r <= 80) . toDoc + pretty = + ( if disableAnsi + then putStr . String.toString + else ANSI.write + ) + . Doc.render (\r -> Rendered.width r <= 80) + . toDoc + + mkFocus :: DescriptionWithContext -> Maybe Ptr + mkFocus (DescriptionWithContext _ ctxt) = listToMaybe (reverse ctxt) diff --git a/src/CBN/Util/Doc/Rendered/ANSI.hs b/src/CBN/Util/Doc/Rendered/ANSI.hs index dbecb1a..b532816 100644 --- a/src/CBN/Util/Doc/Rendered/ANSI.hs +++ b/src/CBN/Util/Doc/Rendered/ANSI.hs @@ -50,5 +50,6 @@ write r = do ] toAnsiColor :: Color -> ANSI.Color - toAnsiColor Blue = ANSI.Blue - toAnsiColor Red = ANSI.Red + toAnsiColor Blue = ANSI.Blue + toAnsiColor Red = ANSI.Red + toAnsiColor Green = ANSI.Green diff --git a/src/CBN/Util/Doc/Rendered/HTML.hs b/src/CBN/Util/Doc/Rendered/HTML.hs index 55ece13..47fb485 100644 --- a/src/CBN/Util/Doc/Rendered/HTML.hs +++ b/src/CBN/Util/Doc/Rendered/HTML.hs @@ -6,9 +6,9 @@ import Data.Char (isSpace) import Data.Default import Data.Function (on) import Data.List (intersperse, groupBy) -import Data.Monoid import Text.Blaze.Html5 (Html, toHtml, (!)) import Text.Blaze (ToMarkup(..)) + import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A @@ -57,8 +57,9 @@ instance ToMarkup (Rendered Style) where ] toCssColor :: Color -> H.AttributeValue - toCssColor Blue = "darkblue" - toCssColor Red = "darkred" + toCssColor Blue = "darkblue" + toCssColor Red = "darkred" + toCssColor Green = "lightgreen" nbsp :: Html nbsp = preEscapedToMarkup (" " :: String) diff --git a/src/CBN/Util/Doc/Rendered/String.hs b/src/CBN/Util/Doc/Rendered/String.hs index 268a0d8..4c49c87 100644 --- a/src/CBN/Util/Doc/Rendered/String.hs +++ b/src/CBN/Util/Doc/Rendered/String.hs @@ -4,10 +4,5 @@ import Data.List (intercalate) import CBN.Util.Doc.Rendered -toString :: Rendered () -> String -toString = intercalate "\n" . map (ignoreStyle . rTrim) . rendered - where - ignoreStyle :: [Maybe ((), Char)] -> String - ignoreStyle = map $ \mc -> case mc of - Just ((), c) -> c - Nothing -> ' ' -- padding +toString :: Rendered style -> String +toString = intercalate "\n" . map (map (maybe ' ' snd)) . rendered diff --git a/src/CBN/Util/Doc/Style.hs b/src/CBN/Util/Doc/Style.hs index 5e73f05..4556d0f 100644 --- a/src/CBN/Util/Doc/Style.hs +++ b/src/CBN/Util/Doc/Style.hs @@ -18,6 +18,7 @@ data Style = Style { data Color = Blue | Red + | Green deriving (Eq) instance Default Style where diff --git a/src/Main.hs b/src/Main.hs index befa13e..fa2f64c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,9 +14,14 @@ main :: IO () main = do Options{..} <- getOptions input <- parseIO optionsInput parseModule =<< readFile optionsInput - let trace = summarize optionsSummarize $ traceTerm optionsGC input - when optionsShowTrace $ - Trace.Textual.renderIO trace + let trace = summarize optionsSummarize $ + traceTerm + optionsGC + optionsInlineHeap + optionsSelThunkOpt + input + when optionsShowTrace $ + Trace.Textual.renderIO optionsDisableAnsi trace forM_ optionsJsOutput $ \file -> writeFile file $ Trace.JavaScript.render optionsJsName optionsGraphOutput trace forM_ optionsGraphOutput $ \file -> diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 707dd0f..0000000 --- a/stack.yaml +++ /dev/null @@ -1,66 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-9.11 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: [] - -# Override default flag values for local packages and extra-deps -flags: {} - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.5" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file diff --git a/visualize-cbn.cabal b/visualize-cbn.cabal index 6b3cfd0..df64e5b 100644 --- a/visualize-cbn.cabal +++ b/visualize-cbn.cabal @@ -39,11 +39,13 @@ executable visualize-cbn CBN.Eval CBN.Free CBN.Heap + CBN.InlineHeap CBN.Language CBN.Options CBN.Parser CBN.Pretty CBN.Pretty.Precedence + CBN.SelThunkOpt CBN.Subst CBN.Trace CBN.Trace.HeapGraph @@ -79,6 +81,7 @@ executable visualize-cbn RecordWildCards ScopedTypeVariables StandaloneDeriving + TupleSections other-extensions: GeneralizedNewtypeDeriving OverloadedStrings TemplateHaskell From 966c0fbb0ca3e9e6d175e9fe805f90e0fb993df2 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Sun, 17 Dec 2023 10:58:09 +0100 Subject: [PATCH 2/5] Annotated execution --- .gitignore | 1 + examples/circular_hos.hs | 18 ++++++++++++++++++ examples/repmin.hs | 16 ++++++++++++++++ 3 files changed, 35 insertions(+) diff --git a/.gitignore b/.gitignore index ef7fc1c..24aec9b 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ dist-newstyle/ .stack-work .cabal.sandbox.config .envrc +foo.js diff --git a/examples/circular_hos.hs b/examples/circular_hos.hs index 8aefe32..e5895f8 100644 --- a/examples/circular_hos.hs +++ b/examples/circular_hos.hs @@ -17,6 +17,24 @@ -- > --hide-selector-thunk-opt \ -- > --javascript foo.js \ -- > -i examples/circular_hos.hs +-- +-- Annotated execution (as of dc51993): +-- +-- 2. As soon as we demand the value of @maxBV body_0@ to determine the +-- variable to be used for the outer-most lambda, this will force the +-- construction of the next term down. This happens recursively, so the +-- entire term is build in memory. +-- 10. This is an instructive subsequence: we will see the evaluation of +-- the simple term @lam (\y -> y)@. +-- 16. At this point this term is fully known: @Lam 1 (Var 1)@. +-- 17. The computation is driven by the computation of the variable to be used +-- for the outermost lambda; we can now continue this computation a little +-- bit, because we now know the @maxBV@ of the subterm @Lam 1 (Var 1)@. +-- 19. We repeat for the second simple term @lam (\z -> z)@. +-- 27. At this point we're almost done: we need to know the @max@BV@ of the +-- subterm @Var n_1@, but there aren't any, so that is just @0@. +-- 33. At this point all bound variables are known, and the new term has been +-- constructed. maxBV = (\exp -> case exp of { Var x -> 0 diff --git a/examples/repmin.hs b/examples/repmin.hs index ae28a32..6937d21 100644 --- a/examples/repmin.hs +++ b/examples/repmin.hs @@ -14,6 +14,22 @@ -- > --hide-selector-thunk-opt \ -- > --javascript foo.js \ -- > -i examples/repmin.hs +-- +-- Annotated execution (as of dc51993): +-- +-- 1. One way to think about this circular program is to consider that it +-- first creates a pointer to an int (the new value in the leaves), and +-- then starts building up a tree with all leaves pointing to this int; +-- as it builds the tree, it is also computing the value of this int. +-- 6. We're starting to see the tree take shape here; the top-level structure +-- of the tree is now known. +-- 10. Similarly, we now see the shape of the left subtree. +-- 13. Here we see the first @Leaf@, ponting to @m_1@; part of the computation +-- of @m_1@ is now also known (@mb_7@). +-- 16. The second @Leaf@ is known. +-- 18. The minimum value of the left subtree is known (@mb_4@). +-- 28. At this point the structure of the tree is mostly done. We can +-- finish the value computation. worker = (\m -> \t -> case t of { Leaf x -> Pair x (Leaf m) From 95b2fd6855834f000ae97ede8abb24ff7af68e67 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 20 Dec 2023 19:53:35 +0100 Subject: [PATCH 3/5] Add option to hide prelude from certain step --- examples/circular_hos.hs | 2 +- examples/repmin.hs | 2 +- src/CBN/Options.hs | 5 +++-- src/CBN/Trace.hs | 12 +++++++----- 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/examples/circular_hos.hs b/examples/circular_hos.hs index e5895f8..6305b43 100644 --- a/examples/circular_hos.hs +++ b/examples/circular_hos.hs @@ -8,7 +8,7 @@ -- -- > cabal run visualize-cbn -- \ -- > --show-trace \ --- > --hide-prelude \ +-- > --hide-prelude=1 \ -- > --gc \ -- > --selector-thunk-opt \ -- > --inline-heap \ diff --git a/examples/repmin.hs b/examples/repmin.hs index 6937d21..f832352 100644 --- a/examples/repmin.hs +++ b/examples/repmin.hs @@ -5,7 +5,7 @@ -- -- > cabal run visualize-cbn -- \ -- > --show-trace \ --- > --hide-prelude \ +-- > --hide-prelude=1 \ -- > --gc \ -- > --selector-thunk-opt \ -- > --inline-heap \ diff --git a/src/CBN/Options.hs b/src/CBN/Options.hs index bf8dbc9..e50e0bf 100644 --- a/src/CBN/Options.hs +++ b/src/CBN/Options.hs @@ -88,9 +88,10 @@ parseSummarizeOptions = SummarizeOptions , value 1000 , metavar "N" ]) - <*> (switch $ mconcat [ + <*> (optional $ option auto $ mconcat [ long "hide-prelude" - , help "Hide the prelude from the help" + , metavar "STEP" + , help "Hide the prelude from the help from the given step" ]) <*> (many $ option str $ mconcat [ long "hide-term" diff --git a/src/CBN/Trace.hs b/src/CBN/Trace.hs index 65c2dfd..cc97811 100644 --- a/src/CBN/Trace.hs +++ b/src/CBN/Trace.hs @@ -102,7 +102,7 @@ traceTerm shouldGC shouldInline enableSelThunkOpt = go data SummarizeOptions = SummarizeOptions { summarizeCollapseBeta :: Bool , summarizeMaxNumSteps :: Int - , summarizeHidePrelude :: Bool + , summarizeHidePrelude :: Maybe Int , summarizeHideTerms :: [String] , summarizeHideGC :: Bool , summarizeHideSelThunk :: Bool @@ -167,7 +167,7 @@ summarize SummarizeOptions{..} = go 0 where showSrc :: TraceCont -> Trace - showSrc = Trace (goHeap hp, e) + showSrc = Trace (goHeap n hp, e) -- | We already saw one beta reduction; skip any subsequent ones goBeta :: Int -> Trace -> TraceCont @@ -186,13 +186,15 @@ summarize SummarizeOptions{..} = go 0 _otherwise -> False -- | Cleanup the heap - goHeap :: Heap Term -> Heap Term - goHeap (Heap next heap) = + goHeap :: Int -> Heap Term -> Heap Term + goHeap n (Heap next heap) = Heap next $ Map.filterWithKey shouldShow heap where shouldShow :: Ptr -> Term -> Bool shouldShow (Ptr Nothing (Just name)) _ = and [ - not summarizeHidePrelude + case summarizeHidePrelude of + Nothing -> True + Just n' -> n < n' , not (name `elem` summarizeHideTerms) ] shouldShow (Ptr _ _) _ = True From 44381831c8db7a9e3a7f0cd04f285752267e030d Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 20 Dec 2023 20:00:34 +0100 Subject: [PATCH 4/5] Update CI --- .github/workflows/haskell-ci.yml | 111 +++++++------------------------ src/CBN/SelThunkOpt.hs | 1 + visualize-cbn.cabal | 10 +-- 3 files changed, 28 insertions(+), 94 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 2840b86..2e74101 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -6,11 +6,11 @@ # # haskell-ci regenerate # -# For more information, see https://github.com/andreasabel/haskell-ci +# For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.17.20230928 +# version: 0.17.20231219 # -# REGENDATA ("0.17.20230928",["github","visualize-cbn.cabal"]) +# REGENDATA ("0.17.20231219",["github","visualize-cbn.cabal"]) # name: Haskell-CI on: @@ -23,24 +23,24 @@ jobs: timeout-minutes: 60 container: - image: buildpack-deps:focal + image: buildpack-deps:bionic continue-on-error: ${{ matrix.allow-failure }} strategy: matrix: include: - - compiler: ghc-9.8.0.20230919 + - compiler: ghc-9.8.1 compilerKind: ghc - compilerVersion: 9.8.0.20230919 + compilerVersion: 9.8.1 setup-method: ghcup - allow-failure: true + allow-failure: false - compiler: ghc-9.6.3 compilerKind: ghc compilerVersion: 9.6.3 setup-method: ghcup allow-failure: false - - compiler: ghc-9.4.7 + - compiler: ghc-9.4.8 compilerKind: ghc - compilerVersion: 9.4.7 + compilerVersion: 9.4.8 setup-method: ghcup allow-failure: false - compiler: ghc-9.2.8 @@ -58,54 +58,17 @@ jobs: compilerVersion: 8.10.7 setup-method: ghcup allow-failure: false - - compiler: ghc-8.8.4 - compilerKind: ghc - compilerVersion: 8.8.4 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.6.5 - compilerKind: ghc - compilerVersion: 8.6.5 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.4.4 - compilerKind: ghc - compilerVersion: 8.4.4 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.2.2 - compilerKind: ghc - compilerVersion: 8.2.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.0.2 - compilerKind: ghc - compilerVersion: 8.0.2 - setup-method: hvr-ppa - allow-failure: false fail-fast: false steps: - name: apt run: | apt-get update apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 - if [ "${{ matrix.setup-method }}" = ghcup ]; then - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - else - apt-add-repository -y 'ppa:hvr/ghc' - apt-get update - apt-get install -y "$HCNAME" - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; - "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - fi + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) env: HCKIND: ${{ matrix.compilerKind }} HCNAME: ${{ matrix.compiler }} @@ -117,27 +80,18 @@ jobs: echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" HCDIR=/opt/$HCKIND/$HCVER - if [ "${{ matrix.setup-method }}" = ghcup ]; then - HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") - HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') - HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" - echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - else - HC=$HCDIR/bin/$HCKIND - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" - echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" - fi - + HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") + HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') + HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" + echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - if [ $((HCNUMVER >= 90800)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" echo "GHCJSARITH=0" >> "$GITHUB_ENV" env: @@ -166,18 +120,6 @@ jobs: repository hackage.haskell.org url: http://hackage.haskell.org/ EOF - if $HEADHACKAGE; then - cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> cabal.project - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package visualize-cbn" >> cabal.project ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + echo "package visualize-cbn" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project - fi $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(visualize-cbn)$/; }' >> cabal.project.local cat cabal.project cat cabal.project.local diff --git a/src/CBN/SelThunkOpt.hs b/src/CBN/SelThunkOpt.hs index 44a8aad..58a6e4b 100644 --- a/src/CBN/SelThunkOpt.hs +++ b/src/CBN/SelThunkOpt.hs @@ -20,6 +20,7 @@ module CBN.SelThunkOpt (selThunkOpt) where import Control.Applicative +import Control.Monad import Control.Monad.State import Data.Set (Set) diff --git a/visualize-cbn.cabal b/visualize-cbn.cabal index df64e5b..2efc9f3 100644 --- a/visualize-cbn.cabal +++ b/visualize-cbn.cabal @@ -16,18 +16,12 @@ build-type: Simple extra-source-files: ChangeLog.md README.md CONTRIBUTORS tested-with: - GHC == 9.8.0 + GHC == 9.8.1 GHC == 9.6.3 - GHC == 9.4.7 + GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 GHC == 8.10.7 - GHC == 8.8.4 - GHC == 8.6.5 - GHC == 8.4.4 - GHC == 8.2.2 - GHC == 8.0.2 - source-repository head type: git From 191fefcd16a04b0c88f494aad330ea2d8b794996 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Wed, 20 Dec 2023 20:04:56 +0100 Subject: [PATCH 5/5] Prepare for release 0.2.0 --- ChangeLog.md | 14 +++++++++++++- src/CBN/Parser.hs | 2 +- src/CBN/SelThunkOpt.hs | 2 +- visualize-cbn.cabal | 23 ++++++++++------------- 4 files changed, 25 insertions(+), 16 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 6733cb9..fae2f60 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Revision history for visualize-cbn +## 0.2.0 -- 2023-12-20 + +* Support multiple (mutually recursive) bindings in `let` +* Fix pattern matching on heap-allocated objects (we were losing sharing) +* Support heap inlining +* Support for selectors (`fst`, `snd`) +* Support the selector thunk optimization +* Add `--disable-ansi` command line +* Improve trace summarization +* Add some new primitive functions (`min`, `max`, `succ`) +* Add option to hide the prelude only after a specified step + ## 0.1.0.2 -- 2019-09-10 * Newer GHC compatibility @@ -18,4 +30,4 @@ this avoids moving `e1` to the heap (provided that there aren't multiple references to `x` from `e2`), clarifying the evaluation. * Added graph output (contributed by Yiğit Özkavcı). -* Improved heap descriptions (contributed by Tim Rakowski). +* Improved heap descriptions (contributed by Tim Rakowski). diff --git a/src/CBN/Parser.hs b/src/CBN/Parser.hs index a6f6dc5..f83bfec 100644 --- a/src/CBN/Parser.hs +++ b/src/CBN/Parser.hs @@ -6,10 +6,10 @@ module CBN.Parser ( , parseIO ) where -import Control.Applicative (asum) import Control.Exception import Control.Monad import Data.Bifunctor +import Data.Foldable (asum) import Language.Haskell.TH (Q) import Language.Haskell.TH.Quote import Text.Parsec diff --git a/src/CBN/SelThunkOpt.hs b/src/CBN/SelThunkOpt.hs index 58a6e4b..9038760 100644 --- a/src/CBN/SelThunkOpt.hs +++ b/src/CBN/SelThunkOpt.hs @@ -19,9 +19,9 @@ module CBN.SelThunkOpt (selThunkOpt) where -import Control.Applicative import Control.Monad import Control.Monad.State +import Data.Foldable (asum) import Data.Set (Set) import qualified Data.Map as Map diff --git a/visualize-cbn.cabal b/visualize-cbn.cabal index 2efc9f3..87340e9 100644 --- a/visualize-cbn.cabal +++ b/visualize-cbn.cabal @@ -1,8 +1,6 @@ cabal-version: >=1.10 name: visualize-cbn -version: 0.1.0.2 -x-revision: 3 - +version: 0.2.0 synopsis: Visualize CBN reduction description: CBN interpretation and visualization tool. Exports in text format, coloured text (ANSI) or HTML/JavaScript. @@ -54,18 +52,17 @@ executable visualize-cbn CBN.Util.Doc.Style CBN.Util.Map CBN.Util.Snoc - build-depends: base >= 4.9 && < 4.20 - , ansi-terminal >= 0.6 && < 1.1 - , blaze-html >= 0.8 && < 0.10 - , blaze-markup >= 0.7 && < 0.9 - , containers >= 0.5 && < 0.8 + build-depends: base >= 4.14 && < 4.20 + , ansi-terminal >= 1.0 && < 1.1 + , blaze-html >= 0.9 && < 0.10 + , blaze-markup >= 0.8 && < 0.9 + , containers >= 0.6 && < 0.8 , data-default >= 0.7 && < 0.8 - , optparse-applicative >= 0.12 && < 0.19 + , mtl >= 2.2 && < 2.4 + , optparse-applicative >= 0.18 && < 0.19 , parsec >= 3.1 && < 3.2 - -- version shipped with ghc - , template-haskell - , mtl - , text + , template-haskell >= 2.16 && < 2.22 + , text >= 1.2 && < 2.2 hs-source-dirs: src default-language: Haskell2010 default-extensions: DeriveDataTypeable