Merge pull request #5 from bachelor-group-66-systemf/codegen-martin-3

Codegen martin 3

.gitignore

@@ -3,3 +3,4 @@ dist-newstyle
 *.x
 *.bak
 src/Grammar
+/language

Grammar.cf

@@ -3,21 +3,21 @@ Program. Program ::= [Def] ;
 DExp.  Def ::= Ident ":" Type
                Ident [Ident] "=" Exp ;
 
-separator Def "";
+Program. Program ::= [Bind];
-separator Ident "";
-separator Type "->";
 
-EId.  Exp3 ::= Ident   ;
+EId.  Exp3 ::= Ident;
-EInt. Exp3 ::= Integer ;
+EInt. Exp3 ::= Integer;
-EApp. Exp2 ::= Exp2 Exp3 ;
+ELet. Exp3 ::= "let" [Bind] "in" Exp; 
-EAdd. Exp1 ::= Exp1 "+" Exp2 ;
+EApp. Exp2 ::= Exp2 Exp3;
-EAbs. Exp  ::= "\\" Ident ":" Type "." Exp ;
+EAdd. Exp1 ::= Exp1 "+" Exp2;
-coercions Exp 3 ;
+EAbs. Exp  ::= "\\" Ident "." Exp;
 
-TInt. Type1 ::= "Int" ;
+Bind. Bind ::= Ident [Ident] "=" Exp;
-TPol. Type1 ::= Ident ;
+separator Bind ";";
-TFun. Type  ::= [Type] ;
+separator Ident " ";
-coercions Type 1 ;
+
+coercions Exp 3;
+
+comment "--";
+comment "{-" "-}";
 
-comment "--" ;
-comment "{-" "-}" ;

Makefile

@@ -22,4 +22,11 @@ clean :
 	rm -r src/Grammar
 	rm language
 
+test :
+	./language ./sample-programs/basic-1
+	./language ./sample-programs/basic-2
+	./language ./sample-programs/basic-3
+	./language ./sample-programs/basic-4
+	./language ./sample-programs/basic-5
+
 # EOF

language.cabal

@@ -12,7 +12,7 @@ build-type:         Simple
 
 extra-doc-files:    CHANGELOG.md
 
-extra-source-fiels:
+extra-source-files:
   Grammar.cf
 
 
@@ -30,18 +30,18 @@ executable language
       Grammar.Par
       Grammar.Print
       Grammar.Skel
-      Grammar.ErrM
+      LambdaLifter
-      Interpreter
+      Auxiliary
-      TypeChecker
+      -- Interpreter
-      NewAbs
 
     hs-source-dirs:   src
 
     build-depends:    
-        base >= 4.16.3.0
+        base >=4.16
       , mtl
       , containers
       , either
       , array
+      , extra
 
     default-language: GHC2021

sample-programs/basic-1

@@ -0,0 +1,2 @@
+
+f = \x. x+1;

sample-programs/basic-2

@@ -0,0 +1,4 @@
+add x = \y. x+y;
+
+main = (\z. z+z) ((add 4) 6);
+

sample-programs/basic-3

@@ -0,0 +1,2 @@
+
+main = (\x. x+x+3) ((\x. x) 2)

sample-programs/basic-4

@@ -0,0 +1,2 @@
+
+f x = let g = (\y. y+1) in g (g x)

sample-programs/basic-5

@@ -0,0 +1,9 @@
+id x = x;
+
+add x y = x + y;
+
+double n = n + n;
+
+apply f x = \y. f x y;
+
+main = apply (id add) ((\x. x + 1) 1) (double 3);

shell.nix

@@ -6,7 +6,7 @@ pkgs.haskellPackages.developPackage {
   withHoogle = true;
   modifier = drv:
   pkgs.haskell.lib.addBuildTools drv (
-    (with pkgs; [ hlint haskell-language-server ghc jasmin ])
+    (with pkgs; [ hlint haskell-language-server ghc jasmin llvmPackages_15.libllvm])
     ++
     (with pkgs.haskellPackages; [ 
       cabal-install

src/Auxiliary.hs

@@ -0,0 +1,5 @@
+
+module Auxiliary (module Auxiliary) where
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]

src/Interpreter.hs

@@ -7,4 +7,68 @@ import           Control.Monad.Except    (Except, MonadError (throwError))
 import           Grammar.Abs
 
 interpret :: Program -> Except String Integer
-interpret (Program _) = throwError "Can not interpret program yet"
+interpret (Program e) =
+  eval mempty e >>= \case
+    VClosure {} -> throwError "main evaluated to a function"
+    VInt i      -> pure i
+
+
+data Val = VInt Integer
+         | VClosure Cxt Ident Exp
+
+type Cxt = Map Ident Val
+
+eval :: Cxt -> Exp -> Except String Val
+eval cxt = \case
+
+
+  --  ------------ x ∈ γ
+  --  γ ⊢ x ⇓ γ(x)
+
+  EId x     ->
+    maybeToRightM
+      ("Unbound variable:" ++ printTree x)
+      $ Map.lookup x cxt
+
+  --  ---------
+  --  γ ⊢ i ⇓ i
+
+  EInt i    -> pure $ VInt i
+
+  --  γ     ⊢ e  ⇓ let δ in λx. f
+  --  γ     ⊢ e₁ ⇓ v
+  --  δ,x=v ⊢ f  ⇓ v₁
+  --  ------------------------------
+  --  γ ⊢ e e₁ ⇓ v₁
+
+  EApp e e1 ->
+    eval cxt e >>= \case
+      VInt _ -> throwError "Not a function"
+      VClosure delta x f -> do
+        v <- eval cxt e1
+        eval (Map.insert x v delta) f
+
+  --
+  --  -----------------------------
+  --  γ ⊢ λx. f ⇓ let γ in λx. f
+
+  EAbs x e  -> pure $ VClosure cxt x e
+
+
+  --  γ ⊢ e  ⇓ v
+  --  γ ⊢ e₁ ⇓ v₁
+  --  ------------------
+  --  γ ⊢ e e₁ ⇓ v + v₁
+
+  EAdd e e1 -> do
+    v <- eval cxt e
+    v1 <- eval cxt e1
+    case (v, v1) of
+      (VInt i, VInt i1) -> pure $ VInt (i + i1)
+      _                 -> throwError "Can't add a function"
+
+
+
+maybeToRightM :: MonadError l m => l -> Maybe r -> m r
+maybeToRightM err = liftEither . maybeToRight err
+

src/LambdaLifter.hs

@@ -0,0 +1,221 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
+
+import           Data.List        (mapAccumL)
+import           Data.Map         (Map)
+import qualified Data.Map         as Map
+import           Data.Maybe       (fromMaybe)
+import           Data.Set         (Set, (\\))
+import qualified Data.Set         as Set
+import           Data.Tuple.Extra (uncurry3)
+import           Grammar.Abs
+import           Prelude          hiding (exp)
+
+
+
+-- | Lift lambdas and let expression into supercombinators.
+lambdaLift :: Program -> Program
+lambdaLift = collectScs . rename . abstract . freeVars
+
+
+-- | Annotate free variables
+freeVars :: Program -> AnnProgram
+freeVars (Program ds) = [ (n, xs, freeVarsExp (Set.fromList xs) e)
+                        | Bind n xs e <- ds
+                        ]
+
+freeVarsExp :: Set Ident -> Exp -> AnnExp
+freeVarsExp lv = \case
+
+  EId n | Set.member n lv -> (Set.singleton n, AId n)
+        | otherwise       -> (mempty, AId n)
+
+  EInt i     -> (mempty, AInt i)
+
+  EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AApp e1' e2')
+    where e1' = freeVarsExp lv e1
+          e2' = freeVarsExp lv e2
+
+  EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2')
+    where e1' = freeVarsExp lv e1
+          e2' = freeVarsExp lv e2
+
+  EAbs n  e  -> (Set.delete n $ freeVarsOf e', AAbs n e')
+    where e'  = freeVarsExp (Set.insert n lv) e
+
+  ELet bs e  -> (Set.union bsFree eFree, ALet bs' e')
+    where
+      bsFree       = freeInValues \\ nsSet
+      eFree        = freeVarsOf e' \\ nsSet
+      bs'          = zipWith3 ABind ns xs es'
+      e'           = freeVarsExp e_lv e
+      (ns, xs, es) = fromBinders bs
+      nsSet        = Set.fromList ns
+      e_lv         = Set.union lv nsSet
+      es'          = map (freeVarsExp e_lv) es
+      freeInValues = foldr1 Set.union (map freeVarsOf es')
+
+
+freeVarsOf :: AnnExp -> Set Ident
+freeVarsOf = fst
+
+fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp])
+fromBinders bs = unzip3 [ (n, xs, e) | Bind n xs e <- bs ]
+
+-- AST annotated with free variables
+type AnnProgram = [(Ident, [Ident], AnnExp)]
+
+type AnnExp = (Set Ident, AnnExp')
+
+data ABind = ABind Ident [Ident] AnnExp deriving Show
+
+data AnnExp' = AId Ident
+             | AInt Integer
+             | AApp AnnExp  AnnExp
+             | AAdd AnnExp  AnnExp
+             | AAbs Ident   AnnExp
+             | ALet [ABind] AnnExp
+             deriving Show
+
+-- | Lift lambdas to let expression of the form @let sc = \x -> rhs@
+abstract :: AnnProgram -> Program
+abstract prog = Program $ map f prog
+  where
+  f :: (Ident, [Ident], AnnExp) -> Bind
+  f (name, pars, rhs@(_, e)) =
+    case e of
+      AAbs par body -> Bind name (snoc par pars) $ abstractExp body
+      _             -> Bind name pars            $ abstractExp rhs
+
+abstractExp :: AnnExp -> Exp
+abstractExp (free, exp) = case exp of
+  AId  n     -> EId n
+  AInt i     -> EInt i
+  AApp e1 e2 -> EApp (abstractExp e1) (abstractExp e2)
+  AAdd e1 e2 -> EAdd (abstractExp e1) (abstractExp e2)
+  ALet bs e  -> ELet [Bind n xs (abstractExp e1) | ABind n xs e1 <- bs ] $ abstractExp e
+  AAbs n  e  -> foldl EApp sc (map EId fvList)
+    where
+      fvList = Set.toList free
+      bind = Bind "sc" [] e'
+      e' = foldr EAbs (abstractExp e) (fvList ++ [n])
+      sc = ELet [bind] (EId (Ident "sc"))
+
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]
+
+-- | Rename all supercombinators and variables
+rename :: Program -> Program
+rename (Program ds) = Program $ map (uncurry3 Bind) tuples
+  where
+    tuples = snd (mapAccumL renameSc 0 ds)
+    renameSc i (Bind n xs e) = (i2, (n, xs', e'))
+      where
+        (i1, xs', env) = newNames i xs
+        (i2, e')       = renameExp env i1 e
+
+renameExp :: Map Ident Ident -> Int -> Exp -> (Int, Exp)
+renameExp env i = \case
+
+  EId  n     -> (i, EId . fromMaybe n $ Map.lookup n env)
+
+  EInt i1    -> (i, EInt i1)
+
+  EApp e1 e2 -> (i2, EApp e1' e2')
+    where
+      (i1, e1') = renameExp env i e1
+      (i2, e2') = renameExp env i1 e2
+
+  EAdd e1 e2 -> (i2, EAdd e1' e2')
+    where
+      (i1, e1') = renameExp env i e1
+      (i2, e2') = renameExp env i1 e2
+
+  ELet bs e  -> (i3, ELet (zipWith3 Bind ns' xs es') e')
+    where
+      (i1, e')        = renameExp e_env i e
+      (ns, xs, es)    = fromBinders bs
+      (i2, ns', env') = newNames i1 ns
+      e_env           = Map.union env' env
+      (i3, es')       = mapAccumL (renameExp e_env) i2 es
+
+
+  EAbs n  e  -> (i2, EAbs (head ns) e')
+    where
+      (i1, ns, env') = newNames i [n]
+      (i2, e')       = renameExp (Map.union env' env ) i1 e
+
+
+newNames :: Int -> [Ident] -> (Int, [Ident], Map Ident Ident)
+newNames i old_names = (i', new_names, env)
+  where
+    (i', new_names) = getNames i old_names
+    env = Map.fromList $ zip old_names new_names
+
+
+getName :: Int -> Ident -> (Int, Ident)
+getName i (Ident s) = (i + 1, makeName s i)
+
+getNames :: Int -> [Ident] -> (Int, [Ident])
+getNames i ns = (i + length ss, zipWith makeName ss [i..])
+  where
+    ss = map (\(Ident s) -> s) ns
+
+makeName :: String -> Int -> Ident
+makeName prefix i = Ident (prefix ++ "_" ++ show i)
+
+
+-- | Collects supercombinators by lifting appropriate let expressions
+collectScs :: Program -> Program
+collectScs (Program ds) = Program $ concatMap collectOneSc ds
+  where
+    collectOneSc (Bind name args rhs) = Bind name args rhs' : scs
+      where (scs, rhs') = collectScsExp rhs
+
+collectScsExp :: Exp -> ([Bind], Exp)
+collectScsExp = \case
+
+  EId  n     -> ([], EId n)
+
+  EInt i     -> ([], EInt i)
+
+  EApp e1 e2 -> (scs1 ++ scs2, EApp e1' e2')
+    where
+      (scs1, e1') = collectScsExp e1
+      (scs2, e2') = collectScsExp e2
+
+  EAdd e1 e2 -> (scs1 ++ scs2, EAdd e1' e2')
+    where
+      (scs1, e1') = collectScsExp e1
+      (scs2, e2') = collectScsExp e2
+
+  EAbs x  e  -> (scs, EAbs x e')
+    where
+      (scs, e') = collectScsExp e
+
+  ELet bs e  -> (rhss_scs ++ e_scs ++ local_scs, mkEAbs non_scs' e')
+    where
+      (rhss_scs, bs') = mapAccumL collectScs_d [] bs
+      scs'            = [ Bind n xs rhs | Bind n xs rhs <- bs', isEAbs rhs]
+      non_scs'        = [ Bind n xs rhs | Bind n xs rhs <- bs', not $ isEAbs rhs]
+      local_scs       = [ Bind n (xs ++ [x]) e1 | Bind n xs (EAbs x e1) <- scs']
+      (e_scs, e')     = collectScsExp e
+
+      collectScs_d scs (Bind n xs rhs) = (scs ++ rhs_scs1, Bind n xs rhs')
+        where
+          (rhs_scs1, rhs') = collectScsExp rhs
+
+isEAbs :: Exp -> Bool
+isEAbs = \case
+  EAbs {} -> True
+  _       -> False
+
+mkEAbs :: [Bind] -> Exp -> Exp
+mkEAbs [] e = e
+mkEAbs bs e = ELet bs e
+
+

src/Main.hs

@@ -1,10 +1,9 @@
 {-# LANGUAGE LambdaCase #-}
 module Main where
 
-import           Control.Monad.Except (runExcept)
 import           Grammar.Par        (myLexer, pProgram)
-import           Interpreter          (interpret)
+import           Grammar.Print      (printTree)
-import           TypeChecker          (typecheck)
+import           LambdaLifter       (abstract, freeVars, lambdaLift, rename)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
 
@@ -18,18 +17,16 @@ main = getArgs >>= \case
        putStrLn "SYNTAX ERROR"
        putStrLn err
        exitFailure
-       Right p -> case typecheck p of
+      Right prg -> do
-          Left err -> do
+        putStrLn "-- Parse"
-              putStrLn "TYPECHECKING ERROR"
+        putStrLn $ printTree prg
-              putStrLn err
+        -- putStrLn "\n-- Abstract"
-              exitFailure
+        -- putStrLn . printTree $ (abstract . freeVars) prg
-          Right prg -> case runExcept $ interpret prg of
+        -- putStrLn "\n-- Rename"
-                Left err -> do
+        -- putStrLn . printTree $ (rename . abstract . freeVars) prg
-                  putStrLn "INTERPRETER ERROR"
+        putStrLn "\n-- Lamda lifter"
-                  putStrLn err
+        putStrLn . printTree $ lambdaLift prg
-                  exitFailure
+        putStrLn ""
-                Right i -> do
-                  print i
         exitSuccess