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

Added calling conventions to functions.

Browse source
This commit is contained in:
Samuel Hammersberg 2023-02-24 09:00:29 +01:00
parent 4df3f705ed
commit 5d004f4286
3 changed files with 62 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

23
sample-programs/basic-1
View file

@ -61,6 +61,27 @@ facc a = case a of {
1 => 1, 1 => 1,
_ => posMul a (facc (a - 1)) _ => posMul a (facc (a - 1))
} : Int; } : Int;
-- main : Int;
-- main = facc 5
-- answer: 120
-- pow : Int -> Int -> Int;
-- pow a b = case b of {
-- 0 => 1,
-- _ => posMul a (pow a (b-1))
-- } : Int;
minimization : (Int -> Int) -> Int -> Int;
minimization p x = case p x of {
1 => x,
_ => minimization p (x + 1)
} : Int;
checkFac : Int -> Int;
checkFac x = case facc x of {
0 => 1,
_ => 0
} : Int;
main : Int; main : Int;
main = facc 27 main = minimization checkFac 1

38
src/Compiler.hs
View file

@ -10,7 +10,8 @@ import qualified Data.Map as Map
import Data.Tuple.Extra (dupe, first, second) import Data.Tuple.Extra (dupe, first, second)
import qualified Grammar.Abs as GA import qualified Grammar.Abs as GA
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import LlvmIr (LLVMComp (..), LLVMIr (..), LLVMType (..), import LlvmIr (CallingConvention (..), LLVMComp (..),
LLVMIr (..), LLVMType (..),
LLVMValue (..), Visibility (..), LLVMValue (..), Visibility (..),
llvmIrToString) llvmIrToString)
import TypeChecker (partitionType) import TypeChecker (partitionType)
@ -119,7 +120,7 @@ compileScs (Bind (name, t) args exp : xs) = do
emit $ UnsafeRaw "\n" emit $ UnsafeRaw "\n"
emit . Comment $ show name <> ": " <> show exp emit . Comment $ show name <> ": " <> show exp
let args' = map (second type2LlvmType) args let args' = map (second type2LlvmType) args
emit $ Define I64 {-(type2LlvmType t_return)-} name args' emit $ Define FastCC I64 {-(type2LlvmType t_return)-} name args'
functionBody <- exprToValue exp functionBody <- exprToValue exp
if name == "main" if name == "main"
then mapM_ emit $ mainContent functionBody then mapM_ emit $ mainContent functionBody
@ -182,19 +183,30 @@ emitECased t e cases = do
emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr)) emit $ SetVariable (Ident $ show res) (Load ty Ptr (Ident $ show stackPtr))
where where
emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState () emitCases :: LLVMType -> Ident -> Integer -> LLVMValue -> Case -> CompilerState ()
emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do emitCases ty label stackPtr vs (Case (GA.CInt 0) exp) = do
ns <- getNewVar ns <- getNewVar
lbl_fail <- getNewLabel lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succ <- getNewLabel lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel
let failed = Ident $ "failed_" <> show lbl_fail lbl_failNeg <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel
let success = Ident $ "success_" <> show lbl_succ lbl_succNeg <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel
emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i)) emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger 0))
emit $ BrCond (VIdent (Ident $ show ns) ty) success failed emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos
emit $ Label success emit $ Label lbl_succPos
val <- exprToValue exp val <- exprToValue exp
emit $ Store ty val Ptr (Ident . show $ stackPtr) emit $ Store ty val Ptr (Ident . show $ stackPtr)
emit $ Br label emit $ Br label
emit $ Label failed emit $ Label lbl_failPos
emitCases ty label stackPtr vs (Case (GA.CInt i) exp) = do
ns <- getNewVar
lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel
emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i))
emit $ BrCond (VIdent (Ident $ show ns) ty) lbl_succPos lbl_failPos
emit $ Label lbl_succPos
val <- exprToValue exp
emit $ Store ty val Ptr (Ident . show $ stackPtr)
emit $ Br label
emit $ Label lbl_failPos
emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do emitCases ty label stackPtr _ (Case GA.CatchAll exp) = do
val <- exprToValue exp val <- exprToValue exp
emit $ Store ty val Ptr (Ident . show $ stackPtr) emit $ Store ty val Ptr (Ident . show $ stackPtr)
@ -231,7 +243,7 @@ emitApp t e1 e2 = appEmitter t e1 e2 []
funcs <- gets functions funcs <- gets functions
let visibility = maybe Local (const Global) $ Map.lookup id funcs let visibility = maybe Local (const Global) $ Map.lookup id funcs
args' = map (first valueGetType . dupe) args args' = map (first valueGetType . dupe) args
call = Call (type2LlvmType t) visibility name args' call = Call FastCC (type2LlvmType t) visibility name args'
emit $ SetVariable (Ident $ show vs) call emit $ SetVariable (Ident $ show vs) call
x -> do x -> do
emit . Comment $ "The unspeakable happened: " emit . Comment $ "The unspeakable happened: "
@ -314,7 +326,7 @@ exprToValue = \case
then do then do
vc <- getNewVar vc <- getNewVar
emit $ SetVariable (Ident $ show vc) emit $ SetVariable (Ident $ show vc)
(Call (type2LlvmType t) Global name []) (Call FastCC (type2LlvmType t) Global name [])
pure $ VIdent (Ident $ show vc) (type2LlvmType t) pure $ VIdent (Ident $ show vc) (type2LlvmType t)
else pure $ VFunction name Global (type2LlvmType t) else pure $ VFunction name Global (type2LlvmType t)
Nothing -> pure $ VIdent name (type2LlvmType t) Nothing -> pure $ VIdent name (type2LlvmType t)

21
src/LlvmIr.hs
View file

@ -7,11 +7,20 @@ module LlvmIr (
LLVMValue (..), LLVMValue (..),
LLVMComp (..), LLVMComp (..),
Visibility (..), Visibility (..),
CallingConvention (..)
) where ) where
import Data.List (intercalate) import Data.List (intercalate)
import TypeCheckerIr import TypeCheckerIr
data CallingConvention = TailCC | FastCC | CCC | ColdCC
instance Show CallingConvention where
show :: CallingConvention -> String
show TailCC = "tailcc"
show FastCC = "fastcc"
show CCC = "ccc"
show ColdCC = "coldcc"
-- | A datatype which represents some basic LLVM types -- | A datatype which represents some basic LLVM types
data LLVMType data LLVMType
= I1 = I1
@ -89,7 +98,7 @@ type Args = [(LLVMType, LLVMValue)]
-- | A datatype which represents different instructions in LLVM -- | A datatype which represents different instructions in LLVM
data LLVMIr data LLVMIr
= Define LLVMType Ident Params = Define CallingConvention LLVMType Ident Params
| DefineEnd | DefineEnd
| Declare LLVMType Ident Params | Declare LLVMType Ident Params
| SetVariable Ident LLVMIr | SetVariable Ident LLVMIr
@ -103,7 +112,7 @@ data LLVMIr
| Br Ident | Br Ident
| BrCond LLVMValue Ident Ident | BrCond LLVMValue Ident Ident
| Label Ident | Label Ident
| Call LLVMType Visibility Ident Args | Call CallingConvention LLVMType Visibility Ident Args
| Alloca LLVMType | Alloca LLVMType
| Store LLVMType LLVMValue LLVMType Ident | Store LLVMType LLVMValue LLVMType Ident
| Load LLVMType LLVMType Ident | Load LLVMType LLVMType Ident
@ -134,9 +143,9 @@ llvmIrToString = go 0
insToString :: Int -> LLVMIr -> String insToString :: Int -> LLVMIr -> String
insToString i l = insToString i l =
replicate i '\t' <> case l of replicate i '\t' <> case l of
(Define t (Ident i) params) -> (Define c t (Ident i) params) ->
concat concat
[ "define fastcc ", show t, " @", i [ "define ", show c, " ", show t, " @", i
, "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params) , "(", intercalate ", " (map (\(Ident y, x) -> unwords [show x, "%" <> y]) params)
, ") {\n" , ") {\n"
] ]
@ -168,9 +177,9 @@ llvmIrToString = go 0
[ "srem ", show t, " ", show v1, ", " [ "srem ", show t, " ", show v1, ", "
, show v2, "\n" , show v2, "\n"
] ]
(Call t vis (Ident i) arg) -> (Call c t vis (Ident i) arg) ->
concat concat
[ "call fastcc ", show t, " ", show vis, i, "(" [ "call ", show c, " ", show t, " ", show vis, i, "("
, intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg , intercalate ", " $ Prelude.map (\(x, y) -> show x <> " " <> show y) arg
, ")\n" , ")\n"
] ]