Permalink
Browse files

Merge branch 'feature/definitions-elim' into develop

  • Loading branch information...
2 parents 233b769 + be1abcd commit e86113c7b5752bbee5bc49f5e2e44c0c88cb7c50 @Averethel committed Feb 23, 2013
Showing with 123 additions and 1 deletion.
  1. +2 −1 Compiler.hs
  2. +72 −0 EliminateDefinitions.hs
  3. +49 −0 KNormal/KSyntax.hs
View
@@ -2,6 +2,7 @@ module Compiler (compile) where
import AlphaConvert
import BetaReduce
import ConstantsFold
+ import EliminateDefinitions
import Inline
import KNormal
import LetFlatten
@@ -18,7 +19,7 @@ module Compiler (compile) where
let e5 = letFlatten e4
e6 <- inline t e5
let e7 = constantsFold e6
- return e7
+ eliminateDefinitions e7
compile :: Integer -> Expr -> IO (Either String KExpr)
compile inlineTreshold expr = case typeOfExpression emptyEnv expr of
View
@@ -0,0 +1,72 @@
+module EliminateDefinitions (eliminateDefinitions) where
+ import KNormal.KSyntax
+
+ import Data.Set
+
+ hasSideEffect :: KExpr -> Bool
+ hasSideEffect (KEstore _ _) = True
+ hasSideEffect (KEerror _) = True
+ hasSideEffect (KEifEq _ _ e1 e2) = hasSideEffect e1 || hasSideEffect e2
+ hasSideEffect (KEifLE _ _ e1 e2) = hasSideEffect e1 || hasSideEffect e2
+ hasSideEffect (KElet _ e1 e2) = hasSideEffect e1 || hasSideEffect e2
+ hasSideEffect (KEletRec _ e) = hasSideEffect e
+ hasSideEffect (KEapply _ _) = True
+ hasSideEffect (KEletPair _ _ _ e) = hasSideEffect e
+ hasSideEffect (KEletList _ _ _ e) = hasSideEffect e
+ hasSideEffect (KEhandle e1 e2) = hasSideEffect e1 || hasSideEffect e2
+ hasSideEffect (KEseq e1 e2) = hasSideEffect e1 || hasSideEffect e2
+ hasSideEffect (KEextFunApp _ _) = True
+ hasSideEffect _ = False
+
+ eliminateDefinitions :: KExpr -> IO KExpr
+ eliminateDefinitions (KEifEq s1 s2 e1 e2) = do
+ e1' <- eliminateDefinitions e1
+ e2' <- eliminateDefinitions e2
+ return $ KEifEq s1 s2 e1' e2'
+ eliminateDefinitions (KEifLE s1 s2 e1 e2) = do
+ e1' <- eliminateDefinitions e1
+ e2' <- eliminateDefinitions e2
+ return $ KEifLE s1 s2 e1' e2'
+ eliminateDefinitions (KElet s e1 e2)
+ | not (hasSideEffect e1) &&
+ not (s `member` freeVars e2) = do
+ putStrLn $ "Eliminating variable: " ++ show s
+ eliminateDefinitions e2
+ | otherwise = do
+ e1' <- eliminateDefinitions e1
+ e2' <- eliminateDefinitions e2
+ return $ KElet s e1' e2'
+ eliminateDefinitions (KEletRec fd e)
+ | not (name fd `member` freeVars e) = do
+ putStrLn $ "Eliminating function: " ++ show (name fd)
+ eliminateDefinitions e
+ | otherwise = do
+ b' <- eliminateDefinitions $ body fd
+ e' <- eliminateDefinitions e
+ return $ KEletRec fd { body = b' } e'
+ eliminateDefinitions (KEletPair s1 s2 s3 e)
+ | not (s1 `member` freeVars e) &&
+ not (s2 `member` freeVars e) = do
+ putStrLn $ "Eliminating variables: " ++ show s1 ++ ", " ++ show s2
+ eliminateDefinitions e
+ | otherwise = do
+ e' <- eliminateDefinitions e
+ return $ KEletPair s1 s2 s3 e'
+ eliminateDefinitions (KEletList s1 s2 s3 e)
+ | not (s1 `member` freeVars e) &&
+ not (s2 `member` freeVars e) = do
+ putStrLn $ "Eliminating variables: " ++ show s1 ++ ", " ++ show s2
+ eliminateDefinitions e
+ | otherwise = do
+ e' <- eliminateDefinitions e
+ return $ KEletList s1 s2 s3 e'
+ eliminateDefinitions (KEhandle e1 e2) = do
+ e1' <- eliminateDefinitions e1
+ e2' <- eliminateDefinitions e2
+ return $ KEhandle e1' e2'
+ eliminateDefinitions (KEseq e1 e2) = do
+ e1' <- eliminateDefinitions e1
+ e2' <- eliminateDefinitions e2
+ return $ KEseq e1' e2'
+ eliminateDefinitions e =
+ return e
View
@@ -1,6 +1,8 @@
module KNormal.KSyntax where
import Utils.Iseq
+ import Data.Set hiding (map)
+
data FunDef = FD {
name :: String,
args :: [String],
@@ -49,6 +51,53 @@ module KNormal.KSyntax where
-- - reference maker
-- - tag getter
+ freeVars :: KExpr -> Set String
+ freeVars (KEneg s) =
+ singleton s
+ freeVars (KEload s) =
+ singleton s
+ freeVars (KEadd s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEsub s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEmult s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEdiv s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEmod s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEstore s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEvar s) =
+ singleton s
+ freeVars (KEifEq s1 s2 e1 e2) =
+ s1 `insert` (s2 `insert` freeVars e1 `union` freeVars e2)
+ freeVars (KEifLE s1 s2 e1 e2) =
+ s1 `insert` (s2 `insert` freeVars e1 `union` freeVars e2)
+ freeVars (KElet s e1 e2) =
+ freeVars e1 `union` (s `delete` freeVars e2)
+ freeVars (KEletRec fd e) =
+ freeVars (body fd) \\ fromList (args fd) `union`
+ (name fd `delete` freeVars e)
+ freeVars (KEapply s ss) =
+ fromList $ s:ss
+ freeVars (KEpair s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEcons s1 s2) =
+ fromList [s1, s2]
+ freeVars (KEletPair s1 s2 s3 e) =
+ s3 `insert` freeVars e \\ fromList [s1, s2]
+ freeVars (KEletList s1 s2 s3 e) =
+ s3 `insert` freeVars e \\ fromList [s1, s2]
+ freeVars (KEhandle e1 e2) =
+ freeVars e1 `union` freeVars e2
+ freeVars (KEseq e1 e2) =
+ freeVars e1 `union` freeVars e2
+ freeVars (KEextFunApp s ss) =
+ fromList $ s:ss
+ freeVars _ =
+ empty
+
pprKExpr :: KExpr -> Iseq
pprKExpr KEunit = iStr "()"
pprKExpr KEnil = iStr "[]"

0 comments on commit e86113c

Please sign in to comment.