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,
_ => posMul a (facc (a - 1))
} : 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 = 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 qualified Grammar.Abs as GA
import Grammar.ErrM (Err)
import LlvmIr (LLVMComp (..), LLVMIr (..), LLVMType (..),
import LlvmIr (CallingConvention (..), LLVMComp (..),
LLVMIr (..), LLVMType (..),
LLVMValue (..), Visibility (..),
llvmIrToString)
import TypeChecker (partitionType)
@ -119,7 +120,7 @@ compileScs (Bind (name, t) args exp : xs) = do
emit $ UnsafeRaw "\n"
emit . Comment $ show name <> ": " <> show exp
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
if name == "main"
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))
where
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
lbl_fail <- getNewLabel
lbl_succ <- getNewLabel
let failed = Ident $ "failed_" <> show lbl_fail
let success = Ident $ "success_" <> show lbl_succ
emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger i))
emit $ BrCond (VIdent (Ident $ show ns) ty) success failed
emit $ Label success
lbl_failPos <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succPos <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel
lbl_failNeg <- (\x -> Ident $ "failed_" <> show x) <$> getNewLabel
lbl_succNeg <- (\x -> Ident $ "success_" <> show x) <$> getNewLabel
emit $ SetVariable (Ident $ show ns) (Icmp LLEq ty vs (VInteger 0))
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 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
val <- exprToValue exp
emit $ Store ty val Ptr (Ident . show $ stackPtr)
@ -231,7 +243,7 @@ emitApp t e1 e2 = appEmitter t e1 e2 []
funcs <- gets functions
let visibility = maybe Local (const Global) $ Map.lookup id funcs
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
x -> do
emit . Comment $ "The unspeakable happened: "
@ -314,7 +326,7 @@ exprToValue = \case
then do
vc <- getNewVar
emit $ SetVariable (Ident $ show vc)
(Call (type2LlvmType t) Global name [])
(Call FastCC (type2LlvmType t) Global name [])
pure $ VIdent (Ident $ show vc) (type2LlvmType t)
else pure $ VFunction name Global (type2LlvmType t)
Nothing -> pure $ VIdent name (type2LlvmType t)

21
src/LlvmIr.hs
View file

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