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

Author: leblowl

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

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,32 +415,32 @@ 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
         put (MemState preDeleters postDeps postLifetimes) -- Restore managed variables, TODO: Use a "local" state monad instead?
         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) =

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")
   )