From e3df4192bbfa19caac41765d9e971eb13aab6d09 Mon Sep 17 00:00:00 2001 From: sebastianselander Date: Thu, 23 Mar 2023 17:20:19 +0100 Subject: [PATCH] created dummy monomorphizer --- language.cabal | 1 - src/Codegen/Codegen.hs | 420 ++++++++++++++++----------- src/LambdaLifter/LambdaLifter.hs | 194 ------------- src/Main.hs | 11 +- src/Monomorphizer/Monomorphizer.hs | 18 +- src/Monomorphizer/MonomorphizerIr.hs | 28 +- 6 files changed, 279 insertions(+), 393 deletions(-) delete mode 100644 src/LambdaLifter/LambdaLifter.hs diff --git a/language.cabal b/language.cabal index a35b5f0..cbb5260 100644 --- a/language.cabal +++ b/language.cabal @@ -34,7 +34,6 @@ executable language TypeChecker.TypeChecker TypeChecker.TypeCheckerIr Renamer.Renamer - LambdaLifter.LambdaLifter Codegen.Codegen Codegen.LlvmIr diff --git a/src/Codegen/Codegen.hs b/src/Codegen/Codegen.hs index a00ec8e..a8c3cfd 100644 --- a/src/Codegen/Codegen.hs +++ b/src/Codegen/Codegen.hs @@ -1,56 +1,69 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Codegen.Codegen (generateCode) where -import Auxiliary (snoc) -import Codegen.LlvmIr (CallingConvention (..), - LLVMComp (..), LLVMIr (..), - LLVMType (..), LLVMValue (..), - Visibility (..), llvmIrToString) -import Codegen.LlvmIr as LIR -import Control.Applicative ((<|>)) -import Control.Monad.State (StateT, execStateT, foldM_, - gets, modify) -import qualified Data.Bifunctor as BI -import Data.List.Extra (trim) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tuple.Extra (dupe, first, second) -import qualified Grammar.Abs as GA -import Grammar.ErrM (Err) -import Monomorphizer.MonomorphizerIr as MIR -import System.Process.Extra (readCreateProcess, shell) + +import Auxiliary (snoc) +import Codegen.LlvmIr ( + CallingConvention (..), + LLVMComp (..), + LLVMIr (..), + LLVMType (..), + LLVMValue (..), + Visibility (..), + llvmIrToString, + ) +import Codegen.LlvmIr as LIR +import Control.Applicative ((<|>)) +import Control.Monad.State ( + StateT, + execStateT, + foldM_, + gets, + modify, + ) +import Data.Bifunctor qualified as BI +import Data.List.Extra (trim) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe (fromJust, fromMaybe) +import Data.Tuple.Extra (dupe, first, second) +import Grammar.Abs qualified as GA +import Grammar.ErrM (Err) +import Monomorphizer.MonomorphizerIr as MIR +import System.Process.Extra (readCreateProcess, shell) + -- | The record used as the code generator state data CodeGenerator = CodeGenerator - { instructions :: [LLVMIr] - , functions :: Map Id FunctionInfo - , constructors :: Map Id ConstructorInfo + { instructions :: [LLVMIr] + , functions :: Map Id FunctionInfo + , constructors :: Map Id ConstructorInfo , variableCount :: Integer - , labelCount :: Integer + , labelCount :: Integer } -- | A state type synonym type CompilerState a = StateT CodeGenerator Err a data FunctionInfo = FunctionInfo - { numArgs :: Int + { numArgs :: Int , arguments :: [Id] - } deriving Show + } + deriving (Show) data ConstructorInfo = ConstructorInfo - { numArgsCI :: Int + { numArgsCI :: Int , argumentsCI :: [Id] - , numCI :: Integer - } deriving Show - + , numCI :: Integer + } + deriving (Show) -- | Adds a instruction to the CodeGenerator state emit :: LLVMIr -> CompilerState () -emit l = modify $ \t -> t { instructions = Auxiliary.snoc l $ instructions t } +emit l = modify $ \t -> t{instructions = Auxiliary.snoc l $ instructions t} -- | Increases the variable counter in the CodeGenerator state increaseVarCount :: CompilerState () -increaseVarCount = modify $ \t -> t { variableCount = variableCount t + 1 } +increaseVarCount = modify $ \t -> t{variableCount = variableCount t + 1} -- | Returns the variable count from the CodeGenerator state getVarCount :: CompilerState Integer @@ -66,76 +79,106 @@ getNewLabel = do modify (\t -> t{labelCount = labelCount t + 1}) gets labelCount --- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. +{- | Produces a map of functions infos from a list of binds, + which contains useful data for code generation. +-} getFunctions :: [Bind] -> Map Id FunctionInfo getFunctions bs = Map.fromList $ go bs where go [] = [] go (Bind id args _ : xs) = - (id, FunctionInfo { numArgs=length args, arguments=args }) - : go xs - go (DataType n cons : xs) = do - map (\(Constructor id xs) -> ((id, MIR.Type n), FunctionInfo { - numArgs=length xs, arguments=createArgs xs - })) cons - <> go xs + (id, FunctionInfo{numArgs = length args, arguments = args}) + : go xs + go (DataType n cons : xs) = + do + map + ( \(Constructor id xs) -> + ( (id, MIR.Type n) + , FunctionInfo + { numArgs = length xs + , arguments = createArgs xs + } + ) + ) + cons + <> go xs createArgs :: [Type] -> [Id] -createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l) , t)],l+1)) ([], 0) xs +createArgs xs = fst $ foldl (\(acc, l) t -> (acc ++ [(GA.Ident ("arg_" <> show l), t)], l + 1)) ([], 0) xs --- | Produces a map of functions infos from a list of binds, --- which contains useful data for code generation. +{- | Produces a map of functions infos from a list of binds, + which contains useful data for code generation. +-} getConstructors :: [Bind] -> Map Id ConstructorInfo getConstructors bs = Map.fromList $ go bs where go [] = [] - go (DataType (GA.Ident n) cons : xs) = do - fst (foldl (\(acc,i) (Constructor (GA.Ident id) xs) -> (((GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)), ConstructorInfo { - numArgsCI=length xs, - argumentsCI=createArgs xs, - numCI=i - }) : acc, i+1)) ([],0) cons) - <> go xs - go (_: xs) = go xs + go (DataType (GA.Ident n) cons : xs) = + do + fst + ( foldl + ( \(acc, i) (Constructor (GA.Ident id) xs) -> + ( ( (GA.Ident (n <> "_" <> id), MIR.Type (GA.Ident n)) + , ConstructorInfo + { numArgsCI = length xs + , argumentsCI = createArgs xs + , numCI = i + } + ) + : acc + , i + 1 + ) + ) + ([], 0) + cons + ) + <> go xs + go (_ : xs) = go xs initCodeGenerator :: [Bind] -> CodeGenerator -initCodeGenerator scs = CodeGenerator { instructions = defaultStart - , functions = getFunctions scs - , constructors = getConstructors scs - , variableCount = 0 - , labelCount = 0 - } +initCodeGenerator scs = + CodeGenerator + { instructions = defaultStart + , functions = getFunctions scs + , constructors = getConstructors scs + , variableCount = 0 + , labelCount = 0 + } run :: Err String -> IO () run s = do let s' = case s of Right s -> s - Left _ -> error "yo" + Left _ -> error "yo" writeFile "output/llvm.ll" s' putStrLn . trim =<< readCreateProcess (shell "lli") s' test :: Integer -> Program -test v = Program - [ DataType (GA.Ident "Craig") [ - Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")], - Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] - ] - , DataType (GA.Ident "Alice") [ - Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")]--, - --(GA.Ident "Alice", [TInt, TInt]) - ] - , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) - , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] - --(EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) - $ eCaseInt (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) - [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) - , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) - , Injection (CIdent (GA.Ident "z")) (int 3) - --, injectionInt 5 (int 6) - , injectionCatchAll (int 10) +test v = + Program + [ DataType + (GA.Ident "Craig") + [ Constructor (GA.Ident "Bob") [MIR.Type (GA.Ident "_Int")] + , Constructor (GA.Ident "Betty") [MIR.Type (GA.Ident "_Int")] ] - ] + , DataType + (GA.Ident "Alice") + [ Constructor (GA.Ident "Eve") [MIR.Type (GA.Ident "_Int")] -- , + -- (GA.Ident "Alice", [TInt, TInt]) + ] + , Bind (GA.Ident "fibonacci", MIR.Type (GA.Ident "_Int")) [(GA.Ident "x", MIR.Type (GA.Ident "_Int"))] (EId ("x", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) + , Bind (GA.Ident "main", MIR.Type (GA.Ident "_Int")) [] + -- (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig"))-- (EInt 92) + $ + eCaseInt + (EApp (MIR.Type (GA.Ident "Craig")) (EId (GA.Ident "Craig_Bob", MIR.Type (GA.Ident "Craig")), MIR.Type (GA.Ident "Craig")) (ELit (LInt v), MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "Craig")) + [ injectionCons "Craig_Bob" "Craig" [CIdent (GA.Ident "x")] (EId (GA.Ident "x", MIR.Type (GA.Ident "_Int")), MIR.Type (GA.Ident "_Int")) + , injectionCons "Craig_Betty" "Craig" [CLit (LInt 5)] (int 2) + , Injection (CIdent (GA.Ident "z")) (int 3) + , -- , injectionInt 5 (int 6) + injectionCatchAll (int 10) + ] + ] where injectionCons x y xs = Injection (CCons (GA.Ident x, MIR.Type (GA.Ident y)) xs) injectionInt x = Injection (CLit (LInt x)) @@ -153,11 +196,12 @@ generateCode (Program scs) = do llvmIrToString . instructions <$> execStateT (compileScs scs) codegen compileScs :: [Bind] -> CompilerState () -compileScs [] = do +compileScs [] = do -- as a last step create all the constructors -- //TODO maybe merge this with the data type match? c <- gets (Map.toList . constructors) - mapM_ (\((id, t), ci) -> do + mapM_ + ( \((id, t), ci) -> do let t' = type2LlvmType t let x = BI.second type2LlvmType <$> argumentsCI ci emit $ Define FastCC t' id x @@ -166,32 +210,47 @@ compileScs [] = do -- allocated the primary type emit $ SetVariable top (Alloca t') - -- set the first byte to the index of the constructor - emit $ SetVariable ptr $ - GetElementPtr t' (Ref t') (VIdent top I8) - I64 (VInteger 0) - I32 (VInteger 0) - emit $ Store I8 (VInteger $ numCI ci ) (Ref I8) ptr + -- set the first byte to the index of the constructor + emit $ + SetVariable ptr $ + GetElementPtr + t' + (Ref t') + (VIdent top I8) + I64 + (VInteger 0) + I32 + (VInteger 0) + emit $ Store I8 (VInteger $ numCI ci) (Ref I8) ptr - -- get a pointer of the correct type + -- get a pointer of the correct type ptr' <- getNewVar emit $ SetVariable ptr' (Bitcast (Ref t') (VIdent top Ptr) (Ref $ CustomType id)) - --emit $ UnsafeRaw "\n" + -- emit $ UnsafeRaw "\n" - enumerateOneM_ (\i (GA.Ident arg_n, arg_t) -> do - let arg_t' = type2LlvmType arg_t - emit $ Comment (toIr arg_t' <>" "<> arg_n <> " " <> show i ) - elemPtr <- getNewVar - emit $ SetVariable elemPtr ( - GetElementPtr (CustomType id) (Ref (CustomType id)) - (VIdent ptr' Ptr) - I64 (VInteger 0) - I32 (VInteger i)) - emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr - ) (argumentsCI ci) + enumerateOneM_ + ( \i (GA.Ident arg_n, arg_t) -> do + let arg_t' = type2LlvmType arg_t + emit $ Comment (toIr arg_t' <> " " <> arg_n <> " " <> show i) + elemPtr <- getNewVar + emit $ + SetVariable + elemPtr + ( GetElementPtr + (CustomType id) + (Ref (CustomType id)) + (VIdent ptr' Ptr) + I64 + (VInteger 0) + I32 + (VInteger i) + ) + emit $ Store arg_t' (VIdent (GA.Ident arg_n) arg_t') Ptr elemPtr + ) + (argumentsCI ci) - --emit $ UnsafeRaw "\n" + -- emit $ UnsafeRaw "\n" -- load and return the constructed value emit $ Comment "Return the newly constructed value" @@ -200,8 +259,9 @@ compileScs [] = do emit $ Ret t' (VIdent load t') emit DefineEnd - modify $ \s -> s { variableCount = 0 } - ) c + modify $ \s -> s{variableCount = 0} + ) + c compileScs (Bind (name, _t) args exp : xs) = do emit $ UnsafeRaw "\n" emit . Comment $ show name <> ": " <> show exp @@ -212,18 +272,20 @@ compileScs (Bind (name, _t) args exp : xs) = do then mapM_ emit $ mainContent functionBody else emit $ Ret I64 functionBody emit DefineEnd - modify $ \s -> s { variableCount = 0 } + modify $ \s -> s{variableCount = 0} compileScs xs compileScs (DataType id@(GA.Ident outer_id) ts : xs) = do let biggestVariant = maximum ((\(Constructor _ t) -> sum $ typeByteSize . type2LlvmType <$> t) <$> ts) emit $ LIR.Type id [I8, Array biggestVariant I8] - mapM_ (\(Constructor (GA.Ident inner_id) fi) -> do + mapM_ + ( \(Constructor (GA.Ident inner_id) fi) -> do emit $ LIR.Type (GA.Ident $ outer_id <> "_" <> inner_id) (I8 : map type2LlvmType fi) - ) ts + ) + ts compileScs xs - -- where - -- _t_return = snd $ partitionType (length args) t +-- where +-- _t_return = snd $ partitionType (length args) t mainContent :: LLVMValue -> [LLVMIr] mainContent var = @@ -233,7 +295,7 @@ mainContent var = -- " %3 = bitcast %Craig* %2 to i72*\n" <> -- " %4 = load i72, ptr %3\n" <> -- " call i32 (ptr, ...) @printf(ptr noundef @.str, i72 noundef %4)\n" - "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" + "call i32 (ptr, ...) @printf(ptr noundef @.str, i64 noundef " <> toIr var <> ")\n" , -- , SetVariable (GA.Ident "p") (Icmp LLEq I64 (VInteger 2) (VInteger 2)) -- , BrCond (VIdent (GA.Ident "p")) (GA.Ident "b_1") (GA.Ident "b_2") -- , Label (GA.Ident "b_1") @@ -249,24 +311,26 @@ mainContent var = ] defaultStart :: [LLVMIr] -defaultStart = [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" - , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" - , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" - , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" - ] +defaultStart = + [ UnsafeRaw "target triple = \"x86_64-pc-linux-gnu\"\n" + , UnsafeRaw "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"\n" + , UnsafeRaw "@.str = private unnamed_addr constant [3 x i8] c\"%x\n\", align 1\n" + , UnsafeRaw "declare i32 @printf(ptr noalias nocapture, ...)\n" + ] compileExp :: Exp -> CompilerState () -compileExp (ELit lit) = emitLit lit -compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst e2) ---compileExp (ESub t e1 e2) = emitSub t e1 e2 -compileExp (EId (name, _)) = emitIdent name -compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) ---compileExp (EAbs t ti e) = emitAbs t ti e +compileExp (ELit lit) = emitLit lit +compileExp (EAdd t e1 e2) = emitAdd t (fst e1) (fst e2) +-- compileExp (ESub t e1 e2) = emitSub t e1 e2 +compileExp (EId (name, _)) = emitIdent name +compileExp (EApp t e1 e2) = emitApp t (fst e1) (fst e2) +-- compileExp (EAbs t ti e) = emitAbs t ti e compileExp (ELet _ binds e) = undefined emitLet binds (fst e) -compileExp (ECase t e cs) = emitECased t e (map (t,) cs) - -- go (EMul e1 e2) = emitMul e1 e2 - -- go (EDiv e1 e2) = emitDiv e1 e2 - -- go (EMod e1 e2) = emitMod e1 e2 +compileExp (ECase t e cs) = emitECased t e (map (t,) cs) + +-- go (EMul e1 e2) = emitMul e1 e2 +-- go (EDiv e1 e2) = emitDiv e1 e2 +-- go (EMod e1 e2) = emitMod e1 e2 --- aux functions --- emitECased :: Type -> ExpT -> [(Type, Injection)] -> CompilerState () @@ -309,31 +373,33 @@ emitECased t e cases = do emit $ SetVariable casted (Load (CustomType (fst consId)) Ptr castedPtr) val <- exprToValue (fst exp) - enumerateOneM_ (\i c -> do + enumerateOneM_ + ( \i c -> do case c of - CIdent x -> do + CIdent x -> do emit . Comment $ "ident " <> show x emit $ SetVariable x (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) emit $ Store ty val Ptr stackPtr CCons x cs -> error "nested constructor" - CLit l -> do + CLit l -> do testVar <- getNewVar emit $ SetVariable testVar (ExtractValue (CustomType (fst consId)) (VIdent casted Ptr) i) case l of - LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) + LInt l -> emit $ Icmp LLEq I64 (VIdent testVar Ptr) (VInteger l) LChar c -> emit $ Icmp LLEq I8 (VIdent testVar Ptr) (VChar c) - CatchAll -> emit . Comment $ "Catch all" + CatchAll -> emit . Comment $ "Catch all" emit . Comment $ "return this " <> toIr val emit . Comment . show $ c emit . Comment . show $ i - ) cs + ) + cs -- emit $ Store ty val Ptr stackPtr emit $ Br label emit $ Label lbl_failPos emitCases rt ty label stackPtr vs (Injection (MIR.CLit i) exp) = do let i' = case i of - LInt i -> VInteger i - LChar i -> VChar i + LInt i -> VInteger i + LChar i -> VChar i ns <- getNewVar lbl_failPos <- (\x -> GA.Ident $ "failed_" <> show x) <$> getNewLabel lbl_succPos <- (\x -> GA.Ident $ "success_" <> show x) <$> getNewLabel @@ -359,7 +425,6 @@ emitECased t e cases = do emit $ Store ty val Ptr stackPtr emit $ Br label - emitLet :: Bind -> Exp -> CompilerState () emitLet xs e = do emit $ @@ -380,18 +445,18 @@ emitApp t e1 e2 = appEmitter t e1 e2 [] let newStack = e2 : stack case e1 of EApp _ (e1', _) (e2', _) -> appEmitter t e1' e2' newStack - EId id@(GA.Ident name,_ ) -> do + EId id@(GA.Ident name, _) -> do args <- traverse exprToValue newStack vs <- getNewVar funcs <- gets functions consts <- gets constructors - let visibility = fromMaybe Local $ - Global <$ Map.lookup id consts - <|> - Global <$ Map.lookup id 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 t) visibility (GA.Ident name) args' + let visibility = + fromMaybe Local $ + Global <$ Map.lookup id consts + <|> Global <$ Map.lookup id 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 t) visibility (GA.Ident name) args' emit $ SetVariable vs call x -> error $ "The unspeakable happened: " <> show x @@ -405,14 +470,13 @@ emitIdent id = do emitLit :: Lit -> CompilerState () emitLit i = do -- !!this should never happen!! - let (i',t) = case i of - (LInt i'') -> (VInteger i'',I64) - (LChar i'') -> (VChar i'', I8) + let (i', t) = case i of + (LInt i'') -> (VInteger i'', I64) + (LChar i'') -> (VChar i'', I8) varCount <- getNewVar emit $ Comment "This should not have happened!" emit $ SetVariable (GA.Ident (show varCount)) (Add t i' (VInteger 0)) - emitAdd :: Type -> Exp -> Exp -> CompilerState () emitAdd t e1 e2 = do v1 <- exprToValue e1 @@ -430,8 +494,8 @@ emitSub t e1 e2 = do exprToValue :: Exp -> CompilerState LLVMValue exprToValue = \case ELit i -> pure $ case i of - (LInt i) -> VInteger i - (LChar i) -> VChar i + (LInt i) -> VInteger i + (LChar i) -> VChar i EId id@(name, t) -> do funcs <- gets functions case Map.lookup id funcs of @@ -439,8 +503,10 @@ exprToValue = \case if numArgs fi == 0 then do vc <- getNewVar - emit $ SetVariable vc - (Call FastCC (type2LlvmType t) Global name []) + emit $ + SetVariable + vc + (Call FastCC (type2LlvmType t) Global name []) pure $ VIdent vc (type2LlvmType t) else pure $ VFunction name Global (type2LlvmType t) Nothing -> pure $ VIdent name (type2LlvmType t) @@ -452,45 +518,45 @@ exprToValue = \case type2LlvmType :: Type -> LLVMType type2LlvmType (MIR.Type (GA.Ident t)) = case t of "_Int" -> I64 - t -> CustomType (GA.Ident t) - -- TInt -> I64 - -- TFun t xs -> do - -- let (t', xs') = function2LLVMType xs [type2LlvmType t] - -- Function t' xs' - -- TPol t -> CustomType t - --where - -- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) - -- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) - -- function2LLVMType x s = (type2LlvmType x, s) + t -> CustomType (GA.Ident t) + +-- TInt -> I64 +-- TFun t xs -> do +-- let (t', xs') = function2LLVMType xs [type2LlvmType t] +-- Function t' xs' +-- TPol t -> CustomType t +-- where +-- function2LLVMType :: Type -> [LLVMType] -> (LLVMType, [LLVMType]) +-- function2LLVMType (TFun t xs) s = function2LLVMType xs (type2LlvmType t : s) +-- function2LLVMType x s = (type2LlvmType x, s) getType :: Exp -> LLVMType -getType (ELit l) = I64 -getType (EAdd t _ _) = type2LlvmType t ---getType (ESub t _ _) = type2LlvmType t -getType (EId (_, t)) = type2LlvmType t -getType (EApp t _ _) = type2LlvmType t ---getType (EAbs t _ _) = type2LlvmType t +getType (ELit l) = I64 +getType (EAdd t _ _) = type2LlvmType t +-- getType (ESub t _ _) = type2LlvmType t +getType (EId (_, t)) = type2LlvmType t +getType (EApp t _ _) = type2LlvmType t +-- getType (EAbs t _ _) = type2LlvmType t getType (ELet (_, t) _ e) = type2LlvmType t -getType (ECase t _ _) = type2LlvmType t +getType (ECase t _ _) = type2LlvmType t valueGetType :: LLVMValue -> LLVMType -valueGetType (VInteger _) = I64 -valueGetType (VChar _) = I8 -valueGetType (VIdent _ t) = t -valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 +valueGetType (VInteger _) = I64 +valueGetType (VChar _) = I8 +valueGetType (VIdent _ t) = t +valueGetType (VConstant s) = Array (fromIntegral $ length s) I8 valueGetType (VFunction _ _ t) = t typeByteSize :: LLVMType -> Integer -typeByteSize I1 = 1 -typeByteSize I8 = 1 -typeByteSize I32 = 4 -typeByteSize I64 = 8 -typeByteSize Ptr = 8 -typeByteSize (Ref _) = 8 +typeByteSize I1 = 1 +typeByteSize I8 = 1 +typeByteSize I32 = 4 +typeByteSize I64 = 8 +typeByteSize Ptr = 8 +typeByteSize (Ref _) = 8 typeByteSize (Function _ _) = 8 -typeByteSize (Array n t) = n * typeByteSize t +typeByteSize (Array n t) = n * typeByteSize t typeByteSize (CustomType _) = 8 enumerateOneM_ :: Monad m => (Integer -> a -> m b) -> [a] -> m () enumerateOneM_ f = foldM_ (\i a -> f i a >> pure (i + 1)) 1 - diff --git a/src/LambdaLifter/LambdaLifter.hs b/src/LambdaLifter/LambdaLifter.hs deleted file mode 100644 index a09f1a7..0000000 --- a/src/LambdaLifter/LambdaLifter.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module LambdaLifter.LambdaLifter where - -import Auxiliary (snoc) -import Control.Applicative (Applicative (liftA2)) -import Control.Monad.State (MonadState (get, put), State, evalState) -import Data.Set (Set) -import Data.Set qualified as Set -import Renamer.Renamer -import TypeChecker.TypeChecker (partitionType) -import TypeChecker.TypeCheckerIr -import Prelude hiding (exp) - -{- | Lift lambdas and let expression into supercombinators. -Three phases: -@freeVars@ annotates all the free variables. -@abstract@ converts lambdas into let expressions. -@collectScs@ moves every non-constant let expression to a top-level function. --} -lambdaLift :: Program -> Program -lambdaLift = collectScs . abstract . freeVars - --- | Annotate free variables -freeVars :: Program -> AnnProgram -freeVars (Program ds) = - [ (n, xs, freeVarsExp (Set.fromList $ map fst xs) e) - | Bind n xs e <- ds - ] - -freeVarsExp :: Set Ident -> ExpT -> AnnExpT -freeVarsExp localVars (exp, t) = case exp of - EId n - | Set.member n localVars -> (Set.singleton n, (AId n, t)) - | otherwise -> (mempty, (AId n, t)) - -- EInt i -> (mempty, AInt i) - ELit lit -> (mempty, (ALit lit, t)) - EApp e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AApp e1' e2', t)) - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 - EAdd e1 e2 -> (Set.union (freeVarsOf e1') (freeVarsOf e2'), (AAdd e1' e2', t)) - where - e1' = freeVarsExp localVars e1 - e2' = freeVarsExp localVars e2 - EAbs par e -> (Set.delete par $ freeVarsOf e', (AAbs par e', t)) - where - e' = freeVarsExp (Set.insert par localVars) e - - -- Sum free variables present in bind and the expression - ELet (Bind (name, t_bind) parms rhs) e -> (Set.union binders_frees e_free, (ALet new_bind e', t)) - where - binders_frees = Set.delete name $ freeVarsOf rhs' - e_free = Set.delete name $ freeVarsOf e' - - rhs' = freeVarsExp e_localVars rhs - new_bind = ABind (name, t_bind) parms rhs' - - e' = freeVarsExp e_localVars e - e_localVars = Set.insert name localVars - -freeVarsOf :: AnnExpT -> Set Ident -freeVarsOf = fst - --- AST annotated with free variables -type AnnProgram = [(Id, [Id], AnnExpT)] - -type AnnExpT = (Set Ident, AnnExpT') - -data ABind = ABind Id [Id] AnnExpT deriving (Show) - -type AnnExpT' = (AnnExp, Type) - -data AnnExp - = AId Ident - | ALit Lit - | ALet ABind AnnExpT - | AApp AnnExpT AnnExpT - | AAdd AnnExpT AnnExpT - | AAbs Ident AnnExpT - 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 $ evalState (mapM go prog) 0 - where - go :: (Id, [Id], AnnExpT) -> State Int Bind - go (name, parms, rhs) = Bind name (parms ++ parms1) <$> abstractExp rhs' - where - (rhs', parms1) = flattenLambdasAnn rhs - -{- | Flatten nested lambdas and collect the parameters -@\x.\y.\z. ae → (ae, [x,y,z])@ --} -flattenLambdasAnn :: AnnExpT -> (AnnExpT, [Id]) -flattenLambdasAnn ae = go (ae, []) - where - go :: (AnnExpT, [Id]) -> (AnnExpT, [Id]) - go ((free, (e, t)), acc) - | AAbs par (free1, e1) <- e - , TFun t_par _ <- t = - go ((Set.delete par free1, e1), snoc (par, t_par) acc) - | otherwise = ((free, (e, t)), acc) - -abstractExp :: AnnExpT -> State Int ExpT -abstractExp (free, (exp, t)) = case exp of - AId n -> pure (EId n, t) - ALit lit -> pure (ELit lit, t) - AApp e1 e2 -> (,t) <$> liftA2 EApp (abstractExp e1) (abstractExp e2) - AAdd e1 e2 -> (,t) <$> liftA2 EAdd (abstractExp e1) (abstractExp e2) - ALet b e -> (,t) <$> liftA2 ELet (go b) (abstractExp e) - where - go (ABind name parms rhs) = do - (rhs', parms1) <- flattenLambdas <$> skipLambdas abstractExp rhs - pure $ Bind name (parms ++ parms1) rhs' - - skipLambdas :: (AnnExpT -> State Int ExpT) -> AnnExpT -> State Int ExpT - skipLambdas f (free, (ae, t)) = case ae of - AAbs par ae1 -> do - ae1' <- skipLambdas f ae1 - pure (EAbs par ae1', t) - _ -> f (free, (ae, t)) - - -- Lift lambda into let and bind free variables - AAbs parm e -> do - i <- nextNumber - rhs <- abstractExp e - - let sc_name = Ident ("sc_" ++ show i) - sc = (ELet (Bind (sc_name, t) vars rhs) (EId sc_name, t), t) - pure $ foldl applyVars sc freeList - where - freeList = Set.toList free - vars = zip names . fst $ partitionType (length names) t - names = snoc parm freeList - applyVars (e, t) name = (EApp (e, t) (EId name, t_var), t_return) - where - (t_var : _, t_return) = partitionType 1 t - -nextNumber :: State Int Int -nextNumber = do - i <- get - put $ succ i - pure i - --- | Collects supercombinators by lifting non-constant 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 :: ExpT -> ([Bind], ExpT) -collectScsExp expT@(exp, typ) = case exp of - EId _ -> ([], expT) - ELit _ -> ([], expT) - EApp e1 e2 -> (scs1 ++ scs2, (EApp e1' e2', typ)) - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - EAdd e1 e2 -> (scs1 ++ scs2, (EAdd e1' e2', typ)) - where - (scs1, e1') = collectScsExp e1 - (scs2, e2') = collectScsExp e2 - EAbs par e -> (scs, (EAbs par e', typ)) - where - (scs, e') = collectScsExp e - - -- Collect supercombinators from bind, the rhss, and the expression. - -- - -- > f = let sc x y = rhs in e - -- - ELet (Bind name parms rhs) e -> - if null parms - then (rhs_scs ++ et_scs, (ELet bind et', snd et')) - else (bind : rhs_scs ++ et_scs, et') - where - bind = Bind name parms rhs' - (rhs_scs, rhs') = collectScsExp rhs - (et_scs, et') = collectScsExp e - --- @\x.\y.\z. e → (e, [x,y,z])@ -flattenLambdas :: ExpT -> (ExpT, [Id]) -flattenLambdas = go . (,[]) - where - go ((e, t), acc) = case e of - EAbs name e1 -> go (e1, snoc (name, t_var) acc) - where - t_var : _ = fst $ partitionType 1 t - _ -> ((e, t), acc) diff --git a/src/Main.hs b/src/Main.hs index edb3eea..ba7578c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,17 +2,16 @@ module Main where --- import Codegen.Codegen (generateCode) +import Codegen.Codegen (generateCode) import GHC.IO.Handle.Text (hPutStrLn) import Grammar.ErrM (Err) import Grammar.Par (myLexer, pProgram) import Grammar.Print (printTree) +import Monomorphizer.Monomorphizer (monomorphize) --- import Interpreter (interpret) import Control.Monad (when) import Data.List.Extra (isSuffixOf) --- import LambdaLifter.LambdaLifter (lambdaLift) import Renamer.Renamer (rename) import System.Directory ( createDirectory, @@ -54,9 +53,9 @@ main' debug s = do -- let lifted = lambdaLift typechecked -- printToErr $ printTree lifted -- - -- printToErr "\n -- Printing compiler output to stdout --" - -- compiled <- fromCompilerErr $ generateCode lifted - -- putStrLn compiled + printToErr "\n -- Printing compiler output to stdout --" + compiled <- fromCompilerErr $ generateCode (monomorphize typechecked) + putStrLn compiled -- check <- doesPathExist "output" -- when check (removeDirectoryRecursive "output") diff --git a/src/Monomorphizer/Monomorphizer.hs b/src/Monomorphizer/Monomorphizer.hs index 58a0abc..69cfa35 100644 --- a/src/Monomorphizer/Monomorphizer.hs +++ b/src/Monomorphizer/Monomorphizer.hs @@ -1 +1,17 @@ -module Monomorphizer.Monomorphizer where +module Monomorphizer.Monomorphizer (monomorphize) where + +import Monomorphizer.MonomorphizerIr +import TypeChecker.TypeCheckerIr qualified as T + +monomorphize :: T.Program -> Program +monomorphize (T.Program ds) = Program $ monoDefs ds + +monoDefs :: [T.Def] -> [Def] +monoDefs = map monoDef + +monoDef :: T.Def -> Def +monoDef (T.DBind bind) = DBind $ monoBind bind +monoDef (T.DData d) = DData d + +monoBind :: T.Bind -> Bind +monoBind (T.Bind name args e) = Bind name args e diff --git a/src/Monomorphizer/MonomorphizerIr.hs b/src/Monomorphizer/MonomorphizerIr.hs index 606a719..8f75f71 100644 --- a/src/Monomorphizer/MonomorphizerIr.hs +++ b/src/Monomorphizer/MonomorphizerIr.hs @@ -1,14 +1,19 @@ module Monomorphizer.MonomorphizerIr where -import Grammar.Abs (Ident) -newtype Program = Program [Bind] +import Grammar.Abs (Data, Ident, Init) +import TypeChecker.TypeCheckerIr (ExpT, Id, Indexed) + +newtype Program = Program [Def] deriving (Show, Ord, Eq) -data Bind = Bind Id [Id] ExpT | DataType Ident [Constructor] +data Def = DBind Bind | DData Data + deriving (Show, Ord, Eq) + +data Bind = Bind Id [Id] ExpT deriving (Show, Ord, Eq) data Exp - = EId Id + = EId Id | ELit Lit | ELet Id ExpT ExpT | EApp Type ExpT ExpT @@ -16,20 +21,15 @@ data Exp | ECase Type ExpT [Injection] deriving (Show, Ord, Eq) -data Injection = Injection Case ExpT - deriving (Show, Ord, Eq) - -data Case = CLit Lit | CCons Id [Case] | CIdent Ident | CatchAll - deriving (Show, Ord, Eq) +data Injection = Injection (Init, Type) ExpT + deriving (Eq, Ord, Show) data Constructor = Constructor Ident [Type] deriving (Show, Ord, Eq) -type Id = (Ident, Type) -type ExpT = (Exp, Type) - -data Lit = LInt Integer - | LChar Char +data Lit + = LInt Integer + | LChar Char deriving (Show, Ord, Eq) newtype Type = Type Ident