Permalink
Browse files

Merge branch 'feature/compile-pattern-matching' into develop

  • Loading branch information...
2 parents a968e03 + dcc051d commit 05f0305aa1efd0158f5afcf1f34b49d0634f3a31 @Averethel committed Feb 10, 2013
View
@@ -0,0 +1,26 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module PatternMatching (compilePatternMatching) where
+ import PatternMatching.Counters
+ import PatternMatching.NameWildcards
+ import PatternMatching.NumbersToIfs
+ import PatternMatching.ToCases
+ import PatternMatching.ToHandles
+ import PatternMatching.SimplifyHandles
+
+ import Control.Monad.State
+
+ import Syntax
+
+ matcherCompiler :: MonadState Counter m => Expr -> m Expr
+ matcherCompiler e = do
+ e1 <- nameWildcards e
+ e2 <- numbersToIfs e1
+ e3 <- functionsToHandles e2
+ e4 <- handlesToCases e3
+ return $ simplifyHandles e4
+
+ compilePatternMatching :: Expr -> Expr
+ compilePatternMatching e = fst $ runState (matcherCompiler e) emptyState
@@ -0,0 +1,40 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module PatternMatching.Counters where
+ import Control.Monad.State
+
+ data Counter = C {
+ args :: Integer,
+ vars :: Integer,
+ wild :: Integer
+ }
+
+ emptyState :: Counter
+ emptyState = C 0 0 0
+
+ freshArg :: MonadState Counter m => m String
+ freshArg = do
+ s <- get
+ put s { args = args s + 1 }
+ return $ '_' : 'a' : show (args s)
+
+ genNames :: MonadState Counter m => Int -> m [String]
+ genNames n = genNames' n [] where
+ genNames' 0 acc = return $ reverse acc
+ genNames' x acc = do
+ a <- freshArg
+ genNames' (x-1) $ a:acc
+
+ freshVar :: MonadState Counter m => m String
+ freshVar = do
+ s <- get
+ put s { vars = vars s + 1 }
+ return $ '_' : 'u' : show (vars s)
+
+ freshWildcard :: MonadState Counter m => m String
+ freshWildcard = do
+ s <- get
+ put s { wild = wild s + 1 }
+ return $ '_' : 'w' : show (wild s)
@@ -0,0 +1,81 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module PatternMatching.NameWildcards (nameWildcards) where
+ import Syntax
+
+ import PatternMatching.Counters
+
+ import Control.Monad.State
+
+ nameWildcardsPattern :: MonadState Counter m => Pattern -> m Pattern
+ nameWildcardsPattern Pwildcard = do
+ v <- freshWildcard
+ return $ Pvar v
+ nameWildcardsPattern (Ppair p1 p2) = do
+ p1' <- nameWildcardsPattern p1
+ p2' <- nameWildcardsPattern p2
+ return $ Ppair p1' p2'
+ nameWildcardsPattern (Pcons p1 p2) = do
+ p1' <- nameWildcardsPattern p1
+ p2' <- nameWildcardsPattern p2
+ return $ Pcons p1' p2'
+ nameWildcardsPattern p =
+ return p
+
+ nameWildcardsFunClause :: MonadState Counter m => FunClause -> m FunClause
+ nameWildcardsFunClause fc = do
+ p' <- mapM nameWildcardsPattern $ arguments fc
+ b' <- nameWildcards $ fbody fc
+ return FC{ arguments = p', fbody = b' }
+
+ nameWildcardsCaseClause :: MonadState Counter m => CaseClause -> m CaseClause
+ nameWildcardsCaseClause cc = do
+ b' <- nameWildcards $ cbody cc
+ return cc{ cbody = b' }
+
+ nameWildcards :: MonadState Counter m => Expr -> m Expr
+ nameWildcards (Efun fcs) = do
+ fcs' <- mapM nameWildcardsFunClause fcs
+ return $ Efun fcs'
+ nameWildcards (Elet p e1 e2) = do
+ p' <- nameWildcardsPattern p
+ e1' <- nameWildcards e1
+ e2' <- nameWildcards e2
+ return $ Elet p' e1' e2'
+ nameWildcards (Eletrec n fcs e) = do
+ fcs' <- mapM nameWildcardsFunClause fcs
+ e' <- nameWildcards e
+ return $ Eletrec n fcs' e'
+ nameWildcards (Eapply e1 as) = do
+ e1' <- nameWildcards e1
+ as' <- mapM nameWildcards as
+ return $ Eapply e1' as'
+ nameWildcards (Epair e1 e2) = do
+ e1' <- nameWildcards e1
+ e2' <- nameWildcards e2
+ return $ Epair e1' e2'
+ nameWildcards (Econs e1 e2) = do
+ e1' <- nameWildcards e1
+ e2' <- nameWildcards e2
+ return $ Econs e1' e2'
+ nameWildcards (Eif e1 e2 e3) = do
+ e1' <- nameWildcards e1
+ e2' <- nameWildcards e2
+ e3' <- nameWildcards e3
+ return $ Eif e1' e2' e3'
+ nameWildcards (Eseq e1 e2) = do
+ e1' <- nameWildcards e1
+ e2' <- nameWildcards e2
+ return $ Eseq e1' e2'
+ nameWildcards (Ecase e1 ccs) = do
+ e1' <- nameWildcards e1
+ ccs' <- mapM nameWildcardsCaseClause ccs
+ return $ Ecase e1' ccs'
+ nameWildcards (Ehandle e1 e2) = do
+ e1' <- nameWildcards e1
+ e2' <- nameWildcards e2
+ return $ Ehandle e1' e2'
+ nameWildcards e =
+ return e
@@ -0,0 +1,94 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module PatternMatching.NumbersToIfs (numbersToIfs) where
+ import Syntax
+
+ import PatternMatching.Counters
+
+ import Control.Monad.State
+
+ mkAnd :: Expr -> Expr -> Expr
+ mkAnd (Econst (Cbool True)) e = e
+ mkAnd e (Econst (Cbool True)) = e
+ mkAnd e1 e2 = Eapply (Ebprim BPand) [e1, e2]
+
+ numbersToIfsPattern :: MonadState Counter m => Pattern -> m (Pattern, Expr)
+ numbersToIfsPattern (Pconst n@(Cint _)) = do
+ a <- freshArg
+ return (Pvar a, Eapply (Ebprim BPeq) [Evar a, Econst n])
+ numbersToIfsPattern (Ppair p1 p2) = do
+ (p1', a1') <- numbersToIfsPattern p1
+ (p2', a2') <- numbersToIfsPattern p2
+ return (Ppair p1' p2', mkAnd a1' a2')
+ numbersToIfsPattern (Pcons p1 p2) = do
+ (p1', a1') <- numbersToIfsPattern p1
+ (p2', a2') <- numbersToIfsPattern p2
+ return (Pcons p1' p2', mkAnd a1' a2')
+ numbersToIfsPattern p =
+ return (p, Econst $ Cbool True)
+
+ numbersToIfsPatterns :: MonadState Counter m => [Pattern] -> m ([Pattern], Expr)
+ numbersToIfsPatterns ps = do
+ pscs <- mapM numbersToIfsPattern ps
+ let (ps', cs) = unzip pscs
+ return (ps', foldl mkAnd (Econst $ Cbool True) cs)
+
+ numbersToIfsCaseClause :: MonadState Counter m => CaseClause -> m CaseClause
+ numbersToIfsCaseClause cc = do
+ b' <- numbersToIfs $ cbody cc
+ return cc{ cbody = b' }
+
+ numbersToIfsFunClause :: MonadState Counter m => FunClause -> m FunClause
+ numbersToIfsFunClause fc = do
+ (ps, c) <- numbersToIfsPatterns $ arguments fc
+ b' <- numbersToIfs $ fbody fc
+ case c of
+ Econst (Cbool True) -> return fc { fbody = b' }
+ _ -> return fc { arguments = ps,
+ fbody = Eif c b' EmatchFailure }
+
+ numbersToIfs :: MonadState Counter m => Expr -> m Expr
+ numbersToIfs (Efun fcs) = do
+ fcs' <- mapM numbersToIfsFunClause fcs
+ return $ Efun fcs'
+ numbersToIfs (Elet p e1 e2) = do
+ e1' <- numbersToIfs e1
+ e2' <- numbersToIfs e2
+ return $ Elet p e1' e2'
+ numbersToIfs (Eletrec n fcs e1) = do
+ fcs' <- mapM numbersToIfsFunClause fcs
+ e1' <- numbersToIfs e1
+ return $ Eletrec n fcs' e1'
+ numbersToIfs (Eapply e1 as) = do
+ e1' <- numbersToIfs e1
+ as' <- mapM numbersToIfs as
+ return $ Eapply e1' as'
+ numbersToIfs (Epair e1 e2) = do
+ e1' <- numbersToIfs e1
+ e2' <- numbersToIfs e2
+ return $ Epair e1' e2'
+ numbersToIfs (Econs e1 e2) = do
+ e1' <- numbersToIfs e1
+ e2' <- numbersToIfs e2
+ return $ Econs e1' e2'
+ numbersToIfs (Eif e1 e2 e3) = do
+ e1' <- numbersToIfs e1
+ e2' <- numbersToIfs e2
+ e3' <- numbersToIfs e3
+ return $ Eif e1' e2' e3'
+ numbersToIfs (Eseq e1 e2) = do
+ e1' <- numbersToIfs e1
+ e2' <- numbersToIfs e2
+ return $ Eseq e1' e2'
+ numbersToIfs (Ecase e ccs) = do
+ e' <- numbersToIfs e
+ ccs' <- mapM numbersToIfsCaseClause ccs
+ return $ Ecase e' ccs'
+ numbersToIfs (Ehandle e1 e2) = do
+ e1' <- numbersToIfs e1
+ e2' <- numbersToIfs e2
+ return $ Ehandle e1' e2'
+ numbersToIfs e =
+ return e
@@ -0,0 +1,84 @@
+module PatternMatching.SimplifyHandles (simplifyHandles) where
+ import Syntax.Expr
+
+ cannotFailMatchingFunClause :: FunClause -> Bool
+ cannotFailMatchingFunClause = cannotFailMatching . fbody
+
+ cannotFailMatchingCaseClause :: CaseClause -> Bool
+ cannotFailMatchingCaseClause = cannotFailMatching . cbody
+
+ cannotFailMatching :: Expr -> Bool
+ cannotFailMatching (Efun fcs) =
+ -- at this point we don't have to worry about incomlete matchings
+ -- thosa have been taken care of in previos passes
+ all cannotFailMatchingFunClause fcs
+ cannotFailMatching (Elet _ e1 e2) =
+ cannotFailMatching e1 && cannotFailMatching e2
+ cannotFailMatching (Eletrec _ fcs e) =
+ all cannotFailMatchingFunClause fcs && cannotFailMatching e
+ cannotFailMatching (Eapply e1 as) =
+ cannotFailMatching e1 && all cannotFailMatching as
+ cannotFailMatching (Epair e1 e2) =
+ cannotFailMatching e1 && cannotFailMatching e2
+ cannotFailMatching (Econs e1 e2) =
+ cannotFailMatching e1 && cannotFailMatching e2
+ cannotFailMatching (Eif e1 e2 e3) =
+ cannotFailMatching e1 && cannotFailMatching e2 && cannotFailMatching e3
+ cannotFailMatching (Eseq e1 e2) =
+ cannotFailMatching e1 && cannotFailMatching e2
+ cannotFailMatching (Ecase e ccs) =
+ cannotFailMatching e && all cannotFailMatchingCaseClause ccs
+ cannotFailMatching (Ehandle e1 e2) =
+ cannotFailMatching e1 && cannotFailMatching e2
+ cannotFailMatching EmatchFailure = False
+ cannotFailMatching _ = True
+
+ simplifyHandles1FunClause :: FunClause -> FunClause
+ simplifyHandles1FunClause fc =
+ fc{ fbody = simplifyHandles1 $ fbody fc }
+
+ simplifyHandles1CaseClause :: CaseClause -> CaseClause
+ simplifyHandles1CaseClause cc =
+ cc{ cbody = simplifyHandles1 $ cbody cc }
+
+ simplifyHandles1 :: Expr -> Expr
+ simplifyHandles1 (Efun fcs) =
+ Efun $ map simplifyHandles1FunClause fcs
+ simplifyHandles1 (Elet p e1 e2) =
+ Elet p (simplifyHandles1 e1) $ simplifyHandles1 e2
+ simplifyHandles1 (Eletrec n fcs e) =
+ Eletrec n (map simplifyHandles1FunClause fcs) $ simplifyHandles1 e
+ simplifyHandles1 (Eapply e1 as) =
+ Eapply (simplifyHandles1 e1) $ map simplifyHandles1 as
+ simplifyHandles1 (Epair e1 e2) =
+ Epair (simplifyHandles1 e1) $ simplifyHandles1 e2
+ simplifyHandles1 (Econs e1 e2) =
+ Econs (simplifyHandles1 e1) $ simplifyHandles1 e2
+ simplifyHandles1 (Eif e1 e2 e3) =
+ Eif (simplifyHandles1 e1) (simplifyHandles1 e2) $
+ simplifyHandles1 e3
+ simplifyHandles1 (Eseq e1 e2) =
+ Eseq (simplifyHandles1 e1) $ simplifyHandles1 e2
+ simplifyHandles1 (Ecase e1 ccs) =
+ Ecase (simplifyHandles1 e1) $ map simplifyHandles1CaseClause ccs
+ simplifyHandles1 (Ehandle EmatchFailure e1) =
+ simplifyHandles1 e1
+ simplifyHandles1 (Ehandle (Eif e1 e2 e3) e4)
+ | cannotFailMatching (simplifyHandles1 e1) &&
+ cannotFailMatching (simplifyHandles1 e2) =
+ Eif (simplifyHandles1 e1) (simplifyHandles1 e2) $
+ Ehandle (simplifyHandles1 e3) $ simplifyHandles1 e4
+ simplifyHandles1 (Ehandle e1 EmatchFailure) =
+ simplifyHandles1 e1
+ simplifyHandles1 (Ehandle e1 e2)
+ | cannotFailMatching (simplifyHandles1 e1) =
+ simplifyHandles1 e1
+ | otherwise =
+ Ehandle (simplifyHandles1 e1) $ simplifyHandles1 e2
+ simplifyHandles1 e =
+ e
+
+ simplifyHandles :: Expr -> Expr
+ simplifyHandles e
+ | simplifyHandles1 e == e = e
+ | otherwise = simplifyHandles (simplifyHandles1 e)
Oops, something went wrong.

0 comments on commit 05f0305

Please sign in to comment.