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

Merged

Browse source
This commit is contained in:
Rakarake 2023-04-27 14:02:10 +02:00
commit 579153b679
9 changed files with 339 additions and 261 deletions
Download patch file Download diff file Expand all files Collapse all files

9
benchmark.txt Normal file
View file

@ -0,0 +1,9 @@
# Full optimization Churf
File: output/hello_world, 100 runs gave average: 0.025261127948760988s
# O2 Haskell
File: ./Bench, 100 runs gave average: 0.05629507303237915s
# 03 Haskell
File: ./Bench, 100 runs gave average: 0.05490849256515503s
File: ./Bench, 100 runs gave average: 0.05323728561401367s

3
sample-programs/lt_testing.crf Normal file
View file

@ -0,0 +1,3 @@
main = case (lt 3 5) of
True => 1
False => 0

1
src/Codegen/Auxillary.hs
View file

@ -9,6 +9,7 @@ type2LlvmType :: MIR.Type -> LLVMType
type2LlvmType (MIR.TLit id@(TIR.Ident name)) = case name of
"Int" -> I64
"Char" -> I8
"Bool" -> I1
_ -> CustomType id
type2LlvmType (MIR.TFun t xs) = do
let (t', xs') = function2LLVMType xs [type2LlvmType t]

13
src/Codegen/Codegen.hs
View file

@ -11,7 +11,8 @@ import Control.Monad.State (
)
import Data.List (sortBy)
import Grammar.ErrM (Err)
import Monomorphizer.MonomorphizerIr as MIR (Def (DBind, DData), Program (..))
import Monomorphizer.MonomorphizerIr as MIR (Bind (..), Data (..), Def (DBind, DData), Program (..), Type (TLit))
import TypeChecker.TypeCheckerIr (Ident (..))
{- | Compiles an AST and produces a LLVM Ir string.
An easy way to actually "compile" this output is to
@ -19,8 +20,14 @@ import Monomorphizer.MonomorphizerIr as MIR (Def (DBind, DData), Program (..))
-}
generateCode :: MIR.Program -> Err String
generateCode (MIR.Program scs) = do
let codegen = initCodeGenerator scs
llvmIrToString . instructions <$> execStateT (compileScs (sortBy lowData scs)) codegen
let tree = filter (not . detectPrelude) (sortBy lowData scs)
let codegen = initCodeGenerator tree
llvmIrToString . instructions <$> execStateT (compileScs tree) codegen
detectPrelude :: Def -> Bool
detectPrelude (DData (Data (TLit (Ident "Bool")) _)) = True
detectPrelude (DBind (Bind (Ident ('l' : 't' : '$' : _), _) _ _)) = True
detectPrelude _ = False
lowData :: Def -> Def -> Ordering
lowData (DData _) (DBind _) = LT

19
src/Codegen/Emits.hs
View file

@ -228,15 +228,15 @@ emitECased t e cases = do
emit $ Store ty val Ptr stackPtr
emit $ Br label
emit $ Label lbl_failPos
emitCases _rt ty label stackPtr vs (Branch (MIR.PLit i, t) exp) = do
emitCases _rt ty label stackPtr vs (Branch (MIR.PLit (i, ct), t) exp) = do
emit $ Comment "Plit"
let i' = case i of
(MIR.LInt i, _) -> VInteger i
(MIR.LChar i, _) -> VChar (ord i)
MIR.LInt i -> VInteger i
MIR.LChar i -> VChar (ord i)
ns <- getNewVar
lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> TIR.Ident $ "success_" <> show x) <$> getNewLabel
emit $ SetVariable ns (Icmp LLEq (type2LlvmType t) vs i')
emit $ SetVariable ns (Icmp LLEq (type2LlvmType ct) vs i')
emit $ BrCond (VIdent ns ty) lbl_succPos lbl_failPos
emit $ Label lbl_succPos
val <- exprToValue exp
@ -255,9 +255,13 @@ emitECased t e cases = do
emit $ Br label
lbl_failPos <- (\x -> TIR.Ident $ "failed_" <> show x) <$> getNewLabel
emit $ Label lbl_failPos
emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "True"), t) exp) = do
emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 1, TLit "Bool"), t) exp)
emitCases rt ty label stackPtr vs (Branch (MIR.PEnum (TIR.Ident "False"), _) exp) = do
emitCases rt ty label stackPtr vs (Branch (MIR.PLit (MIR.LInt 0, TLit "Bool"), t) exp)
emitCases _rt ty label stackPtr _vs (Branch (MIR.PEnum _id, _) exp) = do
-- //TODO Penum wrong, acts as a catch all
emit $ Comment "Penum"
emit $ Comment $ "Penum " <> show _id
val <- exprToValue exp
emit $ Store ty val Ptr stackPtr
emit $ Br label
@ -290,7 +294,10 @@ emitApp rt e1 e2 = appEmitter e1 e2 []
<|> Global <$ Map.lookup (name, t) funcs
-- this piece of code could probably be improved, i.e remove the double `const Global`
args' = map (first valueGetType . dupe) args
call = Call FastCC (type2LlvmType rt) visibility name args'
let call =
case name of
TIR.Ident ('l' : 't' : '$' : _) -> Icmp LLSlt I64 (snd (head args')) (snd (args' !! 1))
_ -> Call FastCC (type2LlvmType rt) visibility name args'
emit $ Comment $ show rt
emit $ SetVariable vs call
x -> error $ "The unspeakable happened: " <> show x

2
src/Main.hs
View file

@ -166,4 +166,4 @@ printToErr = hPutStrLn stderr
fromErr :: Err a -> IO a
fromErr = either (\s -> printToErr s >> exitFailure) pure
prelude = "const x y = x\n\ndata Bool () where\n True : Bool ()\n False : Bool ()\n\nlt : Int -> Int -> Bool ()\nlt = \\x. \\y. const True (x + y)"
prelude = "\n\nconst x y = x\n\ndata Bool () where\n True : Bool ()\n False : Bool ()\n\nlt : Int -> Int -> Bool ()\nlt = \\x. \\y. const True (x + y)"

33
src/Monomorphizer/DataTypeRemover.hs
View file

@ -1,6 +1,7 @@
module Monomorphizer.DataTypeRemover (removeDataTypes) where
import qualified Monomorphizer.MorbIr as M1
import qualified Monomorphizer.MonomorphizerIr as M2
import Monomorphizer.MonomorphizerIr qualified as M2
import Monomorphizer.MorbIr qualified as M1
import TypeChecker.TypeCheckerIr (Ident (Ident))
removeDataTypes :: M1.Program -> M2.Program
@ -17,9 +18,10 @@ pCons :: M1.Inj -> M2.Inj
pCons (M1.Inj ident t) = M2.Inj ident (pType t)
pType :: M1.Type -> M2.Type
pType (M1.TLit ident) = M2.TLit ident
pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2)
pType d = M2.TLit (Ident (newName d)) -- This is the step
pType (M1.TLit ident) = M2.TLit ident
pType (M1.TFun t1 t2) = M2.TFun (pType t1) (pType t2)
pType (M1.TData (Ident "Bool") _) = M2.TLit (Ident "Bool")
pType d = M2.TLit (Ident (newName d)) -- This is the step
newName :: M1.Type -> String
newName (M1.TLit (Ident str)) = str
@ -36,24 +38,23 @@ pExpT :: M1.ExpT -> M2.ExpT
pExpT (exp, t) = (pExp exp, pType t)
pExp :: M1.Exp -> M2.Exp
pExp (M1.EVar ident) = M2.EVar ident
pExp (M1.ELit lit) = M2.ELit (pLit lit)
pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt)
pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2)
pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2)
pExp (M1.EVar ident) = M2.EVar ident
pExp (M1.ELit lit) = M2.ELit (pLit lit)
pExp (M1.ELet bind expt) = M2.ELet (pBind bind) (pExpT expt)
pExp (M1.EApp e1 e2) = M2.EApp (pExpT e1) (pExpT e2)
pExp (M1.EAdd e1 e2) = M2.EAdd (pExpT e1) (pExpT e2)
pExp (M1.ECase expT branches) = M2.ECase (pExpT expT) (map pBranch branches)
pBranch :: M1.Branch -> M2.Branch
pBranch (M1.Branch (patt, t) expt) = M2.Branch (pPattern patt, pType t) (pExpT expt)
pPattern :: M1.Pattern -> M2.Pattern
pPattern (M1.PVar id) = M2.PVar (pId id)
pPattern (M1.PLit (lit, t)) = M2.PLit (pLit lit, pType t)
pPattern (M1.PVar id) = M2.PVar (pId id)
pPattern (M1.PLit (lit, t)) = M2.PLit (pLit lit, pType t)
pPattern (M1.PInj ident patts) = M2.PInj ident (map pPattern patts)
pPattern M1.PCatch = M2.PCatch
pPattern (M1.PEnum ident) = M2.PEnum ident
pPattern M1.PCatch = M2.PCatch
pPattern (M1.PEnum ident) = M2.PEnum ident
pLit :: M1.Lit -> M2.Lit
pLit (M1.LInt v) = M2.LInt v
pLit (M1.LInt v) = M2.LInt v
pLit (M1.LChar c) = M2.LChar c

467
src/Monomorphizer/Monomorphizer.hs
View file

@ -1,72 +1,84 @@
-- | For now, converts polymorphic functions to concrete ones based on usage.
-- Assumes lambdas are lifted.
--
-- This step of compilation is as follows:
--
-- Split all function bindings into monomorphic and polymorphic binds. The
-- monomorphic bindings will be part of this compilation step.
-- Apply the following monomorphization function on all monomorphic binds, with
-- their type as an additional argument.
--
-- The function that transforms Binds operates on both monomorphic and
-- polymorphic functions, creates a context in which all possible polymorphic types
-- are mapped to concrete types, created using the additional argument.
-- Expressions are then recursively processed. The type of these expressions
-- are changed to using the mapped generic types. The expected type provided
-- in the recursion is changed depending on the different nodes.
--
-- When an external bind is encountered (with EId), it is checked whether it
-- exists in outputed binds or not. If it does, nothing further is evaluated.
-- If not, the bind transformer function is called on it with the
-- expected type in this context. The result of this computation (a monomorphic
-- bind) is added to the resulting set of binds.
{-# LANGUAGE LambdaCase #-}
{- | For now, converts polymorphic functions to concrete ones based on usage.
Assumes lambdas are lifted.
This step of compilation is as follows:
Split all function bindings into monomorphic and polymorphic binds. The
monomorphic bindings will be part of this compilation step.
Apply the following monomorphization function on all monomorphic binds, with
their type as an additional argument.
The function that transforms Binds operates on both monomorphic and
polymorphic functions, creates a context in which all possible polymorphic types
are mapped to concrete types, created using the additional argument.
Expressions are then recursively processed. The type of these expressions
are changed to using the mapped generic types. The expected type provided
in the recursion is changed depending on the different nodes.
When an external bind is encountered (with EId), it is checked whether it
exists in outputed binds or not. If it does, nothing further is evaluated.
If not, the bind transformer function is called on it with the
expected type in this context. The result of this computation (a monomorphic
bind) is added to the resulting set of binds.
-}
module Monomorphizer.Monomorphizer (monomorphize, morphExp, morphBind) where
import Monomorphizer.DataTypeRemover (removeDataTypes)
import qualified Monomorphizer.MonomorphizerIr as O
import qualified Monomorphizer.MorbIr as M
import qualified TypeChecker.TypeCheckerIr as T
import TypeChecker.TypeCheckerIr (Ident (Ident))
import Monomorphizer.DataTypeRemover (removeDataTypes)
import Monomorphizer.MonomorphizerIr qualified as O
import Monomorphizer.MorbIr qualified as M
import TypeChecker.TypeCheckerIr (Ident (Ident))
import TypeChecker.TypeCheckerIr qualified as T
import Control.Monad.Reader (MonadReader (ask, local),
Reader, asks, runReader, when)
import Control.Monad.State (MonadState, StateT (runStateT),
gets, modify)
import Data.Coerce (coerce)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Debug.Trace
import Grammar.Print (printTree)
import Control.Monad.Reader (
MonadReader (ask, local),
Reader,
asks,
runReader,
when,
)
import Control.Monad.State (
MonadState,
StateT (runStateT),
gets,
modify,
)
import Data.Coerce (coerce)
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Debug.Trace
import Grammar.Print (printTree)
-- | EnvM is the monad containing the read-only state as well as the
-- output state containing monomorphized functions and to-be monomorphized
-- data type declarations.
{- | EnvM is the monad containing the read-only state as well as the
output state containing monomorphized functions and to-be monomorphized
data type declarations.
-}
newtype EnvM a = EnvM (StateT Output (Reader Env) a)
deriving (Functor, Applicative, Monad, MonadState Output, MonadReader Env)
deriving (Functor, Applicative, Monad, MonadState Output, MonadReader Env)
type Output = Map.Map Ident Outputted
-- | Data structure describing outputted top-level information, that is
-- Binds, Polymorphic Data types (monomorphized in a later step) and
-- Marked bind, which means that it is in the process of monomorphization
-- and should not be monomorphized again.
{- | Data structure describing outputted top-level information, that is
Binds, Polymorphic Data types (monomorphized in a later step) and
Marked bind, which means that it is in the process of monomorphization
and should not be monomorphized again.
-}
data Outputted = Marked | Complete M.Bind | Data M.Type T.Data
-- | Static environment.
data Env = Env {
-- | All binds in the program.
input :: Map.Map Ident T.Bind,
-- | All constructors mapped to their respective polymorphic data def
-- which includes all other constructors.
dataDefs :: Map.Map Ident T.Data,
-- | Maps polymorphic identifiers with concrete types.
polys :: Map.Map Ident M.Type,
-- | Local variables.
locals :: Set.Set Ident
}
data Env = Env
{ input :: Map.Map Ident T.Bind
-- ^ All binds in the program.
, dataDefs :: Map.Map Ident T.Data
-- ^ All constructors mapped to their respective polymorphic data def
-- which includes all other constructors.
, polys :: Map.Map Ident M.Type
-- ^ Maps polymorphic identifiers with concrete types.
, locals :: Set.Set Ident
-- ^ Local variables.
}
-- | Determines if the identifier describes a local variable in the given context.
localExists :: Ident -> EnvM Bool
@ -80,8 +92,9 @@ getInputBind ident = asks (Map.lookup ident . input)
addOutputBind :: M.Bind -> EnvM ()
addOutputBind b@(M.Bind (ident, _) _ _) = modify (Map.insert ident (Complete b))
-- | Marks a global bind as being processed, meaning that when encountered again,
-- it should not be recursively processed.
{- | Marks a global bind as being processed, meaning that when encountered again,
it should not be recursively processed.
-}
markBind :: Ident -> EnvM ()
markBind ident = modify (Map.insert ident Marked)
@ -96,125 +109,143 @@ getMain = asks (\env -> case Map.lookup (T.Ident "main") (input env) of
Nothing -> error "main not found in monomorphizer!"
)
-- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime
-- error when encountering different structures between the two arguments.
{- | Makes a kv pair list of polymorphic to monomorphic mappings, throws runtime
error when encountering different structures between the two arguments.
-}
mapTypes :: T.Type -> M.Type -> [(Ident, M.Type)]
mapTypes (T.TLit _) (M.TLit _) = []
mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)]
mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) = mapTypes pt1 mt1 ++
mapTypes pt2 mt2
mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) = if tIdent /= mIdent
then error "the data type names of monomorphic and polymorphic data types does not match"
else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs)
mapTypes (T.TLit _) (M.TLit _) = []
mapTypes (T.TVar (T.MkTVar i1)) tm = [(i1, tm)]
mapTypes (T.TFun pt1 pt2) (M.TFun mt1 mt2) =
mapTypes pt1 mt1
++ mapTypes pt2 mt2
mapTypes (T.TData tIdent pTs) (M.TData mIdent mTs) =
if tIdent /= mIdent
then error "the data type names of monomorphic and polymorphic data types does not match"
else foldl (\xs (p, m) -> mapTypes p m ++ xs) [] (zip pTs mTs)
mapTypes t1 t2 = error $ "structure of types not the same: '" ++ printTree t1 ++ "', '" ++ printTree t2 ++ "'"
-- | Gets the mapped monomorphic type of a polymorphic type in the current context.
getMonoFromPoly :: T.Type -> EnvM M.Type
getMonoFromPoly t = do env <- ask
return $ getMono (polys env) t
where
getMono :: Map.Map Ident M.Type -> T.Type -> M.Type
getMono polys t = case t of
(T.TLit ident) -> M.TLit (coerce ident)
(T.TFun t1 t2) -> M.TFun (getMono polys t1) (getMono polys t2)
(T.TVar (T.MkTVar ident)) -> case Map.lookup ident polys of
Just concrete -> concrete
Nothing -> M.TLit (Ident "void")
--error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps"
(T.TData ident args) -> M.TData ident (map (getMono polys) args)
getMonoFromPoly t = do
env <- ask
return $ getMono (polys env) t
where
getMono :: Map.Map Ident M.Type -> T.Type -> M.Type
getMono polys t = case t of
(T.TLit ident) -> M.TLit (coerce ident)
(T.TFun t1 t2) -> M.TFun (getMono polys t1) (getMono polys t2)
(T.TVar (T.MkTVar ident)) -> case Map.lookup ident polys of
Just concrete -> concrete
Nothing -> M.TLit (Ident "void")
-- error $ "type not found! type: " ++ show ident ++ ", error in previous compilation steps"
(T.TData ident args) -> M.TData ident (map (getMono polys) args)
-- | If ident not already in env's output, morphed bind to output
-- (and all referenced binds within this bind).
-- Returns the annotated bind name.
{- | If ident not already in env's output, morphed bind to output
(and all referenced binds within this bind).
Returns the annotated bind name.
-}
morphBind :: M.Type -> T.Bind -> EnvM Ident
morphBind expectedType b@(T.Bind (Ident str, btype) args (exp, expt)) =
local (\env -> env { locals = Set.fromList (map fst args),
polys = Map.fromList (mapTypes btype expectedType)
}) $ do
-- The "new name" is used to find out if it is already marked or not.
let name' = newFuncName expectedType b
bindMarked <- isBindMarked (coerce name')
-- Return with right name if already marked
if bindMarked then return name' else do
-- Mark so that this bind will not be processed in recursive or cyclic
-- function calls
markBind (coerce name')
expt' <- getMonoFromPoly expt
exp' <- morphExp expt' exp
-- Get monomorphic type sof args
args' <- mapM morphArg args
addOutputBind $ M.Bind (coerce name', expectedType)
args' (exp', expt')
return name'
local
( \env ->
env
{ locals = Set.fromList (map fst args)
, polys = Map.fromList (mapTypes btype expectedType)
}
)
$ do
-- The "new name" is used to find out if it is already marked or not.
let name' = newFuncName expectedType b
bindMarked <- isBindMarked (coerce name')
-- Return with right name if already marked
if bindMarked
then return name'
else do
-- Mark so that this bind will not be processed in recursive or cyclic
-- function calls
markBind (coerce name')
expt' <- getMonoFromPoly expt
exp' <- morphExp expt' exp
-- Get monomorphic type sof args
args' <- mapM morphArg args
addOutputBind $
M.Bind
(coerce name', expectedType)
args'
(exp', expt')
return name'
-- | Monomorphizes arguments of a bind.
morphArg :: (Ident, T.Type) -> EnvM (Ident, M.Type)
morphArg (ident, t) = do t' <- getMonoFromPoly t
return (ident, t')
morphArg (ident, t) = do
t' <- getMonoFromPoly t
return (ident, t')
-- | Gets the data bind from the name of a constructor.
getInputData :: Ident -> EnvM (Maybe T.Data)
getInputData ident = do env <- ask
return $ Map.lookup ident (dataDefs env)
getInputData ident = do
env <- ask
return $ Map.lookup ident (dataDefs env)
-- | Monomorphize a constructor using it's global name. Constructors may
-- appear as expressions in the tree, or as patterns in case-expressions.
{- | Monomorphize a constructor using it's global name. Constructors may
appear as expressions in the tree, or as patterns in case-expressions.
-}
morphCons :: M.Type -> Ident -> EnvM ()
morphCons expectedType ident = do
maybeD <- getInputData ident
case maybeD of
Nothing -> error $ "identifier '" ++ show ident ++ "' not found"
Just d -> do
modify (\output -> Map.insert ident (Data expectedType d) output )
maybeD <- getInputData ident
case maybeD of
Nothing -> error $ "identifier '" ++ show ident ++ "' not found"
Just d -> do
modify (\output -> Map.insert ident (Data expectedType d) output)
-- | Converts literals from input to output tree.
convertLit :: T.Lit -> M.Lit
convertLit (T.LInt v) = M.LInt v
convertLit (T.LInt v) = M.LInt v
convertLit (T.LChar v) = M.LChar v
-- | Monomorphizes an expression, given an expected type.
morphExp :: M.Type -> T.Exp -> EnvM M.Exp
morphExp expectedType exp = case exp of
T.ELit lit -> return $ M.ELit (convertLit lit)
-- Constructor
T.EInj ident -> do
return $ M.EVar ident
T.EApp (e1, _t1) (e2, t2) -> do
t2' <- getMonoFromPoly t2
e2' <- morphExp t2' e2
e1' <- morphExp (M.TFun t2' expectedType) e1
return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2')
T.EAdd (e1, t1) (e2, t2) -> do
t1' <- getMonoFromPoly t1
t2' <- getMonoFromPoly t2
e1' <- morphExp t1' e1
e2' <- morphExp t2' e2
return $ M.EAdd (e1', expectedType) (e2', expectedType)
T.EAbs ident (exp, t) -> local (\env -> env { locals = Set.insert ident (locals env) }) $ do
t' <- getMonoFromPoly t
morphExp t' exp
T.ECase (exp, t) bs -> do
t' <- getMonoFromPoly t
bs' <- mapM morphBranch bs
exp' <- morphExp t' exp
return $ M.ECase (exp', t') bs'
T.EVar ident -> do
isLocal <- localExists ident
if isLocal then do
return $ M.EVar (coerce ident)
else do
bind <- getInputBind ident
case bind of
Nothing -> do
-- This is a constructor
morphCons expectedType ident
return $ M.EVar ident
Just bind' -> do
-- New bind to process
newBindName <- morphBind expectedType bind'
return $ M.EVar (coerce newBindName)
T.ELet (T.Bind {}) _ -> error "lets not possible yet"
T.ELit lit -> return $ M.ELit (convertLit lit)
-- Constructor
T.EInj ident -> do
return $ M.EVar ident
T.EApp (e1, _t1) (e2, t2) -> do
t2' <- getMonoFromPoly t2
e2' <- morphExp t2' e2
e1' <- morphExp (M.TFun t2' expectedType) e1
return $ M.EApp (e1', M.TFun t2' expectedType) (e2', t2')
T.EAdd (e1, t1) (e2, t2) -> do
t1' <- getMonoFromPoly t1
t2' <- getMonoFromPoly t2
e1' <- morphExp t1' e1
e2' <- morphExp t2' e2
return $ M.EAdd (e1', expectedType) (e2', expectedType)
T.EAbs ident (exp, t) -> local (\env -> env{locals = Set.insert ident (locals env)}) $ do
t' <- getMonoFromPoly t
morphExp t' exp
T.ECase (exp, t) bs -> do
t' <- getMonoFromPoly t
bs' <- mapM morphBranch bs
exp' <- morphExp t' exp
return $ M.ECase (exp', t') bs'
T.EVar ident -> do
isLocal <- localExists ident
if isLocal
then do
return $ M.EVar (coerce ident)
else do
bind <- getInputBind ident
case bind of
Nothing -> do
-- This is a constructor
morphCons expectedType ident
return $ M.EVar ident
Just bind' -> do
-- New bind to process
newBindName <- morphBind expectedType bind'
return $ M.EVar (coerce newBindName)
T.ELet (T.Bind{}) _ -> error "lets not possible yet"
-- | Monomorphizes case-of branches.
morphBranch :: T.Branch -> EnvM M.Branch
@ -239,32 +270,36 @@ morphPattern p expectedType = case p of
let pts' = zip (map fst pts) ts'
psSets <- mapM (uncurry morphPattern) pts'
return (M.PInj ident (map fst psSets), Set.unions $ map snd psSets)
-- | Creates a new identifier for a function with an assigned type.
newFuncName :: M.Type -> T.Bind -> Ident
newFuncName t (T.Bind (ident@(Ident bindName), _) _ _) =
if bindName == "main"
then Ident bindName
else newName t ident
if bindName == "main"
then Ident bindName
else newName t ident
newName :: M.Type -> Ident -> Ident
newName t (Ident str) = Ident $ str ++ "$" ++ newName' t
where
newName' :: M.Type -> String
newName' (M.TLit (Ident str)) = str
newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2
newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts
where
newName' :: M.Type -> String
newName' (M.TLit (Ident str)) = str
newName' (M.TFun t1 t2) = newName' t1 ++ "_" ++ newName' t2
newName' (M.TData (Ident str) ts) = str ++ foldl (\s t -> s ++ "." ++ newName' t) "" ts
-- | Monomorphization step.
monomorphize :: T.Program -> O.Program
monomorphize (T.Program defs) = removeDataTypes $ M.Program (getDefsFromOutput
(runEnvM Map.empty (createEnv defs) monomorphize'))
where
monomorphize' :: EnvM ()
monomorphize' = do
main <- getMain
morphBind (M.TLit $ Ident "Int") main
return ()
monomorphize (T.Program defs) =
removeDataTypes $
M.Program
( getDefsFromOutput
(runEnvM Map.empty (createEnv defs) monomorphize')
)
where
monomorphize' :: EnvM ()
monomorphize' = do
main <- getMain
morphBind (M.TLit $ Ident "Int") main
return ()
-- | Runs and gives the output binds.
runEnvM :: Output -> Env -> EnvM () -> Output
@ -272,14 +307,17 @@ runEnvM o env (EnvM stateM) = snd $ runReader (runStateT stateM o) env
-- | Creates the environment based on the input binds.
createEnv :: [T.Def] -> Env
createEnv defs = Env { input = Map.fromList bindPairs,
dataDefs = Map.fromList dataPairs,
polys = Map.empty,
locals = Set.empty }
where
bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs
dataPairs :: [(Ident, T.Data)]
dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs
createEnv defs =
Env
{ input = Map.fromList bindPairs
, dataDefs = Map.fromList dataPairs
, polys = Map.empty
, locals = Set.empty
}
where
bindPairs = (map (\b -> (getBindName b, b)) . getBindsFromDefs) defs
dataPairs :: [(Ident, T.Data)]
dataPairs = (foldl (\acc d@(T.Data _ cs) -> map ((,d) . getConsName) cs ++ acc) [] . getDataFromDefs) defs
-- | Gets a top-lefel function name.
getBindName :: T.Bind -> Ident
@ -288,51 +326,64 @@ getBindName (T.Bind (ident, _) _ _) = ident
-- Helper functions
-- Gets custom data declarations form defs.
getDataFromDefs :: [T.Def] -> [T.Data]
getDataFromDefs = foldl (\bs -> \case
T.DBind _ -> bs
T.DData d -> d:bs) []
getDataFromDefs =
foldl
( \bs -> \case
T.DBind _ -> bs
T.DData d -> d : bs
)
[]
getConsName :: T.Inj -> Ident
getConsName (T.Inj ident _) = ident
getBindsFromDefs :: [T.Def] -> [T.Bind]
getBindsFromDefs = foldl (\bs -> \case
T.DBind b -> b:bs
T.DData _ -> bs) []
getBindsFromDefs =
foldl
( \bs -> \case
T.DBind b -> b : bs
T.DData _ -> bs
)
[]
getDefsFromOutput :: Output -> [M.Def]
getDefsFromOutput o =
map M.DBind binds ++
(map (M.DData . snd) . Map.toList) (createNewData dataInput Map.empty)
where
(binds, dataInput) = splitBindsAndData o
map M.DBind binds
++ (map (M.DData . snd) . Map.toList) (createNewData dataInput Map.empty)
where
(binds, dataInput) = splitBindsAndData o
-- | Splits the output into binds and data declaration components (used in createNewData)
splitBindsAndData :: Output -> ([M.Bind], [(Ident, M.Type, T.Data)])
splitBindsAndData output = foldl
(\(oBinds, oData) (ident, o) -> case o of
Marked -> error "internal bug in monomorphizer"
Complete b -> (b:oBinds, oData)
Data t d -> (oBinds, (ident, t, d):oData))
([], [])
(Map.toList output)
splitBindsAndData output =
foldl
( \(oBinds, oData) (ident, o) -> case o of
Marked -> error "internal bug in monomorphizer"
Complete b -> (b : oBinds, oData)
Data t d -> (oBinds, (ident, t, d) : oData)
)
([], [])
(Map.toList output)
-- | Converts all found constructors to monomorphic data declarations.
createNewData :: [(Ident, M.Type, T.Data)] -> Map.Map Ident M.Data -> Map.Map Ident M.Data
createNewData [] o = o
createNewData ((consIdent, consType, polyData):input) o =
createNewData input $
Map.insertWith (\_ (M.Data _ cs) -> M.Data newDataType (newCons:cs))
newDataName (M.Data newDataType [newCons]) o
where
T.Data (T.TData polyDataIdent _) _ = polyData
newDataType = getDataType consType
newDataName = newName newDataType polyDataIdent
newCons = M.Inj consIdent consType
createNewData [] o = o
createNewData ((consIdent, consType, polyData) : input) o =
createNewData input $
Map.insertWith
(\_ (M.Data _ cs) -> M.Data newDataType (newCons : cs))
newDataName
(M.Data newDataType [newCons])
o
where
T.Data (T.TData polyDataIdent _) _ = polyData
newDataType = getDataType consType
newDataName = newName newDataType polyDataIdent
newCons = M.Inj consIdent consType
-- | Gets the Data Type of a constructor type (a -> Just a becomes Just a).
getDataType :: M.Type -> M.Type
getDataType (M.TFun t1 t2) = getDataType t2
getDataType tData@(M.TData _ _) = tData
getDataType _ = error "???"
getDataType (M.TFun t1 t2) = getDataType t2
getDataType tData@(M.TData _ _) = tData
getDataType _ = error "???"

53
src/TypeChecker/ReportTEVar.hs
View file

@ -2,16 +2,15 @@
module TypeChecker.ReportTEVar where
import Auxiliary (onM)
import Control.Applicative (Applicative (liftA2), liftA3)
import Control.Monad.Except (MonadError (throwError))
import Data.Coerce (coerce)
import Data.Tuple.Extra (secondM)
import qualified Grammar.Abs as G
import Grammar.ErrM (Err)
import Grammar.Print (printTree)
import TypeChecker.TypeCheckerIr hiding (Type (..))
import Auxiliary (onM)
import Control.Applicative (Applicative (liftA2), liftA3)
import Control.Monad.Except (MonadError (throwError))
import Data.Coerce (coerce)
import Data.Tuple.Extra (secondM)
import Grammar.Abs qualified as G
import Grammar.ErrM (Err)
import Grammar.Print (printTree)
import TypeChecker.TypeCheckerIr hiding (Type (..))
data Type
= TLit Ident
@ -30,20 +29,20 @@ instance ReportTEVar (Program' G.Type) (Program' Type) where
instance ReportTEVar (Def' G.Type) (Def' Type) where
reportTEVar = \case
DBind bind -> DBind <$> reportTEVar bind
DData dat -> DData <$> reportTEVar dat
DData dat -> DData <$> reportTEVar dat
instance ReportTEVar (Bind' G.Type) (Bind' Type) where
reportTEVar (Bind id vars rhs) = liftA3 Bind (reportTEVar id) (reportTEVar vars) (reportTEVar rhs)
instance ReportTEVar (Exp' G.Type) (Exp' Type) where
reportTEVar exp = case exp of
EVar name -> pure $ EVar name
EInj name -> pure $ EInj name
ELit lit -> pure $ ELit lit
ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e)
EApp e1 e2 -> onM EApp reportTEVar e1 e2
EAdd e1 e2 -> onM EAdd reportTEVar e1 e2
EAbs name e -> EAbs name <$> reportTEVar e
EVar name -> pure $ EVar name
EInj name -> pure $ EInj name
ELit lit -> pure $ ELit lit
ELet bind e -> liftA2 ELet (reportTEVar bind) (reportTEVar e)
EApp e1 e2 -> onM EApp reportTEVar e1 e2
EAdd e1 e2 -> onM EAdd reportTEVar e1 e2
EAbs name e -> EAbs name <$> reportTEVar e
ECase e branches -> liftA2 ECase (reportTEVar e) (reportTEVar branches)
instance ReportTEVar (Branch' G.Type) (Branch' Type) where
@ -54,10 +53,10 @@ instance ReportTEVar (Pattern' G.Type, G.Type) (Pattern' Type, Type) where
instance ReportTEVar (Pattern' G.Type) (Pattern' Type) where
reportTEVar = \case
PVar name -> pure $ PVar name
PLit lit -> pure $ PLit lit
PCatch -> pure PCatch
PEnum name -> pure $ PEnum name
PVar name -> pure $ PVar name
PLit lit -> pure $ PLit lit
PCatch -> pure PCatch
PEnum name -> pure $ PEnum name
PInj name ps -> PInj name <$> reportTEVar ps
instance ReportTEVar (Data' G.Type) (Data' Type) where
@ -77,9 +76,9 @@ instance ReportTEVar a b => ReportTEVar [a] [b] where
instance ReportTEVar G.Type Type where
reportTEVar = \case
G.TLit lit -> pure $ TLit (coerce lit)
G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i)
G.TData name typs -> TData (coerce name) <$> reportTEVar typs
G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2)
G.TLit lit -> pure $ TLit (coerce lit)
G.TVar (G.MkTVar i) -> pure $ TVar (MkTVar $ coerce i)
G.TData name typs -> TData (coerce name) <$> reportTEVar typs
G.TFun t1 t2 -> liftA2 TFun (reportTEVar t1) (reportTEVar t2)
G.TAll (G.MkTVar i) t -> TAll (MkTVar $ coerce i) <$> reportTEVar t
G.TEVar tevar -> throwError ("Found TEVar: " ++ printTree tevar)
G.TEVar tevar -> throwError ("Found TEVar: " ++ printTree tevar)