From 37292780418f7bd9d068954a509400b3e0a7528b Mon Sep 17 00:00:00 2001 From: Rakarake Date: Thu, 27 Apr 2023 16:44:30 +0200 Subject: [PATCH] =?UTF-8?q?Unreachable=20branhces=20are=20removed,=20fixed?= =?UTF-8?q?=20a=20nasty=20bug=20in=20monomorphizer=20=F0=9F=98=B8?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- sample-programs/bubble-sort.chrf | 11 +++++++ sample-programs/insertion-sort.chrf | 23 ++++++++++++++ sample-programs/mono-2.crf | 3 ++ src/Monomorphizer/Monomorphizer.hs | 47 +++++++++++++++++++---------- 4 files changed, 68 insertions(+), 16 deletions(-) create mode 100644 sample-programs/bubble-sort.chrf create mode 100644 sample-programs/insertion-sort.chrf diff --git a/sample-programs/bubble-sort.chrf b/sample-programs/bubble-sort.chrf new file mode 100644 index 0000000..59e6598 --- /dev/null +++ b/sample-programs/bubble-sort.chrf @@ -0,0 +1,11 @@ +data List (a) where + Cons : a -> List (a) -> List (a) + Nil : List (a) + +bubblesort : List (a) -> List (a) +bubblesort xs = case xs of + Nil => Nil + Cons x => case x of + Nil => Cons x Nil + Cons y => + diff --git a/sample-programs/insertion-sort.chrf b/sample-programs/insertion-sort.chrf new file mode 100644 index 0000000..573f2de --- /dev/null +++ b/sample-programs/insertion-sort.chrf @@ -0,0 +1,23 @@ +data List (a) where + Nil : List (a) + Cons : a -> List (a) -> List (a) + +insert : Int -> List (Int) -> List (Int) +insert x xs = case xs of + Cons z zs => case (lt x z) of + True => Cons x (Cons z zs) + False => Cons z (insert x zs) + Nil => Cons x Nil + +insertionSort : List (Int) -> List (Int) +insertionSort xs = case xs of + Cons y ys => case ys of + _ => insert y (insertionSort ys) + Nil => xs + Nil => Nil + +main = head (insertionSort (Cons 5 (Cons 4 (Cons 3 (Cons 2 (Cons 1 Nil)))))) + +head xs = case xs of + Cons x _ => x + diff --git a/sample-programs/mono-2.crf b/sample-programs/mono-2.crf index 9325b4a..97e8c1f 100644 --- a/sample-programs/mono-2.crf +++ b/sample-programs/mono-2.crf @@ -5,6 +5,9 @@ data Either(a b) where unwrapLeft x = case x of Left y => y +unwrapRight x = case x of + Right y => y + wow = Left 5 main = unwrapLeft wow diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 6bf767b..1d99731 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -46,7 +46,7 @@ import Control.Monad.State ( ) import Data.Coerce (coerce) import Data.Map qualified as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, catMaybes) import Data.Set qualified as Set import Debug.Trace import Grammar.Print (printTree) @@ -102,6 +102,10 @@ markBind ident = modify (Map.insert ident Marked) isBindMarked :: Ident -> EnvM Bool isBindMarked ident = gets (Map.member ident) +-- | Checks if constructor is outputted. +isConsMarked :: Ident -> EnvM Bool +isConsMarked ident = gets (Map.member ident) + -- | Finds main bind. getMain :: EnvM T.Bind getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of @@ -228,7 +232,7 @@ morphExp expectedType exp = case exp of t' <- getMonoFromPoly t bs' <- mapM morphBranch bs exp' <- morphExp t' exp - return $ M.ECase (exp', t') bs' + return $ M.ECase (exp', t') (catMaybes bs') T.EVar ident -> do isLocal <- localExists ident if isLocal @@ -248,28 +252,39 @@ morphExp expectedType exp = case exp of T.ELet (T.Bind{}) _ -> error "lets not possible yet" -- | Monomorphizes case-of branches. -morphBranch :: T.Branch -> EnvM M.Branch +morphBranch :: T.Branch -> EnvM (Maybe M.Branch) morphBranch (T.Branch (p, pt) (e, et)) = do pt' <- getMonoFromPoly pt et' <- getMonoFromPoly et env <- ask - (p', newLocals) <- morphPattern p pt' - local (const env { locals = Set.union (locals env) newLocals }) $ do - e' <- morphExp et' e - return $ M.Branch (p', pt') (e', et') + maybeMorphedPattern <- morphPattern p pt' + case maybeMorphedPattern of + Nothing -> return Nothing + Just (p', newLocals) -> + local (const env { locals = Set.union (locals env) newLocals }) $ do + e' <- morphExp et' e + return $ Just (M.Branch (p', pt') (e', et')) -morphPattern :: T.Pattern -> M.Type -> EnvM (M.Pattern, Set.Set Ident) +morphPattern :: T.Pattern -> M.Type -> EnvM (Maybe (M.Pattern, Set.Set Ident)) morphPattern p expectedType = case p of - T.PVar ident -> return (M.PVar (ident, expectedType), Set.singleton ident) - T.PLit lit -> return (M.PLit (convertLit lit, expectedType), Set.empty) - T.PCatch -> return (M.PCatch, Set.empty) + T.PVar ident -> return $ Just (M.PVar (ident, expectedType), Set.singleton ident) + T.PLit lit -> return $ Just (M.PLit (convertLit lit, expectedType), Set.empty) + T.PCatch -> return $ Just (M.PCatch, Set.empty) T.PEnum ident -> do --morphCons expectedType ident - return (M.PEnum ident, Set.empty) + return $ Just (M.PEnum ident, Set.empty) T.PInj ident pts -> do --morphCons expectedType ident - ts' <- mapM (getMonoFromPoly . snd) pts - let pts' = zip (map fst pts) ts' - psSets <- mapM (uncurry morphPattern) pts' - return (M.PInj ident (map fst psSets), Set.unions $ map snd psSets) + isMarked <- isConsMarked ident + if isMarked + then do + ts' <- mapM (getMonoFromPoly . snd) pts + let pts' = zip (map fst pts) ts' + psSets <- mapM (uncurry morphPattern) pts' + let maybePsSets = sequence psSets + case maybePsSets of + Nothing -> return Nothing + Just psSets' -> return $ Just + (M.PInj ident (map fst psSets'), Set.unions $ map snd psSets') + else return Nothing -- | Creates a new identifier for a function with an assigned type. newFuncName :: M.Type -> T.Bind -> Ident