Permalink
Browse files

Merge branch 'feature/inline' into develop

  • Loading branch information...
2 parents d7089d1 + 71c3336 commit 6c7436f7788b76b923171d414ac061075560fcfa @Averethel committed Feb 19, 2013
Showing with 106 additions and 8 deletions.
  1. +5 −2 AlphaConvert.hs
  2. +7 −6 Compiler.hs
  3. +11 −0 Inline.hs
  4. +21 −0 Inline/Env.hs
  5. +49 −0 Inline/Inline.hs
  6. +13 −0 Inline/Size.hs
View
@@ -1,4 +1,4 @@
-module AlphaConvert (alphaConvert) where
+module AlphaConvert (alphaConvert, alphaConvertWithEnv) where
import qualified AlphaConvert.AlphaConvert as AC
import AlphaConvert.Counter
import AlphaConvert.Env
@@ -7,4 +7,7 @@ module AlphaConvert (alphaConvert) where
import Control.Monad.State
alphaConvert :: KExpr -> KExpr
- alphaConvert e = fst $ runState (AC.alphaConvert emptyEnv e) emptyState
+ alphaConvert = alphaConvertWithEnv emptyEnv
+
+ alphaConvertWithEnv :: Env -> KExpr -> KExpr
+ alphaConvertWithEnv env e = fst $ runState (AC.alphaConvert env e) emptyState
View
@@ -1,24 +1,25 @@
module Compiler (compile) where
import AlphaConvert
import BetaReduce
+ import Inline
import KNormal
import LetFlatten
import PatternMatching
import Syntax
import TypeInference
- compiler :: Expr -> IO KExpr
- compiler e0 = do
+ compiler :: Integer -> Expr -> IO KExpr
+ compiler t e0 = do
let e1 = compilePatternMatching e0
let e2 = convertToKNormal e1
let e3 = alphaConvert e2
e4 <- betaReduce e3
let e5 = letFlatten e4
- return e5
+ inline t e5
- compile :: Expr -> IO (Either String KExpr)
- compile expr = case typeOfExpression emptyEnv expr of
+ compile :: Integer -> Expr -> IO (Either String KExpr)
+ compile inlineTreshold expr = case typeOfExpression emptyEnv expr of
Left er -> return $ Left er
Right _ -> do
- c <- compiler expr
+ c <- compiler inlineTreshold expr
return $ Right c
View
@@ -0,0 +1,11 @@
+module Inline (inline, defaultTreshold) where
+ import Inline.Env
+ import qualified Inline.Inline as I
+
+ import KNormal.KSyntax
+
+ defaultTreshold :: Integer
+ defaultTreshold = 0
+
+ inline :: Integer -> KExpr -> IO KExpr
+ inline = I.inline emptyEnv
View
@@ -0,0 +1,21 @@
+module Inline.Env where
+ import KNormal.KSyntax
+
+ import qualified Data.List as L
+ import Data.Maybe
+
+ type Env = [FunDef]
+
+ emptyEnv :: Env
+ emptyEnv = []
+
+ member :: String -> Env -> Bool
+ member n = any (\x -> name x == n)
+
+ find :: Env -> String -> ([String], KExpr)
+ find e n =
+ let fd = fromJust $ L.find (\x -> name x == n) e
+ in (args fd, body fd)
+
+ extend :: Env -> FunDef -> Env
+ extend = flip (:)
View
@@ -0,0 +1,49 @@
+module Inline.Inline where
+ import Inline.Env
+ import Inline.Size
+
+ import KNormal.KSyntax
+ import AlphaConvert
+
+ inline :: Env -> Integer -> KExpr -> IO KExpr
+ inline env trs (KEifEq s1 s2 e1 e2) = do
+ e1' <- inline env trs e1
+ e2' <- inline env trs e2
+ return $ KEifEq s1 s2 e1' e2'
+ inline env trs (KEifLE s1 s2 e1 e2) = do
+ e1' <- inline env trs e1
+ e2' <- inline env trs e2
+ return $ KEifLE s1 s2 e1' e2'
+ inline env trs (KElet s e1 e2) = do
+ e1' <- inline env trs e1
+ e2' <- inline env trs e2
+ return $ KElet s e1' e2'
+ inline env trs (KEletRec fd e) = do
+ b' <- inline env trs $ body fd
+ e' <- inline env' trs e
+ return $ KEletRec fd { body = b' } e'
+ where
+ env'
+ | size (body fd) > trs = env
+ | otherwise = env `extend` fd
+ inline env trs (KEapply s ss)
+ | s `member` env = do
+ putStrLn $ "Inlining " ++ show s ++ "."
+ let (fas, b) = env `find` s
+ inline env trs $ alphaConvertWithEnv (zip fas ss) b
+ inline env trs (KEletPair s1 s2 s3 e) = do
+ e' <- inline env trs e
+ return $ KEletPair s1 s2 s3 e'
+ inline env trs (KEletList s1 s2 s3 e) = do
+ e' <- inline env trs e
+ return $ KEletList s1 s2 s3 e'
+ inline env trs (KEhandle e1 e2) = do
+ e1' <- inline env trs e1
+ e2' <- inline env trs e2
+ return $ KEhandle e1' e2'
+ inline env trs (KEseq e1 e2) = do
+ e1' <- inline env trs e1
+ e2' <- inline env trs e2
+ return $ KEseq e1' e2'
+ inline _ _ e =
+ return e
View
@@ -0,0 +1,13 @@
+module Inline.Size where
+ import KNormal.KSyntax
+
+ size :: KExpr -> Integer
+ size (KEifEq _ _ e1 e2) = 1 + size e1 + size e2
+ size (KEifLE _ _ e1 e2) = 1 + size e1 + size e2
+ size (KElet _ e1 e2) = 1 + size e1 + size e2
+ size (KEletRec fd e) = 1 + size e + size (body fd)
+ size (KEletPair _ _ _ e) = 1 + size e
+ size (KEletList _ _ _ e) = 1 + size e
+ size (KEhandle e1 e2) = size e1 + size e2
+ size (KEseq e1 e2) = size e1 + size e2
+ size _ = 1

0 comments on commit 6c7436f

Please sign in to comment.