Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
...
  • 8 commits
  • 5 files changed
  • 0 commit comments
  • 1 contributor
Showing with 321 additions and 3 deletions.
  1. +11 −0 ClosureConvert.hs
  2. +197 −0 ClosureConvert/CSyntax.hs
  3. +105 −0 ClosureConvert/ClosureConvert.hs
  4. +5 −3 Compiler.hs
  5. +3 −0 README.md
View
11 ClosureConvert.hs
@@ -0,0 +1,11 @@
+module ClosureConvert (
+ ClosureConvert.closureConvert,
+ Program(..)
+) where
+ import ClosureConvert.CSyntax
+ import ClosureConvert.ClosureConvert
+
+ import KNormal.KSyntax
+
+ closureConvert :: KExpr -> IO Program
+ closureConvert = ClosureConvert.ClosureConvert.closureConvert []
View
197 ClosureConvert/CSyntax.hs
@@ -0,0 +1,197 @@
+module ClosureConvert.CSyntax where
+ import Utils.Iseq
+
+ import Data.Set hiding (map)
+
+ data Label = L String deriving Eq
+
+ instance Show Label where
+ show (L s) = "_L_" ++ s
+
+ data Closure = C {
+ entry :: Label,
+ actFvs :: [String]
+ } deriving Eq
+
+ pprClosure :: Closure -> Iseq
+ pprClosure c = iConcat [ iStr "{ ", iStr . show . entry $ c,
+ iStr ", [ ", iInterleave (iStr ", ") $
+ map iStr (actFvs c), iStr " }" ]
+
+ instance Show Closure where
+ show = show . pprClosure
+
+ data CExpr =
+ -- constants
+ CEunit
+ | CEnil
+ | CEint Integer
+ -- unary primitives
+ | CEneg String
+ | CEload String
+ -- binary primitives
+ | CEadd String String
+ | CEsub String String
+ | CEmult String String
+ | CEdiv String String
+ | CEmod String String
+ | CEstore String String
+ --
+ | CEvar String
+ | CEerror String
+ | CEifEq String String CExpr CExpr
+ | CEifLE String String CExpr CExpr
+ | CElet String CExpr CExpr
+ | CEmakeClj String Closure CExpr
+ | CEappClj String [String]
+ | CEappDir Label [String]
+ | CEpair String String
+ | CEcons String String
+ | CEletPair String String String CExpr
+ | CEletList String String String CExpr
+ | CEhandle CExpr CExpr
+ | CEseq CExpr CExpr
+ deriving Eq
+
+ freeVars :: CExpr -> Set String
+ freeVars (CEneg s1) =
+ singleton s1
+ freeVars (CEload s1) =
+ singleton s1
+ freeVars (CEadd s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEsub s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEmult s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEdiv s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEmod s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEstore s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEvar s1) =
+ singleton s1
+ freeVars (CEifEq s1 s2 e1 e2) =
+ s1 `insert` (s2 `insert` freeVars e1 `union` freeVars e2)
+ freeVars (CEifLE s1 s2 e1 e2) =
+ s1 `insert` (s2 `insert` freeVars e1 `union` freeVars e2)
+ freeVars (CElet s1 e1 e2) =
+ s1 `delete` (freeVars e1 `union` freeVars e2)
+ freeVars (CEmakeClj s1 clj e) =
+ s1 `delete` (fromList (actFvs clj) `union` freeVars e)
+ freeVars (CEappClj s1 ss) =
+ fromList $ s1 : ss
+ freeVars (CEappDir _ ss) =
+ fromList ss
+ freeVars (CEpair s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEcons s1 s2) =
+ fromList [s1, s2]
+ freeVars (CEletPair s1 s2 s3 e) =
+ s3 `insert` freeVars e \\ fromList [s1, s2]
+ freeVars (CEletList s1 s2 s3 e) =
+ s3 `insert` freeVars e \\ fromList [s1, s2]
+ freeVars (CEhandle e1 e2) =
+ freeVars e1 `union` freeVars e2
+ freeVars (CEseq e1 e2) =
+ freeVars e1 `union` freeVars e2
+ freeVars _ =
+ empty
+
+ pprCExpr :: CExpr -> Iseq
+ pprCExpr CEunit = iStr "()"
+ pprCExpr CEnil = iStr "[]"
+ pprCExpr (CEint n) = iStr . show $ n
+ pprCExpr (CEneg s) = iStr "-" `iAppend` iStr s
+ pprCExpr (CEload s) = iStr "&" `iAppend` iStr s
+ pprCExpr (CEadd s1 s2) = iConcat [ iStr s1, iStr " + ", iStr s2 ]
+ pprCExpr (CEsub s1 s2) = iConcat [ iStr s1, iStr " - ", iStr s2 ]
+ pprCExpr (CEmult s1 s2) = iConcat [ iStr s1, iStr " * ", iStr s2 ]
+ pprCExpr (CEdiv s1 s2) = iConcat [ iStr s1, iStr " / ", iStr s2 ]
+ pprCExpr (CEmod s1 s2) = iConcat [ iStr s1, iStr " % ", iStr s2 ]
+ pprCExpr (CEstore s1 s2) = iConcat [ iStr s1, iStr " := ", iStr s2 ]
+ pprCExpr (CEvar s) = iStr s
+ pprCExpr (CEerror s) = iStr s
+ pprCExpr (CEifEq s1 s2 e1 e2) = iConcat [ iStr "if ", iStr s1,
+ iStr " == ", iStr s2, iStr "{",
+ iNewline, indentation,
+ iIndent $ pprCExpr e1,
+ iStr " } else { ",
+ iNewline, indentation,
+ iIndent $ pprCExpr e2,
+ iNewline, iStr "}" ]
+ pprCExpr (CEifLE s1 s2 e1 e2) = iConcat [ iStr "if ", iStr s1,
+ iStr " <= ", iStr s2, iStr "{",
+ iNewline, indentation,
+ iIndent $ pprCExpr e1,
+ iStr " } else { ",
+ iNewline, indentation,
+ iIndent $ pprCExpr e2,
+ iNewline, iStr "}" ]
+ pprCExpr (CElet s e1 e2) = iConcat [ iStr "let ", iStr s,
+ iStr " = ", pprCExpr e1,
+ iNewline, iStr "in ",
+ pprCExpr e2 ]
+ pprCExpr (CEmakeClj s c e) = iConcat [ iStr "make_closure( ", iStr s,
+ pprClosure c, pprCExpr e,
+ iStr " )" ]
+ pprCExpr (CEappClj s ss) = iConcat [ iStr s, iStr "@( ",
+ iInterleave (iStr ", ") $
+ map iStr ss,
+ iStr " )" ]
+ pprCExpr (CEappDir s ss) = iInterleave (iStr " ") $ map iStr $
+ show s:ss
+ pprCExpr (CEpair s1 s2) = iConcat [ iStr "(", iStr s1, iStr ", ",
+ iStr s2, iStr ")" ]
+ pprCExpr (CEcons s1 s2) = iConcat [ iStr s1, iStr "::", iStr s2 ]
+ pprCExpr (CEletPair s1 s2 s3 e) = iConcat [ iStr "let (", iStr s1,
+ iStr ", ", iStr s2, iStr ") = ",
+ iStr s3, iNewline, iStr "in ",
+ pprCExpr e ]
+ pprCExpr (CEletList s1 s2 s3 e) = iConcat [ iStr "let ", iStr s1,
+ iStr "::", iStr s2, iStr " = ",
+ iStr s3, iNewline, iStr "in ",
+ pprCExpr e ]
+ pprCExpr (CEhandle e1 e2) = iConcat [ pprCExpr e1, iNewline,
+ iStr "rescue", iNewline,
+ pprCExpr e2 ]
+ pprCExpr (CEseq e1 e2) = iConcat [ pprCExpr e1, iStr "; ",
+ pprCExpr e2 ]
+
+ instance Show CExpr where
+ show = show . pprCExpr
+
+ data FunDef = FD {
+ name :: Label,
+ args :: [String],
+ formalFvs :: [String],
+ body :: CExpr
+ } deriving Eq
+
+ pprFunDef :: FunDef -> Iseq
+ pprFunDef fd = iConcat [ iStr . show . name $ fd, iStr " ",
+ iInterleave (iStr " ") $ map iStr $ args fd,
+ iStr " =", iNewline, indentation,
+ iIndent . pprCExpr . body $ fd,
+ iNewline, iStr "FVs = ",
+ iInterleave (iStr ", ") $ map iStr $ formalFvs fd ]
+
+ instance Show FunDef where
+ show = show . pprFunDef
+
+ data Program = P {
+ definitions :: [FunDef],
+ main :: CExpr
+ } deriving Eq
+
+ pprProgram :: Program -> Iseq
+ pprProgram (P [] e) = pprCExpr e
+ pprProgram (P fds e) = iConcat [ iInterleave (iStr ";;" `iAppend` iNewline) $
+ map pprFunDef fds, iStr ";;", iNewline,
+ pprCExpr e ]
+
+ instance Show Program where
+ show = show . pprProgram
+
+
View
105 ClosureConvert/ClosureConvert.hs
@@ -0,0 +1,105 @@
+module ClosureConvert.ClosureConvert where
+ import ClosureConvert.CSyntax
+
+ import KNormal.KSyntax
+
+ import Data.Set
+
+ closureConvert :: [Label] -> KExpr -> IO Program
+ closureConvert _ KEunit =
+ return $ P [] CEunit
+ closureConvert _ KEnil =
+ return $ P [] CEnil
+ closureConvert _ (KEint n) =
+ return $ P [] $ CEint n
+ closureConvert _ (KEneg x) =
+ return $ P [] $ CEneg x
+ closureConvert _ (KEload r) =
+ return $ P [] $ CEload r
+ closureConvert _ (KEadd x y) =
+ return $ P [] $ CEadd x y
+ closureConvert _ (KEsub x y) =
+ return $ P [] $ CEsub x y
+ closureConvert _ (KEmult x y) =
+ return $ P [] $ CEmult x y
+ closureConvert _ (KEdiv x y) =
+ return $ P [] $ CEdiv x y
+ closureConvert _ (KEmod x y) =
+ return $ P [] $ CEmod x y
+ closureConvert _ (KEstore r x) =
+ return $ P [] $ CEstore r x
+ closureConvert _ (KEvar x) =
+ return $ P [] $ CEvar x
+ closureConvert _ (KEerror m) =
+ return $ P [] $ CEerror m
+ closureConvert known (KEifEq x y e1 e2) = do
+ p1 <- closureConvert known e1
+ p2 <- closureConvert known e2
+ return $ P (definitions p1 ++ definitions p2)
+ $ CEifEq x y (main p1) $ main p2
+ closureConvert known (KEifLE x y e1 e2) = do
+ p1 <- closureConvert known e1
+ p2 <- closureConvert known e2
+ return $ P (definitions p1 ++ definitions p2)
+ $ CEifLE x y (main p1) $ main p2
+ closureConvert known (KElet x e1 e2) = do
+ p1 <- closureConvert known e1
+ p2 <- closureConvert known e2
+ return $ P (definitions p1 ++ definitions p2)
+ $ CElet x (main p1) $ main p2
+ closureConvert known (KEletRec fd e) = do
+ let x = KNormal.KSyntax.name fd
+ let as = KNormal.KSyntax.args fd
+ let e1 = KNormal.KSyntax.body fd
+ let known' = L x : known
+ p1 <- closureConvert known' e1
+ let zs = ClosureConvert.CSyntax.freeVars (main p1) \\ fromList as
+ (p1', known'') <-
+ if zs /= empty
+ then do
+ putStrLn $ "Free variable(s) " ++ show (toList zs) ++
+ " found in function " ++ x ++ "."
+ putStrLn $ "Function " ++ x ++ " cannot be applied directly."
+ p <- closureConvert known e1
+ return (p, known)
+ else
+ return (p1, known')
+ p2 <- closureConvert known'' e
+ let fvs = toList $ ClosureConvert.CSyntax.freeVars (main p1') \\
+ singleton x `union` fromList as
+ let df = ClosureConvert.CSyntax.FD { ClosureConvert.CSyntax.name = L x,
+ ClosureConvert.CSyntax.args = as,
+ formalFvs = fvs, ClosureConvert.CSyntax.body = main p1' }
+ let dfs = df : (definitions p1' ++ definitions p2)
+ if x `member` ClosureConvert.CSyntax.freeVars (main p2)
+ then
+ return $ P dfs $ CEmakeClj x C { entry = L x, actFvs = fvs } $ main p2
+ else do
+ putStrLn $ "Eliminating closure " ++ x
+ return $ P dfs $ main p2
+ closureConvert known (KEapply s ss)
+ | L s `elem` known = do
+ putStrLn $ "Directly applying " ++ s
+ return $ P [] $ CEappDir (L s) ss
+ | otherwise =
+ return $ P [] $ CEappClj s ss
+ closureConvert _ (KEpair a b) =
+ return $ P [] $ CEpair a b
+ closureConvert _ (KEcons h t) =
+ return $ P [] $ CEcons h t
+ closureConvert known (KEletPair a b p e) = do
+ pr <- closureConvert known e
+ return $ P (definitions pr) $ CEletPair a b p $ main pr
+ closureConvert known (KEletList h t l e) = do
+ p <- closureConvert known e
+ return $ P (definitions p) $ CEletList h t l $ main p
+ closureConvert known (KEhandle e1 e2) = do
+ p1 <- closureConvert known e1
+ p2 <- closureConvert known e2
+ return $ P (definitions p1 ++ definitions p2) $ CEhandle (main p1) $ main p2
+ closureConvert known (KEseq e1 e2) = do
+ p1 <- closureConvert known e1
+ p2 <- closureConvert known e2
+ return $ P (definitions p1 ++ definitions p2) $ CEseq (main p1) $ main p2
+ closureConvert _ (KEextFunApp s ss) =
+ return $ P [] $ CEappDir (L s) ss
View
8 Compiler.hs
@@ -1,6 +1,7 @@
module Compiler (compile) where
import AlphaConvert
import BetaReduce
+ import ClosureConvert
import ConstantsFold
import EliminateDefinitions
import Inline
@@ -10,7 +11,7 @@ module Compiler (compile) where
import Syntax
import TypeInference
- compiler :: Integer -> Expr -> IO KExpr
+ compiler :: Integer -> Expr -> IO Program
compiler t e0 = do
let e1 = compilePatternMatching e0
let e2 = convertToKNormal e1
@@ -19,9 +20,10 @@ module Compiler (compile) where
let e5 = letFlatten e4
e6 <- inline t e5
let e7 = constantsFold e6
- eliminateDefinitions e7
+ e8 <- eliminateDefinitions e7
+ closureConvert e8
- compile :: Integer -> Expr -> IO (Either String KExpr)
+ compile :: Integer -> Expr -> IO (Either String Program)
compile inlineTreshold expr = case typeOfExpression emptyEnv expr of
Left er -> return $ Left er
Right _ -> do
View
3 README.md
@@ -5,9 +5,12 @@ Implementation of OCamlMin language based on min-caml project.
Changelog
=========
+* 11 III 2013
+ * Closure conversion module
* 23 II 2013
* Constant folding
* Unused definitions elimination
+ * Syntax for closure converted expressions
* 19 II 2013
* β-reduction
* nested let expressions flattening

No commit comments for this range

Something went wrong with that request. Please try again.