Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Moved modules into a proper folder structure.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-03-08 10:35:07 +01:00
parent ac0ac2dac7
commit d5dd7896d8
9 changed files with 66 additions and 180 deletions
Download patch file Download diff file Expand all files Collapse all files

8
language.cabal
View file

@ -32,11 +32,11 @@ executable language
Grammar.Print Grammar.Print
Grammar.Skel Grammar.Skel
Grammar.ErrM Grammar.ErrM
LambdaLifter LambdaLifter.LambdaLifter
Auxiliary Auxiliary
Renamer Renamer.Renamer
TypeChecker TypeChecker.TypeChecker
TypeCheckerIr TypeChecker.TypeCheckerIr
-- Interpreter -- Interpreter
Codegen.Codegen Codegen.Codegen
Codegen.LlvmIr Codegen.LlvmIr

33
src/Codegen/Codegen.hs
View file

@ -3,22 +3,23 @@
module Codegen.Codegen (generateCode) where module Codegen.Codegen (generateCode) where
import Auxiliary (snoc) import Auxiliary (snoc)
import Codegen.LlvmIr (CallingConvention (..), LLVMComp (..), import Codegen.LlvmIr (CallingConvention (..),
LLVMIr (..), LLVMType (..), LLVMComp (..), LLVMIr (..),
LLVMValue (..), Visibility (..), LLVMType (..), LLVMValue (..),
llvmIrToString) Visibility (..), llvmIrToString)
import Control.Monad.State (StateT, execStateT, foldM_, gets, modify) import Control.Monad.State (StateT, execStateT, foldM_, gets,
import qualified Data.Bifunctor as BI modify)
import Data.List.Extra (trim) import qualified Data.Bifunctor as BI
import Data.Map (Map) import Data.List.Extra (trim)
import qualified Data.Map as Map import Data.Map (Map)
import Data.Tuple.Extra (dupe, first, second) import qualified Data.Map as Map
import qualified Grammar.Abs as GA import Data.Tuple.Extra (dupe, first, second)
import Grammar.ErrM (Err) import qualified Grammar.Abs as GA
import System.Process.Extra (readCreateProcess, shell) import Grammar.ErrM (Err)
import TypeCheckerIr (Bind (..), Case (..), Exp (..), Id, import System.Process.Extra (readCreateProcess, shell)
Ident (..), Program (..), Type (..)) import TypeChecker.TypeCheckerIr (Bind (..), Case (..), Exp (..), Id,
Ident (..), Program (..), Type (..))
-- | The record used as the code generator state -- | The record used as the code generator state
data CodeGenerator = CodeGenerator data CodeGenerator = CodeGenerator
{ instructions :: [LLVMIr] { instructions :: [LLVMIr]

4
src/Codegen/LlvmIr.hs
View file

@ -10,8 +10,8 @@ module Codegen.LlvmIr (
CallingConvention (..) CallingConvention (..)
) where ) where
import Data.List (intercalate) import Data.List (intercalate)
import TypeCheckerIr import TypeChecker.TypeCheckerIr
data CallingConvention = TailCC | FastCC | CCC | ColdCC data CallingConvention = TailCC | FastCC | CCC | ColdCC
instance Show CallingConvention where instance Show CallingConvention where

116
src/Interpreter.hs
View file

@ -1,116 +0,0 @@
{-# 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 -> Err Integer
interpret (Program scs) = do
main <- findMain scs
eval (initCxt scs) main >>=
\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 Env Ident Exp
deriving (Show, Eq)
type Env = Map Ident Val
type Sig = Map Ident Exp
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 -> do
case Map.lookup x cxt.env of
Just e -> pure e
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₁ ⇓ 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
let cxt' = putEnv (Map.insert x v delta) cxt
eval cxt' f
--
-- -----------------------------
-- γ ⊢ λx. f ⇓ let γ in λx. f
EAbs par e -> pure $ VClosure cxt.env par 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"
ELet _ _ -> throwError "ELet pattern match should never occur!"
emptyEnv :: Cxt -> Cxt
emptyEnv cxt = cxt { env = mempty }
putEnv :: Env -> Cxt -> Cxt
putEnv env cxt = cxt { env = env }

23
src/LambdaLifter.hs → src/LambdaLifter/LambdaLifter.hs
View file

@ -2,18 +2,19 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where module LambdaLifter.LambdaLifter (lambdaLift, freeVars, abstract, rename, collectScs) where
import Auxiliary (snoc) import Auxiliary (snoc)
import Control.Applicative (Applicative (liftA2)) import Control.Applicative (Applicative (liftA2))
import Control.Monad.State (MonadState (get, put), State, evalState) import Control.Monad.State (MonadState (get, put), State,
import Data.Set (Set) evalState)
import qualified Data.Set as Set import Data.Set (Set)
import Debug.Trace (trace) import qualified Data.Set as Set
import qualified Grammar.Abs as GA import Debug.Trace (trace)
import Prelude hiding (exp) import qualified Grammar.Abs as GA
import Renamer import Prelude hiding (exp)
import TypeCheckerIr import Renamer.Renamer
import TypeChecker.TypeCheckerIr
-- | Lift lambdas and let expression into supercombinators. -- | Lift lambdas and let expression into supercombinators.

36
src/Main.hs
View file

@ -2,26 +2,26 @@
module Main where module Main where
import Codegen.Codegen (generateCode) import Codegen.Codegen (generateCode)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
-- import Interpreter (interpret) -- import Interpreter (interpret)
import Control.Monad (when) import Control.Monad (when)
import Data.List.Extra (isSuffixOf) import Data.List.Extra (isSuffixOf)
import LambdaLifter (lambdaLift) import LambdaLifter.LambdaLifter (lambdaLift)
import Renamer (rename) import Renamer.Renamer (rename)
import System.Directory (createDirectory, doesPathExist, import System.Directory (createDirectory, doesPathExist,
getDirectoryContents, getDirectoryContents,
removeDirectoryRecursive, removeDirectoryRecursive,
setCurrentDirectory) setCurrentDirectory)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess) import System.Exit (exitFailure, exitSuccess)
import System.IO (stderr) import System.IO (stderr)
import System.Process.Extra (spawnCommand, waitForProcess) import System.Process.Extra (spawnCommand, waitForProcess)
import TypeChecker (typecheck) import TypeChecker.TypeChecker (typecheck)
main :: IO () main :: IO ()
main = main =

2
src/Renamer.hs → src/Renamer/Renamer.hs
View file

@ -1,6 +1,6 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Renamer (module Renamer) where module Renamer.Renamer (module Renamer.Renamer) where
import Auxiliary (mapAccumM) import Auxiliary (mapAccumM)
import Control.Monad (foldM) import Control.Monad (foldM)

20
src/TypeChecker.hs → src/TypeChecker/TypeChecker.hs
View file

@ -1,18 +1,18 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedRecordDot #-}
module TypeChecker (typecheck, partitionType) where module TypeChecker.TypeChecker (typecheck, partitionType) where
import Auxiliary (maybeToRightM, snoc) import Auxiliary (maybeToRightM, snoc)
import Control.Monad.Except (throwError, unless) import Control.Monad.Except (throwError, unless)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Grammar.Abs import Grammar.Abs
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Print (Print (prt), concatD, doc, printTree, import Grammar.Print (Print (prt), concatD, doc,
render) printTree, render)
import Prelude hiding (exp, id) import Prelude hiding (exp, id)
import qualified TypeCheckerIr as T import qualified TypeChecker.TypeCheckerIr as T
-- NOTE: this type checker is poorly tested -- NOTE: this type checker is poorly tested

4
src/TypeCheckerIr.hs → src/TypeChecker/TypeCheckerIr.hs
View file

@ -1,8 +1,8 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module TypeCheckerIr module TypeChecker.TypeCheckerIr
( module Grammar.Abs ( module Grammar.Abs
, module TypeCheckerIr , module TypeChecker.TypeCheckerIr
) where ) where
import Grammar.Abs (Ident (..), Type (..)) import Grammar.Abs (Ident (..), Type (..))