Merge pull request #6 from bachelor-group-66-systemf/codegen-martin-4

Add lambda lifter

Grammar.cf

@@ -1,15 +1,20 @@
 
 
-Program. Program ::= "main" "=" Exp ;
+Program. Program ::= [Bind];
 
-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 "->" Exp ;
+EAdd. Exp1 ::= Exp1 "+" Exp2;
+EAbs. Exp  ::= "\\" Ident "." Exp;
 
-coercions Exp 3 ;
+Bind. Bind ::= Ident [Ident] "=" Exp;
+separator Bind ";";
+separator Ident " ";
 
-comment "--" ;
+coercions Exp 3;
-comment "{-" "-}" ;
+
+comment "--";
+comment "{-" "-}";
 

Makefile

@@ -22,4 +22,16 @@ 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
+	./language ./sample-programs/basic-5
+	./language ./sample-programs/basic-6
+	./language ./sample-programs/basic-7
+	./language ./sample-programs/basic-8
+	./language ./sample-programs/basic-9
+
 # EOF

language.cabal

@@ -30,6 +30,9 @@ executable language
       Grammar.Par
       Grammar.Print
       Grammar.Skel
+      Grammar.ErrM
+      LambdaLifter
+      Auxiliary
       Interpreter
 
     hs-source-dirs:   src
@@ -40,5 +43,6 @@ executable language
       , 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);

sample-programs/basic-6

@@ -0,0 +1,3 @@
+
+
+f = \x.\y. x+y

sample-programs/basic-7

@@ -0,0 +1,5 @@
+add x y = x + y;
+
+apply f x = f x;
+
+main = apply (add 4) 6;

sample-programs/basic-8

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

sample-programs/basic-9

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

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,11 @@
+
+module Auxiliary (module Auxiliary) where
+import           Control.Monad.Error.Class (liftEither)
+import           Control.Monad.Except      (MonadError)
+import           Data.Either.Combinators   (maybeToRight)
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]
+
+maybeToRightM :: MonadError l m => l -> Maybe r -> m r
+maybeToRightM err = liftEither . maybeToRight err

src/Interpreter.hs

@@ -1,45 +1,79 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE OverloadedStrings   #-}
 module Interpreter where
 
+import           Auxiliary               (maybeToRightM)
 import           Control.Applicative     (Applicative)
 import           Control.Monad.Except    (Except, MonadError (throwError),
                                           liftEither)
+import           Control.Monad.State     (MonadState, StateT, evalStateT)
 import           Data.Either.Combinators (maybeToRight)
 import           Data.Map                (Map)
 import qualified Data.Map                as Map
+import           Data.Maybe              (maybe)
 import           Grammar.Abs
+import           Grammar.ErrM            (Err)
 import           Grammar.Print           (printTree)
 
-interpret :: Program -> Except String Integer
+interpret :: Program -> Err Integer
-interpret (Program e) =
+interpret (Program scs) = do
-  eval mempty e >>= \case
+  main <- findMain scs
-    VClosure {} -> throwError "main evaluated to a function"
+  eval (initCxt scs) main >>=
-    VInt i      -> pure i
+    \case
+      VClosure {} -> throwError "main evaluated to a function"
+      VInt i      -> pure i
 
 
+initCxt :: [Bind] -> Cxt
+initCxt scs =
+  Cxt { env = mempty
+      , sig = foldr insert mempty $ map expandLambdas scs
+      }
+  where insert (Bind name _ rhs) = Map.insert name rhs
+
+expandLambdas :: Bind -> Bind
+expandLambdas (Bind name parms rhs) = Bind name [] $ foldr EAbs rhs parms
+
+
+findMain :: [Bind] -> Err Exp
+findMain []       = throwError "No main!"
+findMain (sc:scs) = case sc of
+                      Bind "main" _ rhs -> pure rhs
+                      _                 -> findMain scs
+
 data Val = VInt Integer
-         | VClosure Cxt Ident Exp
+         | VClosure Env Ident Exp
+           deriving (Show, Eq)
 
-type Cxt = Map Ident Val
+type Env = Map Ident Val
+type Sig = Map Ident Exp
 
-eval :: Cxt -> Exp -> Except String Val
+data Cxt = Cxt
+  { env :: Map Ident Val
+  , sig :: Map Ident Exp
+  } deriving (Show, Eq)
+
+eval :: Cxt -> Exp -> Err Val
 eval cxt = \case
 
-
   --  ------------ x ∈ γ
   --  γ ⊢ x ⇓ γ(x)
 
-  EId x     ->
+  EId x     -> do
-    maybeToRightM
+    case Map.lookup x cxt.env of
-      ("Unbound variable:" ++ printTree x)
+      Just e -> pure e
-      $ Map.lookup x cxt
+      Nothing ->
+        case Map.lookup x cxt.sig of
+          Just e  -> eval (emptyEnv cxt) e
+          Nothing -> throwError ("Unbound variable: " ++ printTree x)
 
   --  ---------
   --  γ ⊢ i ⇓ i
 
   EInt i    -> pure $ VInt i
 
-  --  γ     ⊢ e  ⇓ let δ in λx → f
+  --  γ     ⊢ e  ⇓ let δ in λx. f
   --  γ     ⊢ e₁ ⇓ v
   --  δ,x=v ⊢ f  ⇓ v₁
   --  ------------------------------
@@ -50,13 +84,15 @@ eval cxt = \case
       VInt _ -> throwError "Not a function"
       VClosure delta x f -> do
         v <- eval cxt e1
-        eval (Map.insert x v delta) f
+        let cxt' = putEnv (Map.insert x v delta) cxt
+        eval cxt' f
+
 
   --
   --  -----------------------------
-  --  γ ⊢ λx → f ⇓ let γ in λx → f
+  --  γ ⊢ λx. f ⇓ let γ in λx. f
 
-  EAbs x e  -> pure $ VClosure cxt x e
+  EAbs par e  -> pure $ VClosure cxt.env par e
 
 
   --  γ ⊢ e  ⇓ v
@@ -71,8 +107,11 @@ eval cxt = \case
       (VInt i, VInt i1) -> pure $ VInt (i + i1)
       _                 -> throwError "Can't add a function"
 
+  ELet _ _ -> throwError "ELet pattern match should never occur!"
 
 
-maybeToRightM :: MonadError l m => l -> Maybe r -> m r
+emptyEnv :: Cxt -> Cxt
-maybeToRightM err = liftEither . maybeToRight err
+emptyEnv cxt = cxt { env = mempty }
 
+putEnv :: Env -> Cxt -> Cxt
+putEnv env cxt = cxt { env = env }

src/LambdaLifter.hs

@@ -0,0 +1,269 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
+
+import           Auxiliary           (snoc)
+import           Data.Foldable.Extra (notNull)
+import           Data.List           (mapAccumL, mapAccumR, partition)
+import           Data.Map            (Map)
+import qualified Data.Map            as Map
+import           Data.Maybe          (fromMaybe, mapMaybe)
+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 localVars = \case
+
+  EId n | Set.member n localVars -> (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 localVars e1
+      e2' = freeVarsExp localVars e2
+
+  EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), AAdd e1' e2')
+    where
+      e1' = freeVarsExp localVars e1
+      e2' = freeVarsExp localVars e2
+
+  EAbs par e -> (Set.delete par $ freeVarsOf e', AAbs par e')
+    where
+      e' = freeVarsExp (Set.insert par localVars) e
+
+  -- Sum free variables present in binders and the expression
+  ELet binders e  -> (Set.union binders_frees e_free, ALet binders' e')
+    where
+      binders_frees = rhss_frees \\ names_set
+      e_free        = freeVarsOf e' \\ names_set
+
+      rhss_frees = foldr1 Set.union (map freeVarsOf rhss')
+      names_set  = Set.fromList names
+
+      (names, parms, rhss) = fromBinders binders
+      rhss'                = map (freeVarsExp e_localVars) rhss
+      e_localVars          = Set.union localVars names_set
+
+      binders' = zipWith3 ABind names parms rhss'
+      e'       = freeVarsExp e_localVars e
+
+
+freeVarsOf :: AnnExp -> Set Ident
+freeVarsOf = fst
+
+fromBinders :: [Bind] -> ([Ident], [[Ident]], [Exp])
+fromBinders bs = unzip3 [ (name, parms, rhs) | Bind name parms rhs <- 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 = \v₁ x₁ -> e₁@.
+-- Free variables are @v₁ v₂ .. vₙ@ are bound.
+abstract :: AnnProgram -> Program
+abstract prog = Program $ map go prog
+  where
+  go :: (Ident, [Ident], AnnExp) -> Bind
+  go (name, pars, rhs@(_, e)) =
+    case e of
+      AAbs par e1 -> Bind name (snoc par pars ++ pars2) $ abstractExp e2
+        where
+          (e2, pars2) = flattenLambdasAnn e1
+      _           -> Bind name pars            $ abstractExp rhs
+
+
+-- | Flatten nested lambdas and collect the parameters
+-- @\x.\y.\z. ae → (ae, [x,y,z])@
+flattenLambdasAnn :: AnnExp -> (AnnExp, [Ident])
+flattenLambdasAnn ae = go (ae, [])
+  where
+    go :: (AnnExp, [Ident]) -> (AnnExp, [Ident])
+    go ((free, e), acc) =
+      case e of
+        AAbs par (free1, e1) -> go ((Set.delete par free1, e1), snoc par acc)
+        _                    -> ((free, e), acc)
+
+
+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 (map go bs) $ abstractExp e
+    where
+      go (ABind name parms rhs) =
+        let
+          (rhs', parms1)  = flattenLambdas $ skipLambdas abstractExp rhs
+        in
+          Bind name (parms ++ parms1) rhs'
+
+      skipLambdas :: (AnnExp -> Exp) -> AnnExp -> Exp
+      skipLambdas f (free, ae) = case ae of
+        AAbs name ae1 -> EAbs name $ skipLambdas f ae1
+        _             -> f (free, ae)
+
+  -- Lift lambda into let and bind free variables
+  AAbs par  e -> foldl EApp sc $ map EId freeList
+    where
+      freeList = Set.toList free
+      sc  = ELet [Bind "sc" (snoc par freeList) $ abstractExp e] $ EId "sc"
+
+-- | 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' pars' es') e')
+    where
+      (i1, e')        = renameExp e_env i e
+      (names, pars, rhss) = fromBinders bs
+      (i2, ns', env') = newNames i1 (names ++ concat pars)
+      pars'           = (map . map) renamePar pars
+      e_env           = Map.union env' env
+      (i3, es')       = mapAccumL (renameExp e_env) i2 rhss
+
+      renamePar p = case Map.lookup p env' of
+                     Just p' -> p'
+                     Nothing -> error ("Can't find name for " ++ show p)
+
+
+  EAbs par  e  -> (i2, EAbs par' e')
+    where
+      (i1, par', env') = newName par
+      (i2, e')         = renameExp (Map.union env' env ) i1 e
+
+
+newName :: Ident -> (Int, Ident, Map Ident Ident)
+newName old_name = (i, head names, env)
+  where (i, names, env) = newNames 1 [old_name]
+
+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
+
+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 scs) = Program $ concatMap collectFromRhs scs
+  where
+    collectFromRhs (Bind name parms rhs) =
+      let (rhs_scs, rhs') = collectScsExp rhs
+      in  Bind name parms rhs' : rhs_scs
+
+
+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
+
+  -- Collect supercombinators from binds, the rhss, and the expression.
+  --
+  -- > f = let
+  -- >       sc  = rhs
+  -- >       sc1 = rhs1
+  -- >          ...
+  -- >     in e
+  --
+  ELet binds e  -> (binds_scs ++ rhss_scs ++ e_scs, mkEAbs non_scs' e')
+    where
+      binds_scs           = [ let (rhs', parms1) = flattenLambdas rhs in
+                              Bind n (parms ++ parms1) rhs'
+                            | Bind n parms rhs <- scs'
+                            ]
+      (rhss_scs, binds')  = mapAccumL collectScsRhs [] binds
+      (e_scs, e')         = collectScsExp e
+
+      (scs', non_scs')    = partition (\(Bind _ pars _) -> notNull pars) binds'
+
+      collectScsRhs acc (Bind n xs rhs) = (acc ++ rhs_scs, Bind n xs rhs')
+        where
+          (rhs_scs, rhs') = collectScsExp rhs
+
+-- @\x.\y.\z. e → (e, [x,y,z])@
+flattenLambdas :: Exp -> (Exp, [Ident])
+flattenLambdas e = go (e, [])
+  where
+    go (e, acc) = case e of
+                   EAbs par e1 -> go (e1, snoc par acc)
+                   _           -> (e, acc)
+
+mkEAbs :: [Bind] -> Exp -> Exp
+mkEAbs [] e = e
+mkEAbs bs e = ELet bs e

src/Main.hs

@@ -1,30 +1,52 @@
 {-# LANGUAGE LambdaCase #-}
 module Main where
 
-import           Control.Monad.Except (runExcept)
+import           Grammar.ErrM       (Err)
-import           Grammar.Par          (myLexer, pProgram)
+import           Grammar.Par        (myLexer, pProgram)
-import           Interpreter          (interpret)
+import           Grammar.Print      (printTree)
-import           System.Environment   (getArgs)
+import           Interpreter        (interpret)
-import           System.Exit          (exitFailure, exitSuccess)
+import           LambdaLifter       (abstract, freeVars, lambdaLift)
+import           System.Environment (getArgs)
+import           System.Exit        (exitFailure, exitSuccess)
 
 main :: IO ()
 main = getArgs >>= \case
   []    -> print "Required file path missing"
-  (x:_) -> do
+  (s:_) -> main' s
-    file <- readFile x
+
-    case pProgram (myLexer file) of
+main' :: String -> IO ()
-      Left err -> do
+main' s = do
-       putStrLn "SYNTAX ERROR"
+  file   <- readFile s
-       putStrLn err
+
-       exitFailure
+  putStrLn "\n-- parse"
-      Right prg -> case runExcept $ interpret prg of
+  parsed    <- fromSyntaxErr . pProgram $ myLexer file
-        Left err -> do
+  putStrLn $ printTree parsed
-          putStrLn "INTERPRETER ERROR"
+
-          putStrLn err
+  putStrLn "\n-- Lambda Lifter"
-          exitFailure
+  let lifted = lambdaLift parsed
-        Right i -> do
+  putStrLn $ printTree lifted
-          print i
+
-          exitSuccess
+  -- interpred <- fromInterpreterErr $ interpret lifted
+  -- putStrLn "\n-- interpret"
+  -- print interpred
+
+  exitSuccess
 
 
+fromSyntaxErr :: Err a -> IO a
+fromSyntaxErr = either
+  (\err -> do
+    putStrLn "\nSYNTAX ERROR"
+    putStrLn err
+    exitFailure)
+ pure
+
+fromInterpreterErr :: Err a -> IO a
+fromInterpreterErr = either
+  (\err -> do
+    putStrLn "\nINTERPRETER ERROR"
+    putStrLn err
+    exitFailure)
+ pure
+
 

test_program

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