Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Merge branch 'feature/K-normalization' into develop

  • Loading branch information...
commit 4f704f5f451ff4289339035c9b96079b163beda5 2 parents 61ac1b0 + 2319adb
Krzysztof Sakwerda authored February 16, 2013
10  Compiler.hs
... ...
@@ -0,0 +1,10 @@
  1
+module Compiler (compile) where
  2
+  import KNormal
  3
+  import PatternMatching
  4
+  import Syntax
  5
+  import TypeInference
  6
+
  7
+  compile :: Expr -> Either String KExpr
  8
+  compile expr = case typeOfExpression emptyEnv expr of
  9
+    Left er -> Left er
  10
+    Right _ -> Right . convertToKNormal . compilePatternMatching $ expr
14  KNormal.hs
... ...
@@ -0,0 +1,14 @@
  1
+module KNormal (
  2
+  convertToKNormal,
  3
+  KExpr(..)
  4
+) where
  5
+  import KNormal.Counter
  6
+  import KNormal.KNormalize
  7
+  import KNormal.KSyntax
  8
+
  9
+  import Syntax
  10
+
  11
+  import Control.Monad.State
  12
+
  13
+  convertToKNormal :: Expr -> KExpr
  14
+  convertToKNormal e = fst $ runState (kNormalize e) emptyState
26  KNormal/Counter.hs
... ...
@@ -0,0 +1,26 @@
  1
+{-# LANGUAGE
  2
+  FlexibleContexts
  3
+  #-}
  4
+
  5
+module KNormal.Counter where
  6
+  import Control.Monad.State
  7
+
  8
+  data Counter = C {
  9
+    variable :: Integer,
  10
+    lambda   :: Integer
  11
+  }
  12
+
  13
+  emptyState :: Counter
  14
+  emptyState = C 0 0
  15
+
  16
+  freshVar :: MonadState Counter m => m String
  17
+  freshVar = do
  18
+    s <- get
  19
+    put s { variable = variable s + 1 }
  20
+    return $ '_':'K': show (variable s)
  21
+
  22
+  freshLambda :: MonadState Counter m => m String
  23
+  freshLambda = do
  24
+    s <- get
  25
+    put s { lambda = lambda s + 1 }
  26
+    return $ '_':'L': 'a' : 'm' : show (lambda s)
277  KNormal/KNormalize.hs
... ...
@@ -0,0 +1,277 @@
  1
+{-# LANGUAGE
  2
+  FlexibleContexts
  3
+  #-}
  4
+
  5
+module KNormal.KNormalize (kNormalize) where
  6
+  import KNormal.Counter
  7
+  import KNormal.KSyntax
  8
+
  9
+  import Syntax
  10
+
  11
+  import Control.Exception.Base
  12
+  import Control.Monad.State
  13
+
  14
+  import Utils.Errors
  15
+
  16
+  insertLet :: MonadState Counter m => KExpr -> (String -> m KExpr) -> m KExpr
  17
+  insertLet (KEvar x) k = k x
  18
+  insertLet e         k = do
  19
+    x  <- freshVar
  20
+    e' <- k x
  21
+    return $ KElet x e e'
  22
+
  23
+  kNormalizeConstant :: Constant -> KExpr
  24
+  kNormalizeConstant (Cint n)   = KEint n
  25
+  kNormalizeConstant (Cbool b)  = KEint $ if b then 1 else 0
  26
+  kNormalizeConstant Cnil       = KEnil
  27
+  kNormalizeConstant Cunit      = KEunit
  28
+
  29
+  mkFunDef :: MonadState Counter m => String -> FunClause -> m FunDef
  30
+  mkFunDef n fc = do
  31
+    let as = map (\(Pvar x) -> x) $ arguments fc
  32
+    b <- kNormalize $ fbody fc
  33
+    return FD{ name = n, body = b, args = as }
  34
+
  35
+  kNormalizeUPrim :: MonadState Counter m => UnaryPrim -> Expr -> m KExpr
  36
+  kNormalizeUPrim UPnot   e =
  37
+    kNormalize $ Eif e (Econst $ Cbool False) $ Econst $ Cbool True
  38
+  kNormalizeUPrim UPref   e = do
  39
+    e' <- kNormalize e
  40
+    insertLet e' (\x -> return $ KEextFunApp "create_ref" [x])
  41
+  kNormalizeUPrim UPderef e = do
  42
+    e' <- kNormalize e
  43
+    insertLet e' (return . KEload)
  44
+  kNormalizeUPrim UPminus e = do
  45
+    e' <- kNormalize e
  46
+    insertLet e' (return . KEneg)
  47
+
  48
+  kNormalizeOp :: MonadState Counter m =>
  49
+                  (String -> String -> KExpr) -> Expr -> Expr -> m KExpr
  50
+  kNormalizeOp op e1 e2 = do
  51
+    e1' <- kNormalize e1
  52
+    insertLet e1' (\x -> do {
  53
+      e2' <- kNormalize e2;
  54
+      insertLet e2' (return . op x)})
  55
+
  56
+  kNormalizeBPrim :: MonadState Counter m =>
  57
+                     BinaryPrim -> Expr -> Expr -> m KExpr
  58
+  kNormalizeBPrim BPeq     e1 e2  = do
  59
+    e1' <- kNormalize e1
  60
+    insertLet e1' (\x -> do {
  61
+      e2' <- kNormalize e2;
  62
+      insertLet e2' (\y -> return $ KEifEq x y (KEint 1) (KEint 0))})
  63
+  kNormalizeBPrim BPlt     e1 e2  = do
  64
+    e1' <- kNormalize e1
  65
+    insertLet e1' (\x -> do {
  66
+      e2' <- kNormalize e2;
  67
+      insertLet e2' (\y -> return $ KEifLE x y
  68
+        (KEifEq x y (KEint 0) (KEint 1)) (KEint 0))})
  69
+  kNormalizeBPrim BPgt     e1 e2  = do
  70
+    e1' <- kNormalize e1
  71
+    insertLet e1' (\x -> do {
  72
+      e2' <- kNormalize e2;
  73
+      insertLet e2' (\y -> return $ KEifLE x y (KEint 0) (KEint 1))})
  74
+  kNormalizeBPrim BPor     e1 e2  = do
  75
+    e1' <- kNormalize e1
  76
+    insertLet e1' (\x -> do {
  77
+      e2' <- kNormalize e2;
  78
+      v   <- freshVar;
  79
+      return $ KElet v (KEint 1) $ KEifEq x v (KEint 1) e2' })
  80
+  kNormalizeBPrim BPand    e1 e2  = do
  81
+    e1' <- kNormalize e1
  82
+    insertLet e1' (\x -> do {
  83
+      e2' <- kNormalize e2;
  84
+      v   <- freshVar;
  85
+      return $ KElet v (KEint 1) $ KEifEq x v e2' (KEint 0) })
  86
+  kNormalizeBPrim BPadd    e1 e2  =
  87
+    kNormalizeOp KEadd e1 e2
  88
+  kNormalizeBPrim BPsub    e1 e2  =
  89
+    kNormalizeOp KEsub e1 e2
  90
+  kNormalizeBPrim BPmult   e1 e2  =
  91
+    kNormalizeOp KEmult e1 e2
  92
+  kNormalizeBPrim BPdiv    e1 e2  =
  93
+    kNormalizeOp KEdiv e1 e2
  94
+  kNormalizeBPrim BPmod    e1 e2  =
  95
+    kNormalizeOp KEmod e1 e2
  96
+  kNormalizeBPrim BPassign e1 e2  =
  97
+    kNormalizeOp KEstore e1 e2
  98
+
  99
+  kNormalizeArgs :: MonadState Counter m =>
  100
+                    [Expr] -> m ([String], KExpr -> KExpr)
  101
+  kNormalizeArgs []     = return ([], id)
  102
+  kNormalizeArgs (a:as) = do
  103
+    (as', f) <- kNormalizeArgs as
  104
+    a'       <- kNormalize a
  105
+    case a' of
  106
+      KEvar x -> return (x:as', f)
  107
+      _       -> do
  108
+        v <- freshVar
  109
+        return (v:as', KElet v a' . f)
  110
+
  111
+
  112
+  kNormalizeCaseBool :: MonadState Counter m =>
  113
+                        String -> Expr -> Expr -> m KExpr
  114
+  kNormalizeCaseBool n et ef = do
  115
+    v   <- freshVar
  116
+    et' <- kNormalize et
  117
+    ef' <- kNormalize ef
  118
+    return $ KElet v (KEint 1) $ KEifEq n v et' ef'
  119
+
  120
+  genVars :: MonadState Counter m => String -> m (KExpr, String, String)
  121
+  genVars n = do
  122
+    let e' = KEextFunApp "tag_of" [n]
  123
+    v1  <- freshVar
  124
+    v2  <- freshVar
  125
+    return (e', v1, v2)
  126
+
  127
+  kNormalizeCaseList :: MonadState Counter m =>
  128
+                        String -> Expr -> String -> String -> Expr -> m KExpr
  129
+  kNormalizeCaseList n en x xs ec = do
  130
+    (e', v1, v2) <- genVars n
  131
+    v3  <- freshVar
  132
+    en' <- kNormalize en
  133
+    ec' <- kNormalize ec
  134
+    return $ KElet v1 e' $ KElet v2 (KEint 0) $ KElet v2 (KEint 1) $
  135
+             KEifEq v1 v2 en' $ KEifEq v1 v3 (KEletList x xs n ec') $
  136
+             KEerror matchFailure
  137
+
  138
+
  139
+
  140
+  kNormalizeCase :: MonadState Counter m =>
  141
+                    [CaseClause] -> String -> m KExpr
  142
+  -- pair
  143
+  kNormalizeCase [CC { constructor = CNpair,
  144
+                       variables   = [a, b],
  145
+                       cbody       = cb }]    n = do
  146
+    (e', v1, v2) <- genVars n
  147
+    cb' <- kNormalize cb
  148
+    return $ KElet v1 (KEint 0) $
  149
+             KElet v2 e' $ KEifEq v1 v2 (KEletPair a b n cb')
  150
+              (KEerror matchFailure)
  151
+  -- boolean
  152
+  kNormalizeCase [CC { constructor = CNtrue,
  153
+                       variables   = [],
  154
+                       cbody       = bt },
  155
+                  CC { constructor = CNfalse,
  156
+                       variables   = [],
  157
+                       cbody       = bf }]    n =
  158
+    kNormalizeCaseBool n bt bf
  159
+  kNormalizeCase [CC { constructor = CNfalse,
  160
+                       variables   = [],
  161
+                       cbody       = bf },
  162
+                  CC { constructor = CNtrue,
  163
+                       variables   = [],
  164
+                       cbody       = bt }]    n =
  165
+    kNormalizeCaseBool n bt bf
  166
+  -- list
  167
+  kNormalizeCase [CC { constructor = CNnil,
  168
+                       variables   = [],
  169
+                       cbody       = bn },
  170
+                  CC { constructor = CNcons,
  171
+                       variables   = [x, xs],
  172
+                       cbody       = bc }]    n =
  173
+    kNormalizeCaseList n bn x xs bc
  174
+  kNormalizeCase [CC { constructor = CNcons,
  175
+                       variables   = [x, xs],
  176
+                       cbody       = bc },
  177
+                  CC { constructor = CNnil,
  178
+                       variables   = [],
  179
+                       cbody       = bn }]    n =
  180
+    kNormalizeCaseList n bn x xs bc
  181
+  -- unit
  182
+  kNormalizeCase [CC { constructor = CNunit,
  183
+                       variables   = [],
  184
+                       cbody       = b }]     n = do
  185
+    (e', v1, v2) <- genVars n
  186
+    b' <- kNormalize b
  187
+    return $ KElet v1 (KEint 0) $
  188
+             KElet v2 e' $ KEifEq v1 v2 b'
  189
+              (KEerror matchFailure)
  190
+  kNormalizeCase ccs n = assert False $ kNormalizeCase ccs n
  191
+
  192
+
  193
+  kNormalize :: MonadState Counter m => Expr -> m KExpr
  194
+  kNormalize (Econst c)                               =
  195
+    return $ kNormalizeConstant c
  196
+  kNormalize (Evar s)                                 =
  197
+    -- Here should be checking for external references
  198
+    -- when modules are implemented
  199
+    return $ KEvar s
  200
+  kNormalize (Elet (Pvar s)            (Efun fcs) e2)     = do
  201
+    fd  <- mkFunDef s $ head fcs
  202
+    e2' <- kNormalize e2
  203
+    return $ KEletRec fd e2'
  204
+  kNormalize (Elet (Pvar s)                    e1 e2)     = do
  205
+    e1' <- kNormalize e1
  206
+    e2' <- kNormalize e2
  207
+    return $ KElet s e1' e2'
  208
+  kNormalize (Elet (Ppair (Pvar p1) (Pvar p2)) e1 e2)     = do
  209
+    e1' <- kNormalize e1
  210
+    insertLet e1' (\x -> do {
  211
+      e2' <- kNormalize e2;
  212
+      return $ KEletPair p1 p2 x e2' })
  213
+  kNormalize (Elet (Pcons (Pvar p1) (Pvar p2)) e1 e2)     = do
  214
+    e1' <- kNormalize e1
  215
+    insertLet e1' (\x -> do {
  216
+      e2' <- kNormalize e2;
  217
+      return $ KEletList p1 p2 x e2' })
  218
+  kNormalize (Eletrec s fcs e)                            = do
  219
+    fd <- mkFunDef s $ head fcs
  220
+    e' <- kNormalize e
  221
+    return $ KEletRec fd e'
  222
+  kNormalize (Eapply (Euprim up) [e])                     =
  223
+    kNormalizeUPrim up e
  224
+  kNormalize (Eapply (Ebprim bp) [e1, e2])                =
  225
+    kNormalizeBPrim bp e1 e2
  226
+  kNormalize (Eapply (Efun fcs)  as)                      = do
  227
+    l         <- freshLambda
  228
+    fd        <- mkFunDef l $ head fcs
  229
+    (as', lt) <- kNormalizeArgs as
  230
+    return $ KEletRec fd $ lt $ KEapply l as'
  231
+  kNormalize (Eapply (Evar x)    as)                      = do
  232
+    (as', lt) <- kNormalizeArgs as
  233
+    return $ lt $ KEapply x as'
  234
+  kNormalize (Epair e1 e2)                                =
  235
+    kNormalizeOp KEpair e1 e2
  236
+  kNormalize (Econs e1 e2)                                =
  237
+    kNormalizeOp KEcons e1 e2
  238
+  kNormalize (Eif (Eapply (Euprim UPnot) [c1]) e2 e3)     =
  239
+    kNormalize (Eif c1 e3 e2)
  240
+  kNormalize (Eif (Eapply (Ebprim BPeq) [c1, c2]) e2 e3)  = do
  241
+    c1' <- kNormalize c1
  242
+    insertLet c1' (\x -> do {
  243
+      c2' <- kNormalize c2;
  244
+      insertLet c2' (\y -> do {
  245
+        e2' <- kNormalize e2;
  246
+        e3' <- kNormalize e3;
  247
+        return $ KEifEq x y e2' e3'})})
  248
+  kNormalize (Eif (Eapply (Ebprim BPgt) [c1, c2]) e2 e3)  = do
  249
+    c1' <- kNormalize c1
  250
+    insertLet c1' (\x -> do {
  251
+      c2' <- kNormalize c2;
  252
+      insertLet c2' (\y -> do {
  253
+        e2' <- kNormalize e2;
  254
+        e3' <- kNormalize e3;
  255
+        return $ KEifLE x y e3' e2'})})
  256
+  kNormalize (Eif e1 e2 e3)                               = do
  257
+    e1' <- kNormalize e1
  258
+    insertLet e1' (\x -> do {
  259
+      y   <- freshVar;
  260
+      e2' <- kNormalize e2;
  261
+      e3' <- kNormalize e3;
  262
+      return $ KElet y (KEint 1) $ KEifEq x y e2' e3' })
  263
+  kNormalize (Eseq e1 e2)                                 = do
  264
+    e1' <- kNormalize e1
  265
+    e2' <- kNormalize e2
  266
+    return $ KEseq e1' e2'
  267
+  kNormalize (Ecase e ccs)                                = do
  268
+    e' <- kNormalize e
  269
+    insertLet e' (kNormalizeCase ccs)
  270
+  kNormalize (Ehandle e1 e2)                              = do
  271
+    e1' <- kNormalize e1
  272
+    e2' <- kNormalize e2
  273
+    return $ KEhandle e1' e2'
  274
+  kNormalize EmatchFailure                                =
  275
+    return $ KEerror matchFailure
  276
+  kNormalize e                  =
  277
+    assert False (kNormalize e)
110  KNormal/KSyntax.hs
... ...
@@ -0,0 +1,110 @@
  1
+module KNormal.KSyntax where
  2
+  import Utils.Iseq
  3
+
  4
+  data FunDef = FD {
  5
+    name :: String,
  6
+    args :: [String],
  7
+    body :: KExpr
  8
+  } deriving Eq
  9
+
  10
+  pprFunDef :: FunDef -> Iseq
  11
+  pprFunDef fd = iConcat [ iInterleave (iStr " ")
  12
+                            (map iStr $ name fd : args fd),
  13
+                          iStr " = ", pprKExpr (body fd) ]
  14
+
  15
+  instance Show FunDef where
  16
+    show = show . pprFunDef
  17
+
  18
+  data KExpr =
  19
+    -- constants
  20
+      KEunit
  21
+    | KEnil
  22
+    | KEint Integer
  23
+    -- unary ptimitives
  24
+    | KEneg String                              -- Bit negation
  25
+    | KEload String                             -- Dereference
  26
+    -- binary primitives
  27
+    | KEadd String String
  28
+    | KEsub String String
  29
+    | KEmult String String
  30
+    | KEdiv String String
  31
+    | KEmod String String
  32
+    | KEstore String String                     -- Assignment
  33
+    --
  34
+    | KEvar String
  35
+    | KEerror String
  36
+    | KEifEq String String KExpr KExpr
  37
+    | KEifLE String String KExpr KExpr
  38
+    | KElet String KExpr KExpr                  -- Functions are not allowed
  39
+    | KEletRec FunDef KExpr                     -- Annonymous functions will be named
  40
+    | KEapply String [String]
  41
+    | KEpair String String
  42
+    | KEcons String String
  43
+    | KEletPair String String String KExpr      -- Read from pair
  44
+    | KEletList String String String KExpr      -- Read from list
  45
+    | KEhandle KExpr KExpr
  46
+    | KEseq KExpr KExpr
  47
+    | KEextFunApp String [String]               -- External function application
  48
+    deriving Eq                                 --   Known external functions:
  49
+                                                --    - reference maker
  50
+                                                --    - tag getter
  51
+
  52
+  pprKExpr :: KExpr -> Iseq
  53
+  pprKExpr KEunit                   = iStr "()"
  54
+  pprKExpr KEnil                    = iStr "[]"
  55
+  pprKExpr (KEint n)                = iStr . show $ n
  56
+  pprKExpr (KEneg s)                = iStr "-" `iAppend` iStr s
  57
+  pprKExpr (KEload s)               = iStr "&" `iAppend` iStr s
  58
+  pprKExpr (KEadd s1 s2)            = iConcat [ iStr s1, iStr " + ", iStr s2 ]
  59
+  pprKExpr (KEsub s1 s2)            = iConcat [ iStr s1, iStr " - ", iStr s2 ]
  60
+  pprKExpr (KEmult s1 s2)           = iConcat [ iStr s1, iStr " * ", iStr s2 ]
  61
+  pprKExpr (KEdiv s1 s2)            = iConcat [ iStr s1, iStr " / ", iStr s2 ]
  62
+  pprKExpr (KEmod s1 s2)            = iConcat [ iStr s1, iStr " % ", iStr s2 ]
  63
+  pprKExpr (KEstore s1 s2)          = iConcat [ iStr s1, iStr " := ", iStr s2 ]
  64
+  pprKExpr (KEvar s)                = iStr s
  65
+  pprKExpr (KEerror s)              = iStr s
  66
+  pprKExpr (KEifEq s1 s2 e1 e2)     = iConcat [ iStr "if ", iStr s1,
  67
+                                                iStr " == ", iStr s2, iStr "{",
  68
+                                                iNewline, indentation,
  69
+                                                iIndent $ pprKExpr e1,
  70
+                                                iStr " } else { ",
  71
+                                                iNewline, indentation,
  72
+                                                iIndent $ pprKExpr e2,
  73
+                                                iNewline, iStr "}" ]
  74
+  pprKExpr (KEifLE s1 s2 e1 e2)     = iConcat [ iStr "if ", iStr s1,
  75
+                                                iStr " <= ", iStr s2, iStr "{",
  76
+                                                iNewline, indentation,
  77
+                                                iIndent $ pprKExpr e1,
  78
+                                                iStr " } else { ",
  79
+                                                iNewline, indentation,
  80
+                                                iIndent $ pprKExpr e2,
  81
+                                                iNewline, iStr "}" ]
  82
+  pprKExpr (KElet s e1 e2)          = iConcat [ iStr "let ", iStr s,
  83
+                                                iStr " = ", pprKExpr e1,
  84
+                                                iNewline, iStr "in ",
  85
+                                                pprKExpr e2 ]
  86
+  pprKExpr (KEletRec fd e)          = iConcat [ iStr "letrec ", pprFunDef fd,
  87
+                                                iNewline, iStr "in ",
  88
+                                                pprKExpr e ]
  89
+  pprKExpr (KEapply s ss)           = iInterleave (iStr " ") $ map iStr (s:ss)
  90
+  pprKExpr (KEpair s1 s2)           = iConcat [ iStr "(", iStr s1, iStr ", ",
  91
+                                                iStr s2, iStr ")" ]
  92
+  pprKExpr (KEcons s1 s2)           = iConcat [ iStr s1, iStr "::", iStr s2 ]
  93
+  pprKExpr (KEletPair s1 s2 s3 e)   = iConcat [ iStr "let (", iStr s1,
  94
+                                                iStr ", ", iStr s2, iStr ") = ",
  95
+                                                iStr s3, iNewline, iStr "in ",
  96
+                                                pprKExpr e ]
  97
+  pprKExpr (KEletList s1 s2 s3 e)   = iConcat [ iStr "let ", iStr s1,
  98
+                                                iStr "::", iStr s2, iStr " = ",
  99
+                                                iStr s3, iNewline, iStr "in ",
  100
+                                                pprKExpr e ]
  101
+  pprKExpr (KEhandle e1 e2)         = iConcat [ pprKExpr e1, iNewline,
  102
+                                                iStr "rescue", iNewline,
  103
+                                                pprKExpr e2 ]
  104
+  pprKExpr (KEseq e1 e2)            = iConcat [ pprKExpr e1, iStr "; ",
  105
+                                                pprKExpr e2 ]
  106
+  pprKExpr (KEextFunApp s ss)       = iInterleave (iStr " ") $ map iStr (s:ss)
  107
+
  108
+  instance Show KExpr where
  109
+    show = show . pprKExpr
  110
+
5  TypeInference.hs
... ...
@@ -1,4 +1,7 @@
1  
-module TypeInference where
  1
+module TypeInference (
  2
+  typeOfExpression,
  3
+  emptyEnv
  4
+) where
2 5
   import Syntax
3 6
   import Types
4 7
 

0 notes on commit 4f704f5

Please sign in to comment.
Something went wrong with that request. Please try again.