Skip to content
This repository has been archived by the owner on Feb 18, 2020. It is now read-only.

Commit

Permalink
Browse files Browse the repository at this point in the history
Merge branch 'feature/compile-pattern-matching' into develop
  • Loading branch information
Averethel committed Feb 10, 2013
2 parents a968e03 + dcc051d commit 05f0305
Show file tree
Hide file tree
Showing 15 changed files with 747 additions and 13 deletions.
26 changes: 26 additions & 0 deletions PatternMatching.hs
@@ -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
40 changes: 40 additions & 0 deletions PatternMatching/Counters.hs
@@ -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)
81 changes: 81 additions & 0 deletions PatternMatching/NameWildcards.hs
@@ -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
94 changes: 94 additions & 0 deletions PatternMatching/NumbersToIfs.hs
@@ -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
84 changes: 84 additions & 0 deletions PatternMatching/SimplifyHandles.hs
@@ -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)

0 comments on commit 05f0305

Please sign in to comment.