Permalink
Browse files

Merge branch 'feature/K-normalization' into develop

  • Loading branch information...
2 parents 61ac1b0 + 2319adb commit 4f704f5f451ff4289339035c9b96079b163beda5 @Averethel committed Feb 16, 2013
Showing with 441 additions and 1 deletion.
  1. +10 −0 Compiler.hs
  2. +14 −0 KNormal.hs
  3. +26 −0 KNormal/Counter.hs
  4. +277 −0 KNormal/KNormalize.hs
  5. +110 −0 KNormal/KSyntax.hs
  6. +4 −1 TypeInference.hs
View
10 Compiler.hs
@@ -0,0 +1,10 @@
+module Compiler (compile) where
+ import KNormal
+ import PatternMatching
+ import Syntax
+ import TypeInference
+
+ compile :: Expr -> Either String KExpr
+ compile expr = case typeOfExpression emptyEnv expr of
+ Left er -> Left er
+ Right _ -> Right . convertToKNormal . compilePatternMatching $ expr
View
14 KNormal.hs
@@ -0,0 +1,14 @@
+module KNormal (
+ convertToKNormal,
+ KExpr(..)
+) where
+ import KNormal.Counter
+ import KNormal.KNormalize
+ import KNormal.KSyntax
+
+ import Syntax
+
+ import Control.Monad.State
+
+ convertToKNormal :: Expr -> KExpr
+ convertToKNormal e = fst $ runState (kNormalize e) emptyState
View
26 KNormal/Counter.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module KNormal.Counter where
+ import Control.Monad.State
+
+ data Counter = C {
+ variable :: Integer,
+ lambda :: Integer
+ }
+
+ emptyState :: Counter
+ emptyState = C 0 0
+
+ freshVar :: MonadState Counter m => m String
+ freshVar = do
+ s <- get
+ put s { variable = variable s + 1 }
+ return $ '_':'K': show (variable s)
+
+ freshLambda :: MonadState Counter m => m String
+ freshLambda = do
+ s <- get
+ put s { lambda = lambda s + 1 }
+ return $ '_':'L': 'a' : 'm' : show (lambda s)
View
277 KNormal/KNormalize.hs
@@ -0,0 +1,277 @@
+{-# LANGUAGE
+ FlexibleContexts
+ #-}
+
+module KNormal.KNormalize (kNormalize) where
+ import KNormal.Counter
+ import KNormal.KSyntax
+
+ import Syntax
+
+ import Control.Exception.Base
+ import Control.Monad.State
+
+ import Utils.Errors
+
+ insertLet :: MonadState Counter m => KExpr -> (String -> m KExpr) -> m KExpr
+ insertLet (KEvar x) k = k x
+ insertLet e k = do
+ x <- freshVar
+ e' <- k x
+ return $ KElet x e e'
+
+ kNormalizeConstant :: Constant -> KExpr
+ kNormalizeConstant (Cint n) = KEint n
+ kNormalizeConstant (Cbool b) = KEint $ if b then 1 else 0
+ kNormalizeConstant Cnil = KEnil
+ kNormalizeConstant Cunit = KEunit
+
+ mkFunDef :: MonadState Counter m => String -> FunClause -> m FunDef
+ mkFunDef n fc = do
+ let as = map (\(Pvar x) -> x) $ arguments fc
+ b <- kNormalize $ fbody fc
+ return FD{ name = n, body = b, args = as }
+
+ kNormalizeUPrim :: MonadState Counter m => UnaryPrim -> Expr -> m KExpr
+ kNormalizeUPrim UPnot e =
+ kNormalize $ Eif e (Econst $ Cbool False) $ Econst $ Cbool True
+ kNormalizeUPrim UPref e = do
+ e' <- kNormalize e
+ insertLet e' (\x -> return $ KEextFunApp "create_ref" [x])
+ kNormalizeUPrim UPderef e = do
+ e' <- kNormalize e
+ insertLet e' (return . KEload)
+ kNormalizeUPrim UPminus e = do
+ e' <- kNormalize e
+ insertLet e' (return . KEneg)
+
+ kNormalizeOp :: MonadState Counter m =>
+ (String -> String -> KExpr) -> Expr -> Expr -> m KExpr
+ kNormalizeOp op e1 e2 = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ insertLet e2' (return . op x)})
+
+ kNormalizeBPrim :: MonadState Counter m =>
+ BinaryPrim -> Expr -> Expr -> m KExpr
+ kNormalizeBPrim BPeq e1 e2 = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ insertLet e2' (\y -> return $ KEifEq x y (KEint 1) (KEint 0))})
+ kNormalizeBPrim BPlt e1 e2 = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ insertLet e2' (\y -> return $ KEifLE x y
+ (KEifEq x y (KEint 0) (KEint 1)) (KEint 0))})
+ kNormalizeBPrim BPgt e1 e2 = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ insertLet e2' (\y -> return $ KEifLE x y (KEint 0) (KEint 1))})
+ kNormalizeBPrim BPor e1 e2 = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ v <- freshVar;
+ return $ KElet v (KEint 1) $ KEifEq x v (KEint 1) e2' })
+ kNormalizeBPrim BPand e1 e2 = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ v <- freshVar;
+ return $ KElet v (KEint 1) $ KEifEq x v e2' (KEint 0) })
+ kNormalizeBPrim BPadd e1 e2 =
+ kNormalizeOp KEadd e1 e2
+ kNormalizeBPrim BPsub e1 e2 =
+ kNormalizeOp KEsub e1 e2
+ kNormalizeBPrim BPmult e1 e2 =
+ kNormalizeOp KEmult e1 e2
+ kNormalizeBPrim BPdiv e1 e2 =
+ kNormalizeOp KEdiv e1 e2
+ kNormalizeBPrim BPmod e1 e2 =
+ kNormalizeOp KEmod e1 e2
+ kNormalizeBPrim BPassign e1 e2 =
+ kNormalizeOp KEstore e1 e2
+
+ kNormalizeArgs :: MonadState Counter m =>
+ [Expr] -> m ([String], KExpr -> KExpr)
+ kNormalizeArgs [] = return ([], id)
+ kNormalizeArgs (a:as) = do
+ (as', f) <- kNormalizeArgs as
+ a' <- kNormalize a
+ case a' of
+ KEvar x -> return (x:as', f)
+ _ -> do
+ v <- freshVar
+ return (v:as', KElet v a' . f)
+
+
+ kNormalizeCaseBool :: MonadState Counter m =>
+ String -> Expr -> Expr -> m KExpr
+ kNormalizeCaseBool n et ef = do
+ v <- freshVar
+ et' <- kNormalize et
+ ef' <- kNormalize ef
+ return $ KElet v (KEint 1) $ KEifEq n v et' ef'
+
+ genVars :: MonadState Counter m => String -> m (KExpr, String, String)
+ genVars n = do
+ let e' = KEextFunApp "tag_of" [n]
+ v1 <- freshVar
+ v2 <- freshVar
+ return (e', v1, v2)
+
+ kNormalizeCaseList :: MonadState Counter m =>
+ String -> Expr -> String -> String -> Expr -> m KExpr
+ kNormalizeCaseList n en x xs ec = do
+ (e', v1, v2) <- genVars n
+ v3 <- freshVar
+ en' <- kNormalize en
+ ec' <- kNormalize ec
+ return $ KElet v1 e' $ KElet v2 (KEint 0) $ KElet v2 (KEint 1) $
+ KEifEq v1 v2 en' $ KEifEq v1 v3 (KEletList x xs n ec') $
+ KEerror matchFailure
+
+
+
+ kNormalizeCase :: MonadState Counter m =>
+ [CaseClause] -> String -> m KExpr
+ -- pair
+ kNormalizeCase [CC { constructor = CNpair,
+ variables = [a, b],
+ cbody = cb }] n = do
+ (e', v1, v2) <- genVars n
+ cb' <- kNormalize cb
+ return $ KElet v1 (KEint 0) $
+ KElet v2 e' $ KEifEq v1 v2 (KEletPair a b n cb')
+ (KEerror matchFailure)
+ -- boolean
+ kNormalizeCase [CC { constructor = CNtrue,
+ variables = [],
+ cbody = bt },
+ CC { constructor = CNfalse,
+ variables = [],
+ cbody = bf }] n =
+ kNormalizeCaseBool n bt bf
+ kNormalizeCase [CC { constructor = CNfalse,
+ variables = [],
+ cbody = bf },
+ CC { constructor = CNtrue,
+ variables = [],
+ cbody = bt }] n =
+ kNormalizeCaseBool n bt bf
+ -- list
+ kNormalizeCase [CC { constructor = CNnil,
+ variables = [],
+ cbody = bn },
+ CC { constructor = CNcons,
+ variables = [x, xs],
+ cbody = bc }] n =
+ kNormalizeCaseList n bn x xs bc
+ kNormalizeCase [CC { constructor = CNcons,
+ variables = [x, xs],
+ cbody = bc },
+ CC { constructor = CNnil,
+ variables = [],
+ cbody = bn }] n =
+ kNormalizeCaseList n bn x xs bc
+ -- unit
+ kNormalizeCase [CC { constructor = CNunit,
+ variables = [],
+ cbody = b }] n = do
+ (e', v1, v2) <- genVars n
+ b' <- kNormalize b
+ return $ KElet v1 (KEint 0) $
+ KElet v2 e' $ KEifEq v1 v2 b'
+ (KEerror matchFailure)
+ kNormalizeCase ccs n = assert False $ kNormalizeCase ccs n
+
+
+ kNormalize :: MonadState Counter m => Expr -> m KExpr
+ kNormalize (Econst c) =
+ return $ kNormalizeConstant c
+ kNormalize (Evar s) =
+ -- Here should be checking for external references
+ -- when modules are implemented
+ return $ KEvar s
+ kNormalize (Elet (Pvar s) (Efun fcs) e2) = do
+ fd <- mkFunDef s $ head fcs
+ e2' <- kNormalize e2
+ return $ KEletRec fd e2'
+ kNormalize (Elet (Pvar s) e1 e2) = do
+ e1' <- kNormalize e1
+ e2' <- kNormalize e2
+ return $ KElet s e1' e2'
+ kNormalize (Elet (Ppair (Pvar p1) (Pvar p2)) e1 e2) = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ return $ KEletPair p1 p2 x e2' })
+ kNormalize (Elet (Pcons (Pvar p1) (Pvar p2)) e1 e2) = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ e2' <- kNormalize e2;
+ return $ KEletList p1 p2 x e2' })
+ kNormalize (Eletrec s fcs e) = do
+ fd <- mkFunDef s $ head fcs
+ e' <- kNormalize e
+ return $ KEletRec fd e'
+ kNormalize (Eapply (Euprim up) [e]) =
+ kNormalizeUPrim up e
+ kNormalize (Eapply (Ebprim bp) [e1, e2]) =
+ kNormalizeBPrim bp e1 e2
+ kNormalize (Eapply (Efun fcs) as) = do
+ l <- freshLambda
+ fd <- mkFunDef l $ head fcs
+ (as', lt) <- kNormalizeArgs as
+ return $ KEletRec fd $ lt $ KEapply l as'
+ kNormalize (Eapply (Evar x) as) = do
+ (as', lt) <- kNormalizeArgs as
+ return $ lt $ KEapply x as'
+ kNormalize (Epair e1 e2) =
+ kNormalizeOp KEpair e1 e2
+ kNormalize (Econs e1 e2) =
+ kNormalizeOp KEcons e1 e2
+ kNormalize (Eif (Eapply (Euprim UPnot) [c1]) e2 e3) =
+ kNormalize (Eif c1 e3 e2)
+ kNormalize (Eif (Eapply (Ebprim BPeq) [c1, c2]) e2 e3) = do
+ c1' <- kNormalize c1
+ insertLet c1' (\x -> do {
+ c2' <- kNormalize c2;
+ insertLet c2' (\y -> do {
+ e2' <- kNormalize e2;
+ e3' <- kNormalize e3;
+ return $ KEifEq x y e2' e3'})})
+ kNormalize (Eif (Eapply (Ebprim BPgt) [c1, c2]) e2 e3) = do
+ c1' <- kNormalize c1
+ insertLet c1' (\x -> do {
+ c2' <- kNormalize c2;
+ insertLet c2' (\y -> do {
+ e2' <- kNormalize e2;
+ e3' <- kNormalize e3;
+ return $ KEifLE x y e3' e2'})})
+ kNormalize (Eif e1 e2 e3) = do
+ e1' <- kNormalize e1
+ insertLet e1' (\x -> do {
+ y <- freshVar;
+ e2' <- kNormalize e2;
+ e3' <- kNormalize e3;
+ return $ KElet y (KEint 1) $ KEifEq x y e2' e3' })
+ kNormalize (Eseq e1 e2) = do
+ e1' <- kNormalize e1
+ e2' <- kNormalize e2
+ return $ KEseq e1' e2'
+ kNormalize (Ecase e ccs) = do
+ e' <- kNormalize e
+ insertLet e' (kNormalizeCase ccs)
+ kNormalize (Ehandle e1 e2) = do
+ e1' <- kNormalize e1
+ e2' <- kNormalize e2
+ return $ KEhandle e1' e2'
+ kNormalize EmatchFailure =
+ return $ KEerror matchFailure
+ kNormalize e =
+ assert False (kNormalize e)
View
110 KNormal/KSyntax.hs
@@ -0,0 +1,110 @@
+module KNormal.KSyntax where
+ import Utils.Iseq
+
+ data FunDef = FD {
+ name :: String,
+ args :: [String],
+ body :: KExpr
+ } deriving Eq
+
+ pprFunDef :: FunDef -> Iseq
+ pprFunDef fd = iConcat [ iInterleave (iStr " ")
+ (map iStr $ name fd : args fd),
+ iStr " = ", pprKExpr (body fd) ]
+
+ instance Show FunDef where
+ show = show . pprFunDef
+
+ data KExpr =
+ -- constants
+ KEunit
+ | KEnil
+ | KEint Integer
+ -- unary ptimitives
+ | KEneg String -- Bit negation
+ | KEload String -- Dereference
+ -- binary primitives
+ | KEadd String String
+ | KEsub String String
+ | KEmult String String
+ | KEdiv String String
+ | KEmod String String
+ | KEstore String String -- Assignment
+ --
+ | KEvar String
+ | KEerror String
+ | KEifEq String String KExpr KExpr
+ | KEifLE String String KExpr KExpr
+ | KElet String KExpr KExpr -- Functions are not allowed
+ | KEletRec FunDef KExpr -- Annonymous functions will be named
+ | KEapply String [String]
+ | KEpair String String
+ | KEcons String String
+ | KEletPair String String String KExpr -- Read from pair
+ | KEletList String String String KExpr -- Read from list
+ | KEhandle KExpr KExpr
+ | KEseq KExpr KExpr
+ | KEextFunApp String [String] -- External function application
+ deriving Eq -- Known external functions:
+ -- - reference maker
+ -- - tag getter
+
+ pprKExpr :: KExpr -> Iseq
+ pprKExpr KEunit = iStr "()"
+ pprKExpr KEnil = iStr "[]"
+ pprKExpr (KEint n) = iStr . show $ n
+ pprKExpr (KEneg s) = iStr "-" `iAppend` iStr s
+ pprKExpr (KEload s) = iStr "&" `iAppend` iStr s
+ pprKExpr (KEadd s1 s2) = iConcat [ iStr s1, iStr " + ", iStr s2 ]
+ pprKExpr (KEsub s1 s2) = iConcat [ iStr s1, iStr " - ", iStr s2 ]
+ pprKExpr (KEmult s1 s2) = iConcat [ iStr s1, iStr " * ", iStr s2 ]
+ pprKExpr (KEdiv s1 s2) = iConcat [ iStr s1, iStr " / ", iStr s2 ]
+ pprKExpr (KEmod s1 s2) = iConcat [ iStr s1, iStr " % ", iStr s2 ]
+ pprKExpr (KEstore s1 s2) = iConcat [ iStr s1, iStr " := ", iStr s2 ]
+ pprKExpr (KEvar s) = iStr s
+ pprKExpr (KEerror s) = iStr s
+ pprKExpr (KEifEq s1 s2 e1 e2) = iConcat [ iStr "if ", iStr s1,
+ iStr " == ", iStr s2, iStr "{",
+ iNewline, indentation,
+ iIndent $ pprKExpr e1,
+ iStr " } else { ",
+ iNewline, indentation,
+ iIndent $ pprKExpr e2,
+ iNewline, iStr "}" ]
+ pprKExpr (KEifLE s1 s2 e1 e2) = iConcat [ iStr "if ", iStr s1,
+ iStr " <= ", iStr s2, iStr "{",
+ iNewline, indentation,
+ iIndent $ pprKExpr e1,
+ iStr " } else { ",
+ iNewline, indentation,
+ iIndent $ pprKExpr e2,
+ iNewline, iStr "}" ]
+ pprKExpr (KElet s e1 e2) = iConcat [ iStr "let ", iStr s,
+ iStr " = ", pprKExpr e1,
+ iNewline, iStr "in ",
+ pprKExpr e2 ]
+ pprKExpr (KEletRec fd e) = iConcat [ iStr "letrec ", pprFunDef fd,
+ iNewline, iStr "in ",
+ pprKExpr e ]
+ pprKExpr (KEapply s ss) = iInterleave (iStr " ") $ map iStr (s:ss)
+ pprKExpr (KEpair s1 s2) = iConcat [ iStr "(", iStr s1, iStr ", ",
+ iStr s2, iStr ")" ]
+ pprKExpr (KEcons s1 s2) = iConcat [ iStr s1, iStr "::", iStr s2 ]
+ pprKExpr (KEletPair s1 s2 s3 e) = iConcat [ iStr "let (", iStr s1,
+ iStr ", ", iStr s2, iStr ") = ",
+ iStr s3, iNewline, iStr "in ",
+ pprKExpr e ]
+ pprKExpr (KEletList s1 s2 s3 e) = iConcat [ iStr "let ", iStr s1,
+ iStr "::", iStr s2, iStr " = ",
+ iStr s3, iNewline, iStr "in ",
+ pprKExpr e ]
+ pprKExpr (KEhandle e1 e2) = iConcat [ pprKExpr e1, iNewline,
+ iStr "rescue", iNewline,
+ pprKExpr e2 ]
+ pprKExpr (KEseq e1 e2) = iConcat [ pprKExpr e1, iStr "; ",
+ pprKExpr e2 ]
+ pprKExpr (KEextFunApp s ss) = iInterleave (iStr " ") $ map iStr (s:ss)
+
+ instance Show KExpr where
+ show = show . pprKExpr
+
View
5 TypeInference.hs
@@ -1,4 +1,7 @@
-module TypeInference where
+module TypeInference (
+ typeOfExpression,
+ emptyEnv
+) where
import Syntax
import Types

0 comments on commit 4f704f5

Please sign in to comment.