diff --git a/sample-programs/basic-1 b/sample-programs/basic-1 index a88960b..113c8b7 100644 --- a/sample-programs/basic-1 +++ b/sample-programs/basic-1 @@ -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 \ No newline at end of file +main = minimization checkFac 1 \ No newline at end of file diff --git a/src/Compiler.hs b/src/Compiler.hs index bffab3b..7490917 100644 --- a/src/Compiler.hs +++ b/src/Compiler.hs @@ -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) diff --git a/src/LlvmIr.hs b/src/LlvmIr.hs index 68f45f2..7fe40c0 100644 --- a/src/LlvmIr.hs +++ b/src/LlvmIr.hs @@ -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" ]