mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-17 16:38:14 +03:00
* 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
This commit is contained in:
parent
499a03e63e
commit
0682f1a61e
@ -445,9 +445,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
|||||||
when isNotVoid $
|
when isNotVoid $
|
||||||
appendToSrc (addIndent indent' ++ retVar ++ " = " ++ caseExprRetVal ++ ";\n")
|
appendToSrc (addIndent indent' ++ retVar ++ " = " ++ caseExprRetVal ++ ";\n")
|
||||||
let Just caseLhsInfo' = caseLhsInfo
|
let Just caseLhsInfo' = caseLhsInfo
|
||||||
when
|
delete indent' caseLhsInfo'
|
||||||
(matchMode == MatchValue)
|
|
||||||
(delete indent' caseLhsInfo')
|
|
||||||
appendToSrc (addIndent indent ++ "}\n")
|
appendToSrc (addIndent indent ++ "}\n")
|
||||||
in do
|
in do
|
||||||
exprVar <- visit indent expr
|
exprVar <- visit indent expr
|
||||||
|
@ -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
|
-- 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'
|
-- 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
|
-- 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
|
do
|
||||||
visitedExpr <- visit expr
|
visitedExpr <- visit expr
|
||||||
case visitedExpr of
|
case visitedExpr of
|
||||||
@ -346,7 +346,7 @@ manageMemory typeEnv globalEnv root =
|
|||||||
do
|
do
|
||||||
_ <- unmanage typeEnv globalEnv okVisitedExpr
|
_ <- unmanage typeEnv globalEnv okVisitedExpr
|
||||||
MemState preDeleters deps lifetimes <- get
|
MemState preDeleters deps lifetimes <- get
|
||||||
vistedCasesAndDeps <- mapM visitMatchCase (pairwise cases)
|
vistedCasesAndDeps <- mapM (visitMatchCase matchMode) (pairwise cases)
|
||||||
case sequence vistedCasesAndDeps of
|
case sequence vistedCasesAndDeps of
|
||||||
Left e -> pure (Left e)
|
Left e -> pure (Left e)
|
||||||
Right okCasesAndDeps ->
|
Right okCasesAndDeps ->
|
||||||
@ -415,11 +415,11 @@ manageMemory typeEnv globalEnv root =
|
|||||||
Right (XObj (Lst (okF : okArgs)) i t)
|
Right (XObj (Lst (okF : okArgs)) i t)
|
||||||
[] -> pure (Right xobj)
|
[] -> pure (Right xobj)
|
||||||
visitList _ = error "Must visit list."
|
visitList _ = error "Must visit list."
|
||||||
visitMatchCase :: (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty))
|
visitMatchCase :: MatchMode -> (XObj, XObj) -> State MemState (Either TypeError ((Set.Set Deleter, (XObj, XObj)), Set.Set Ty))
|
||||||
visitMatchCase (lhs@XObj {}, rhs@XObj {}) =
|
visitMatchCase matchMode (lhs@XObj {}, rhs@XObj {}) =
|
||||||
do
|
do
|
||||||
MemState preDeleters _ _ <- get
|
MemState preDeleters _ _ <- get
|
||||||
_ <- visitCaseLhs lhs
|
_ <- visitCaseLhs matchMode lhs
|
||||||
visitedRhs <- visit rhs
|
visitedRhs <- visit rhs
|
||||||
_ <- unmanage typeEnv globalEnv rhs
|
_ <- unmanage typeEnv globalEnv rhs
|
||||||
MemState postDeleters postDeps postLifetimes <- get
|
MemState postDeleters postDeps postLifetimes <- get
|
||||||
@ -427,20 +427,20 @@ manageMemory typeEnv globalEnv root =
|
|||||||
pure $ do
|
pure $ do
|
||||||
okVisitedRhs <- visitedRhs
|
okVisitedRhs <- visitedRhs
|
||||||
pure ((postDeleters, (lhs, okVisitedRhs)), postDeps)
|
pure ((postDeleters, (lhs, okVisitedRhs)), postDeps)
|
||||||
visitCaseLhs :: XObj -> State MemState (Either TypeError [()])
|
visitCaseLhs :: MatchMode -> XObj -> State MemState (Either TypeError [()])
|
||||||
visitCaseLhs (XObj (Lst vars) _ _) =
|
visitCaseLhs matchMode (XObj (Lst vars) _ _) =
|
||||||
do
|
do
|
||||||
result <- mapM visitCaseLhs vars
|
result <- mapM (visitCaseLhs matchMode) vars
|
||||||
let result' = sequence result
|
let result' = sequence result
|
||||||
pure (fmap concat result')
|
pure (fmap concat result')
|
||||||
visitCaseLhs xobj@(XObj (Sym (SymPath _ name) _) _ _)
|
visitCaseLhs matchMode xobj@(XObj (Sym (SymPath _ name) _) _ _)
|
||||||
| isVarName name = do
|
| (matchMode == MatchValue) && isVarName name = do
|
||||||
manage typeEnv globalEnv xobj
|
manage typeEnv globalEnv xobj
|
||||||
pure (Right [])
|
pure (Right [])
|
||||||
| otherwise = pure (Right [])
|
| otherwise = pure (Right [])
|
||||||
visitCaseLhs (XObj Ref _ _) =
|
visitCaseLhs _ (XObj Ref _ _) =
|
||||||
pure (Right [])
|
pure (Right [])
|
||||||
visitCaseLhs x =
|
visitCaseLhs _ x =
|
||||||
error ("Unhandled: " ++ show x)
|
error ("Unhandled: " ++ show x)
|
||||||
visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj))
|
visitLetBinding :: (XObj, XObj) -> State MemState (Either TypeError (XObj, XObj))
|
||||||
visitLetBinding (name, expr) =
|
visitLetBinding (name, expr) =
|
||||||
|
@ -444,6 +444,46 @@
|
|||||||
(match m
|
(match m
|
||||||
_ 1)))))
|
_ 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
|
(deftest test
|
||||||
(assert-no-leak test scope-1 "scope-1 does not leak")
|
(assert-no-leak test scope-1 "scope-1 does not leak")
|
||||||
(assert-no-leak test scope-2 "scope-2 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-5 "sumtype-5 does not leak")
|
||||||
(assert-no-leak test sumtype-6 "sumtype-6 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-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")
|
||||||
)
|
)
|
||||||
|
Loading…
Reference in New Issue
Block a user