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 $
|
||||
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
|
||||
|
@ -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) =
|
||||
|
@ -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")
|
||||
)
|
||||
|
Loading…
Reference in New Issue
Block a user