From 0682f1a61e3ef02f460425cf02e47f2cc45adcb6 Mon Sep 17 00:00:00 2001 From: Lucas Leblow Date: Mon, 25 Oct 2021 01:50:10 -0600 Subject: [PATCH] Bug fix for #1064 and #843 (#1321) * Bug fix for #1064 and #843 Removes broken fix for #843 in Emit.hs, thus fixing #1064. And then this commit focuses on fixing the memory management side of things, so that we don't add deleters for symbols in the left-hand-side of match case expressions if we are matching on a ref (e.g. using match-ref). * Add sumtype memory tests --- src/Emit.hs | 4 +--- src/Memory.hs | 24 ++++++++++++------------ test/memory.carp | 45 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 15 deletions(-) diff --git a/src/Emit.hs b/src/Emit.hs index e003e15a..3372a22b 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -445,9 +445,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo when isNotVoid $ appendToSrc (addIndent indent' ++ retVar ++ " = " ++ caseExprRetVal ++ ";\n") let Just caseLhsInfo' = caseLhsInfo - when - (matchMode == MatchValue) - (delete indent' caseLhsInfo') + delete indent' caseLhsInfo' appendToSrc (addIndent indent ++ "}\n") in do exprVar <- visit indent expr diff --git a/src/Memory.hs b/src/Memory.hs index fee3e307..2a20fce2 100644 --- a/src/Memory.hs +++ b/src/Memory.hs @@ -337,7 +337,7 @@ manageMemory typeEnv globalEnv root = -- 2. Variables deleted in at least one case has to be deleted in all, so make a union U of all such vars -- but remove the ones that were not present before the 'match' -- 3. In each case - take the intersection of U and the vars deleted in that case and add this result to its deleters - matchExpr@(XObj (Match _) _ _) : expr : cases -> + matchExpr@(XObj (Match matchMode) _ _) : expr : cases -> do visitedExpr <- visit expr case visitedExpr of @@ -346,7 +346,7 @@ manageMemory typeEnv globalEnv root = do _ <- unmanage typeEnv globalEnv okVisitedExpr MemState preDeleters deps lifetimes <- get - vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases) + vistedCasesAndDeps <- mapM (visitMatchCase matchMode) (pairwise cases) case sequence vistedCasesAndDeps of Left e -> pure (Left e) Right okCasesAndDeps -> @@ -415,11 +415,11 @@ manageMemory typeEnv globalEnv root = Right (XObj (Lst (okF : okArgs)) i t) [] -> pure (Right xobj) visitList _ = error "Must visit list." - visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty)) - visitMatchCase (lhs@XObj {}, rhs@XObj {}) = + visitMatchCase :: MatchMode -> (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty)) + visitMatchCase matchMode (lhs@XObj {}, rhs@XObj {}) = do MemState preDeleters _ _ <- get - _ <- visitCaseLhs lhs + _ <- visitCaseLhs matchMode lhs visitedRhs <- visit rhs _ <- unmanage typeEnv globalEnv rhs MemState postDeleters postDeps postLifetimes <- get @@ -427,20 +427,20 @@ manageMemory typeEnv globalEnv root = pure $ do okVisitedRhs <- visitedRhs pure ((postDeleters, (lhs, okVisitedRhs)), postDeps) - visitCaseLhs :: XObj -> State MemState (Either TypeError [()]) - visitCaseLhs (XObj (Lst vars) _ _) = + visitCaseLhs :: MatchMode -> XObj -> State MemState (Either TypeError [()]) + visitCaseLhs matchMode (XObj (Lst vars) _ _) = do - result <- mapM visitCaseLhs vars + result <- mapM (visitCaseLhs matchMode) vars let result' = sequence result pure (fmap concat result') - visitCaseLhs xobj@(XObj (Sym (SymPath _ name) _) _ _) - | isVarName name = do + visitCaseLhs matchMode xobj@(XObj (Sym (SymPath _ name) _) _ _) + | (matchMode == MatchValue) && isVarName name = do manage typeEnv globalEnv xobj pure (Right []) | otherwise = pure (Right []) - visitCaseLhs (XObj Ref _ _) = + visitCaseLhs _ (XObj Ref _ _) = pure (Right []) - visitCaseLhs x = + visitCaseLhs _ x = error ("Unhandled: " ++ show x) visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj)) visitLetBinding (name, expr) = diff --git a/test/memory.carp b/test/memory.carp index 9d42c009..5353ecc4 100644 --- a/test/memory.carp +++ b/test/memory.carp @@ -444,6 +444,46 @@ (match m _ 1))))) +(deftype Example + One + (Two [String])) + +(defn sumtype-8 [] + (let-do [ex [(Example.Two @"OKOK")]] + (match-ref (Array.unsafe-nth &ex 0) + (Example.Two s) (println* s) + _ ()))) + +(deftype Sum One Two) + +(defn sumtype-9 [] + (let [state @"Ok" sumt &(Sum.One)] + (match-ref sumt + Sum.One (println* &@&state) + Sum.Two ()))) + +(defn sumtype-10 [] + (let [state 0] + (match-ref &(Sum.One) + Sum.One (println* ((fn [] @&state))) + Sum.Two ()))) + +(deftype ExampleA + One + (Two [(Array String)])) + +(defn sumtype-11 [] + (match-ref &(Just (ExampleA.Two [@"OKOK"])) + (Just s) () + _ ()) + ) + +(defn sumtype-12 [] + (match (Just (ExampleA.Two [@"OKOK"])) + (Just s) () + _ ()) + ) + (deftest test (assert-no-leak test scope-1 "scope-1 does not leak") (assert-no-leak test scope-2 "scope-2 does not leak") @@ -513,4 +553,9 @@ (assert-no-leak test sumtype-5 "sumtype-5 does not leak") (assert-no-leak test sumtype-6 "sumtype-6 does not leak") (assert-no-leak test sumtype-7 "sumtype-7 does not leak") + (assert-no-leak test sumtype-8 "sumtype-8 does not leak") + (assert-no-leak test sumtype-9 "sumtype-9 does not leak") + (assert-no-leak test sumtype-10 "sumtype-10 does not leak") + (assert-no-leak test sumtype-11 "sumtype-11 does not leak") + (assert-no-leak test sumtype-12 "sumtype-12 does not leak") )