kempe 0.2.0.8 → 0.2.0.9
raw patch · 26 files changed
+264/−41 lines, 26 filesdep ~prettyprinterPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependency ranges changed: prettyprinter
API changes (from Hackage documentation)
+ Kempe.AST: ArmAbi :: ABI
+ Kempe.AST: Hooked :: ABI
+ Kempe.File: cDeclFile :: FilePath -> IO [CFunc]
+ Kempe.File: dumpCDecl :: FilePath -> IO ()
+ Kempe.Lexer: KwArmAbi :: Keyword
+ Kempe.Lexer: KwHooked :: Keyword
+ Language.C.AST: CBool :: CType
+ Language.C.AST: CFunc :: !Text -> [CType] -> CType -> CFunc
+ Language.C.AST: CInt :: CType
+ Language.C.AST: CInt8 :: CType
+ Language.C.AST: CUInt64 :: CType
+ Language.C.AST: CVoid :: CType
+ Language.C.AST: CVoidPtr :: CType
+ Language.C.AST: cSettings :: LayoutOptions
+ Language.C.AST: data CFunc
+ Language.C.AST: data CType
+ Language.C.AST: instance GHC.Classes.Eq Language.C.AST.CHeader
+ Language.C.AST: instance GHC.Classes.Ord Language.C.AST.CHeader
+ Language.C.AST: instance Prettyprinter.Internal.Pretty Language.C.AST.CFunc
+ Language.C.AST: instance Prettyprinter.Internal.Pretty Language.C.AST.CType
+ Language.C.AST: prettyHeaders :: [CFunc] -> Doc ann
Files
- CHANGELOG.md +7/−1
- docs/manual.pdf binary
- examples/factorial.kmp +2/−2
- golden/CDecl.hs +24/−0
- golden/Golden.hs +5/−0
- golden/Harness.hs +0/−1
- kempe.cabal +13/−5
- lib/numbertheory.kmp +2/−2
- run/Main.hs +21/−4
- src/Kempe/AST/Size.hs +6/−2
- src/Kempe/Asm/Arm/Trans.hs +20/−2
- src/Kempe/Asm/X86/Trans.hs +8/−0
- src/Kempe/CGen.hs +36/−0
- src/Kempe/File.hs +14/−0
- src/Kempe/Lexer.x +6/−0
- src/Kempe/Parser.y +4/−0
- src/Language/C/AST.hs +62/−0
- test/examples/bool.kmp +2/−2
- test/examples/const.kmp +1/−1
- test/examples/splitmix.kmp +1/−1
- test/harness/bool.c +7/−5
- test/harness/const.c +4/−2
- test/harness/factorial.c +6/−4
- test/harness/numbertheory.c +7/−5
- test/harness/splitmix.c +4/−2
- test/include/splitmix.h +2/−0
CHANGELOG.md view
@@ -1,5 +1,11 @@ # kempe +## 0.2.0.9++ * Add `armabi` method of exporting Kempe functions, so that `kc` generates+ suitable code for M1 darwin.+ * Add `cdecl` subcommand to generate C headers for exported functions+ ## 0.2.0.8 * More efficient IR generation; don't copy bytes from a source to the same@@ -20,7 +26,7 @@ * Add `absInt` and `chocie` functions to prelude. * Add lints for `swap >`, `swap *` &c. * Fix bug in typing `>=`, `>`, `!=`- + ## 0.2.0.5 * Fix bug in arm control-flow analysis
docs/manual.pdf view
binary file changed (215432 → 217165 bytes)
examples/factorial.kmp view
@@ -17,5 +17,5 @@ , dup 1 - fac * ) ] -%foreign cabi fac-%foreign cabi fac_tailrec+%foreign armabi fac+%foreign armabi fac_tailrec
+ golden/CDecl.hs view
@@ -0,0 +1,24 @@+module CDecl ( goldenCDecl+ ) where++import qualified Data.ByteString.Lazy as BSL+import Data.Text.Lazy.Encoding (encodeUtf8)+import Kempe.File+import Language.C.AST+import Prettyprinter (Doc, LayoutOptions (..), PageWidth (..), layoutSmart)+import Prettyprinter.Render.Text (renderLazy)+import Test.Tasty (TestTree)+import Test.Tasty.Golden (goldenVsString)++renderBSL :: Doc ann -> BSL.ByteString+renderBSL = encodeUtf8 . renderLazy . layoutSmart cSettings where++compileOutput :: FilePath+ -> IO BSL.ByteString+compileOutput = fmap (renderBSL . prettyHeaders) . cDeclFile++goldenCDecl :: FilePath -- ^ Kempe file+ -> FilePath -- ^ Golden header file+ -> TestTree+goldenCDecl kFp golden =+ goldenVsString kFp golden (compileOutput kFp)
golden/Golden.hs view
@@ -1,5 +1,6 @@ module Main (main) where +import CDecl import Data.Tuple.Extra (uncurry3) import Harness import System.Info (arch)@@ -9,6 +10,7 @@ main = defaultMain $ testGroup "Golden output tests" $ fmap (uncurry3 goldenOutput) allGoldens ++ crossTests+ ++ fmap (uncurry goldenCDecl) headerGoldens -- These are redundant on arm crossTests :: [TestTree]@@ -16,6 +18,9 @@ "x86_64" -> fmap (uncurry3 crossGolden) allGoldens "aarch64" -> [] _ -> error "Test suite must be run on x86_64 or aarch64"++headerGoldens :: [(FilePath, FilePath)]+headerGoldens = [ ("test/examples/splitmix.kmp", "test/include/splitmix.h") ] allGoldens :: [(FilePath, FilePath, FilePath)] allGoldens =
golden/Harness.hs view
@@ -12,7 +12,6 @@ import System.Process (CreateProcess (env, std_err), StdStream (Inherit), proc, readCreateProcess) import Test.Tasty import Test.Tasty.Golden (goldenVsString)-import Test.Tasty.HUnit (assertBool, testCase) data CC = CC | ArmCC
kempe.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: kempe-version: 0.2.0.8+version: 0.2.0.9 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2020-2021 Vanessa McHale@@ -17,6 +17,7 @@ test/examples/*.kmp test/golden/*.out test/golden/*.ir+ test/include/*.h test/harness/*.c examples/*.kmp prelude/*.kmp@@ -59,6 +60,7 @@ Kempe.Asm.Arm.Trans Kempe.Asm.Arm.ControlFlow Kempe.Asm.Arm.Linear+ Language.C.AST hs-source-dirs: src other-modules:@@ -77,6 +79,7 @@ Kempe.Asm.Pretty Kempe.IR.Type Kempe.IR.Monad+ Kempe.CGen Kempe.Proc.Nasm Kempe.Proc.As Kempe.Debug@@ -152,7 +155,8 @@ optparse-applicative, kempe-modules, prettyprinter >=1.7.0,- bytestring+ bytestring,+ text if impl(ghc >=8.0) ghc-options:@@ -210,7 +214,10 @@ type: exitcode-stdio-1.0 main-is: Golden.hs hs-source-dirs: golden- other-modules: Harness+ other-modules:+ Harness+ CDecl+ default-language: Haskell2010 ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall build-depends:@@ -222,8 +229,9 @@ temporary, filepath, tasty-golden,- tasty-hunit,- extra+ extra,+ prettyprinter,+ text if impl(ghc >=8.0) ghc-options:
lib/numbertheory.kmp view
@@ -35,5 +35,5 @@ k_gcd : Int Int -- Int =: [ gcd ] -%foreign cabi k_gcd-%foreign cabi is_prime+%foreign armabi k_gcd+%foreign armabi is_prime
run/Main.hs view
@@ -4,15 +4,17 @@ import Control.Monad ((<=<)) import qualified Data.ByteString.Lazy as BSL import Data.Semigroup ((<>))+import qualified Data.Text.Lazy.IO as TLIO import qualified Data.Version as V import Kempe.AST import Kempe.File import Kempe.Lexer import Kempe.Parser+import Language.C.AST import Options.Applicative import qualified Paths_kempe as P import Prettyprinter (LayoutOptions (LayoutOptions), PageWidth (AvailablePerLine), hardline, layoutSmart)-import Prettyprinter.Render.Text (renderIO)+import Prettyprinter.Render.Text (putDoc, renderIO, renderLazy) import System.Exit (ExitCode (ExitFailure), exitWith) import System.IO (stdout) import System.Info (arch)@@ -24,7 +26,16 @@ | Compile !FilePath !(Maybe FilePath) !Arch !Bool !Bool !Bool | Format !FilePath | Lint !FilePath+ | CDecl !FilePath !(Maybe FilePath) +cdecl :: FilePath -> IO ()+cdecl = putDoc . (<> hardline) . prettyHeaders <=< cDeclFile++writeCDecl :: FilePath -> FilePath -> IO ()+writeCDecl fp o = do+ ds <- cDeclFile fp+ TLIO.writeFile o (renderLazy $ layoutSmart cSettings $ prettyHeaders ds)+ fmt :: FilePath -> IO () fmt = renderIO stdout <=< fmap (render . (<> hardline) . prettyModule) . parsedFp where render = layoutSmart settings@@ -48,6 +59,8 @@ run (Compile fp Nothing X64 False False True) = x86File fp run (Compile fp Nothing Aarch64 False False True) = armFile fp run (Format fp) = fmt fp+run (CDecl fp Nothing) = cdecl fp+run (CDecl fp (Just o)) = writeCDecl fp o run _ = putStrLn "Invalid combination of CLI options. Try kc --help" *> exitWith (ExitFailure 1) kmpFile :: Parser FilePath@@ -62,6 +75,9 @@ lintP :: Parser Command lintP = Lint <$> kmpFile +cdeclP :: Parser Command+cdeclP = CDecl <$> kmpFile <*> outFile+ debugSwitch :: Parser Bool debugSwitch = switch (long "debug"@@ -96,8 +112,8 @@ (long "dump-asm" <> help "Write assembly (intel syntax) to stdout") -exeFile :: Parser (Maybe FilePath)-exeFile = optional $ argument str+outFile :: Parser (Maybe FilePath)+outFile = optional $ argument str (metavar "OUTPUT" <> help "File output") @@ -109,10 +125,11 @@ (command "typecheck" (info tcP (progDesc "Type-check module contents")) <> command "lint" (info lintP (progDesc "Lint a file"))) <|> hsubparser (command "fmt" (info fmtP (progDesc "Pretty-print a Kempe file")) <> internal)+ <|> hsubparser (command "cdecl" (info cdeclP (progDesc "Generate C headers for exported Kempe code"))) <|> compileP where tcP = TypeCheck <$> kmpFile- compileP = Compile <$> kmpFile <*> exeFile <*> archFlag <*> debugSwitch <*> irSwitch <*> asmSwitch+ compileP = Compile <$> kmpFile <*> outFile <*> archFlag <*> debugSwitch <*> irSwitch <*> asmSwitch wrapper :: ParserInfo Command wrapper = info (helper <*> versionMod <*> commandP)
src/Kempe/AST/Size.hs view
@@ -69,11 +69,15 @@ data ABI = Cabi | Kabi+ | Hooked+ | ArmAbi deriving (Eq, Ord, Generic, NFData) instance Pretty ABI where- pretty Cabi = "cabi"- pretty Kabi = "kabi"+ pretty Cabi = "cabi"+ pretty Kabi = "kabi"+ pretty Hooked = "hooked"+ pretty ArmAbi = "armabi" -- machinery for assigning a constructor to a function of its concrete types -- (and then curry forward...)
src/Kempe/Asm/Arm/Trans.hs view
@@ -4,13 +4,16 @@ ) where import Data.Bits (rotateR, (.&.))+import qualified Data.ByteString as BS import Data.Foldable.Ext (foldMapA) import Data.Int (Int64) import Data.List (scanl')+import Data.Semigroup ((<>)) import Kempe.AST.Size import Kempe.Asm.Arm.Type import Kempe.IR.Monad import qualified Kempe.IR.Type as IR+import System.Info (arch, os) irToAarch64 :: SizeEnv -> IR.WriteSt -> [IR.Stmt] -> [Arm AbsReg ()] irToAarch64 env w = runWriteM w . foldMapA (irEmit env)@@ -36,18 +39,33 @@ popLink :: [Arm AbsReg ()] popLink = [Load () LinkReg (Reg StackPtr), AddRC () StackPtr StackPtr 16] +-- darwin on arm requires _ prepended to export+darwinExport :: BS.ByteString -> BS.ByteString+darwinExport = case (os, arch) of+ ("darwin", "aarch64") -> ("_" <>)+ _ -> id+ irEmit :: SizeEnv -> IR.Stmt -> WriteM [Arm AbsReg ()] irEmit _ (IR.Jump l) = pure [Branch () l] irEmit _ IR.Ret = pure [Ret ()] irEmit _ (IR.KCall l) = pure (pushLink ++ BranchLink () l : popLink) -- TODO: think more? irEmit _ (IR.Labeled l) = pure [Label () l]-irEmit _ (IR.WrapKCall Kabi (_, _) n l) = pure $ [BSLabel () n] ++ pushLink ++ [BranchLink () l] ++ popLink ++ [Ret ()]+irEmit _ (IR.WrapKCall Kabi (_, _) n l) = pure $ [BSLabel () (darwinExport n)] ++ pushLink ++ [BranchLink () l] ++ popLink ++ [Ret ()]+irEmit _ (IR.WrapKCall Hooked (_, _) n l) =+ pure $ [MovRR () DataPointer CArg0, BSLabel () n] ++ pushLink ++ [BranchLink () l] ++ popLink ++ [Ret ()] irEmit env (IR.WrapKCall Cabi (is, [o]) n l) | all (\i -> size' env i <= 8) is && size' env o <= 8 && length is <= 8 = do { let sizes = fmap (size' env) is ; let offs = scanl' (+) 0 sizes ; let totalSize = sizeStack env is ; let argRegs = [CArg0, CArg1, CArg2, CArg3, CArg4, CArg5, CArg6, CArg7]- ; pure $ [BSLabel () n] ++ pushLink ++ [LoadLabel () DataPointer "kempe_data", GnuMacro () "calleesave"] ++ zipWith3 (\r sz i -> storeSize sz r (AddRCPlus DataPointer i)) argRegs sizes offs ++ [AddRC () DataPointer DataPointer totalSize, BranchLink () l, loadSize (size' env o) CArg0 (AddRCPlus DataPointer (negate $ size' env o)), GnuMacro () "calleerestore"] ++ popLink ++ [Ret ()]+ ; pure $ [BSLabel () (darwinExport n)] ++ pushLink ++ [LoadLabel () DataPointer "kempe_data", GnuMacro () "calleesave"] ++ zipWith3 (\r sz i -> storeSize sz r (AddRCPlus DataPointer i)) argRegs sizes offs ++ [AddRC () DataPointer DataPointer totalSize, BranchLink () l, loadSize (size' env o) CArg0 (AddRCPlus DataPointer (negate $ size' env o)), GnuMacro () "calleerestore"] ++ popLink ++ [Ret ()]+ }+irEmit env (IR.WrapKCall ArmAbi (is, [o]) n l) | all (\i -> size' env i <= 8) is && size' env o <= 8 && length is <= 8 = do+ { let sizes = fmap (size' env) is+ ; let offs = scanl' (+) 0 sizes+ ; let totalSize = sizeStack env is+ ; let argRegs = [CArg1, CArg2, CArg3, CArg4, CArg5, CArg6, CArg7]+ ; pure $ [BSLabel () (darwinExport n)] ++ pushLink ++ [MovRR () DataPointer CArg0, GnuMacro () "calleesave"] ++ zipWith3 (\r sz i -> storeSize sz r (AddRCPlus DataPointer i)) argRegs sizes offs ++ [AddRC () DataPointer DataPointer totalSize, BranchLink () l, loadSize (size' env o) CArg0 (AddRCPlus DataPointer (negate $ size' env o)), GnuMacro () "calleerestore"] ++ popLink ++ [Ret ()] } irEmit _ (IR.MovMem (IR.Reg r) 8 (IR.Reg r')) = pure [Store () (toAbsReg r') (Reg $ toAbsReg r)]
src/Kempe/Asm/X86/Trans.hs view
@@ -127,8 +127,16 @@ ; let argRegs = [CArg1, CArg2, CArg3, CArg4, CArg5, CArg6] ; pure $ [BSLabel () n, MovRL () DataPointer "kempe_data", NasmMacro0 () "calleesave"] ++ zipWith (\r i-> MovAR () (AddrRCPlus DataPointer i) r) argRegs offs ++ [AddRC () DataPointer totalSize, Call () l, MovRA () CRet (AddrRCMinus DataPointer (size' env o)), NasmMacro0 () "calleerestore", Ret ()] -- TODO: bytes on the stack eh }+irEmit env (IR.WrapKCall ArmAbi (is, [o]) n l) | all (\i -> size' env i <= 8) is && size' env o <= 8 && length is <= 6 = do+ { let offs = scanl' (+) 0 (fmap (size' env) is)+ ; let totalSize = sizeStack env is+ ; let argRegs = [CArg2, CArg3, CArg4, CArg5, CArg6]+ ; pure $ [BSLabel () n, MovRR () DataPointer CArg1, NasmMacro0 () "calleesave"] ++ zipWith (\r i-> MovAR () (AddrRCPlus DataPointer i) r) argRegs offs ++ [AddRC () DataPointer totalSize, Call () l, MovRA () CRet (AddrRCMinus DataPointer (size' env o)), NasmMacro0 () "calleerestore", Ret ()] -- TODO: bytes on the stack eh+ } irEmit _ (IR.WrapKCall Kabi (_, _) n l) = pure [BSLabel () n, Call () l, Ret ()]+irEmit _ (IR.WrapKCall Hooked (_, _) n l) =+ pure [MovRR () DataPointer CArg1, BSLabel () n, Call () l, Ret ()] irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ConstInt8 i)) = pure [ MovACi8 () (Reg $ toAbsReg r) i ] -- see: https://github.com/cirosantilli/x86-assembly-cheat/blob/master/x86-64/movabs.asm for why we don't do this ^ for words
+ src/Kempe/CGen.hs view
@@ -0,0 +1,36 @@+module Kempe.CGen ( cGen+ ) where++import Data.Maybe (mapMaybe)+import Kempe.AST+import Kempe.Name+import Language.C.AST++cGen :: Declarations a c (StackType ()) -> [CFunc]+cGen = mapMaybe cDecl++cDecl :: KempeDecl a c (StackType ()) -> Maybe CFunc+cDecl ExtFnDecl{} = Nothing+cDecl TyDecl{} = Nothing+cDecl FunDecl{} = Nothing+cDecl (Export _ Cabi (Name n _ (StackType _ [] []))) = Just (CFunc n [CVoid] CVoid)+cDecl (Export _ Cabi (Name n _ (StackType _ [] [o]))) = Just (CFunc n [CVoid] (kempeTyToCType o))+cDecl (Export _ Cabi (Name n _ (StackType _ ins []))) = Just (CFunc n (kempeTyToCType <$> ins) CVoid)+cDecl (Export _ Cabi (Name n _ (StackType _ ins [o]))) = Just (CFunc n (kempeTyToCType <$> ins) (kempeTyToCType o))+cDecl (Export _ Cabi _) = error "Multiple return not suppported :("+cDecl (Export _ ArmAbi (Name n _ (StackType _ [] []))) = Just (CFunc n [CVoidPtr] CVoid)+cDecl (Export _ ArmAbi (Name n _ (StackType _ [] [o]))) = Just (CFunc n [CVoidPtr] (kempeTyToCType o))+cDecl (Export _ ArmAbi (Name n _ (StackType _ ins []))) = Just (CFunc n (CVoidPtr : fmap kempeTyToCType ins) CVoid)+cDecl (Export _ ArmAbi (Name n _ (StackType _ ins [o]))) = Just (CFunc n (CVoidPtr : fmap kempeTyToCType ins) (kempeTyToCType o))+cDecl (Export _ ArmAbi _) = error "Multiple return not suppported :("+cDecl (Export _ Hooked (Name n _ _)) = Just (CFunc n [CVoidPtr] CVoid)+cDecl (Export _ Kabi _) = error "You probably don't want to do this."++kempeTyToCType :: KempeTy a -> CType+kempeTyToCType (TyBuiltin _ TyInt) = CInt+kempeTyToCType (TyBuiltin _ TyBool) = CBool+kempeTyToCType (TyBuiltin _ TyWord) = CUInt64+kempeTyToCType (TyBuiltin _ TyInt8) = CInt8+kempeTyToCType TyVar{} = error "Don't do that"+kempeTyToCType TyApp{} = error "User-defined types cannot be exported :("+kempeTyToCType TyNamed{} = error "User-defined types cannot be exported :("
src/Kempe/File.hs view
@@ -2,6 +2,8 @@ , warnFile , dumpMono , dumpTyped+ , dumpCDecl+ , cDeclFile , irFile , x86File , armFile@@ -16,6 +18,7 @@ import Control.Applicative ((<|>)) import Control.Composition ((.*)) import Control.Exception (Exception, throwIO)+import Control.Monad ((<=<)) import Data.Bifunctor (bimap) import Data.Functor (void) import Data.Semigroup ((<>))@@ -25,6 +28,7 @@ import Kempe.AST import qualified Kempe.Asm.Arm.Type as Arm import qualified Kempe.Asm.X86.Type as X86+import Kempe.CGen import Kempe.Check.Lint import Kempe.Check.Pattern import Kempe.Check.TopLevel@@ -37,6 +41,7 @@ import qualified Kempe.Proc.Nasm as Nasm import Kempe.Shuttle import Kempe.TyAssign+import Language.C.AST import Prettyprinter (Doc, hardline) import Prettyprinter.Render.Text (putDoc) @@ -54,6 +59,15 @@ yeetIO :: Exception e => Either e a -> IO a yeetIO = either throwIO pure++cDeclFile :: FilePath -> IO [CFunc]+cDeclFile fp = do+ (i, m) <- parseProcess fp+ (mTyped, _) <- yeetIO $ runTypeM i (assignModule m)+ pure $ cGen mTyped++dumpCDecl :: FilePath -> IO ()+dumpCDecl = putDoc . prettyHeaders <=< cDeclFile dumpTyped :: FilePath -> IO () dumpTyped fp = do
src/Kempe/Lexer.x view
@@ -111,6 +111,8 @@ "%foreign" { mkKw KwForeign } "cabi" { mkKw KwCabi } "kabi" { mkKw KwKabi }+ "hooked" { mkKw KwHooked }+ "armabi" { mkKw KwArmAbi } -- builtin dip { mkBuiltin BuiltinDip }@@ -288,6 +290,8 @@ | KwForeign | KwCabi | KwKabi+ | KwHooked+ | KwArmAbi deriving (Generic, NFData) instance Pretty Keyword where@@ -299,6 +303,8 @@ pretty KwForeign = "%foreign" pretty KwCabi = "cabi" pretty KwKabi = "kabi"+ pretty KwHooked = "hooked"+ pretty KwArmAbi = "armabi" data Builtin = BuiltinBool | BuiltinBoolLit { bool :: !Bool }
src/Kempe/Parser.y view
@@ -89,6 +89,8 @@ foreign { TokKeyword $$ KwForeign } cabi { TokKeyword $$ KwCabi } kabi { TokKeyword $$ KwKabi }+ hooked { TokKeyword $$ KwHooked }+ armabi { TokKeyword $$ KwArmAbi } import { TokKeyword $$ KwImport } dip { TokBuiltin $$ BuiltinDip }@@ -139,6 +141,8 @@ ABI :: { ABI } : cabi { Cabi } | kabi { Kabi }+ | hooked { Hooked }+ | armabi { ArmAbi } Decl :: { KempeDecl AlexPosn AlexPosn AlexPosn } : TyDecl { $1 }
+ src/Language/C/AST.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.C.AST ( CType (..)+ , CFunc (..)+ , prettyHeaders+ , cSettings+ ) where++import Data.Semigroup ((<>))+import qualified Data.Set as S+import qualified Data.Text as T+import Prettyprinter (Doc, LayoutOptions (..), PageWidth (..), Pretty (..), tupled, (<+>))+import Prettyprinter.Ext++cSettings :: LayoutOptions+cSettings = LayoutOptions $ AvailablePerLine 180 0.8++data CHeader = StdBool -- ^ @stdbool.h@+ | StdInt -- ^ @stdint.h@+ deriving (Eq, Ord)++prettyInclude :: CHeader -> Doc ann+prettyInclude StdBool = "#include <stdbool.h>"+prettyInclude StdInt = "#include <stdint.h>"++data CType = CInt+ | CBool+ | CUInt64+ | CInt8+ | CVoid+ | CVoidPtr+ -- ADTs etc.++data CFunc = CFunc !T.Text [CType] CType++prettyHeaders :: [CFunc] -> Doc ann+prettyHeaders es =+ let hs = foldMap mentionedFunc es+ in prettyLines (fmap prettyInclude (S.toList hs))+ <#> prettyLines (fmap pretty es)++mentioned :: CType -> S.Set CHeader+mentioned CInt = mempty+mentioned CBool = S.singleton StdBool+mentioned CUInt64 = S.singleton StdInt+mentioned CVoid = mempty+mentioned CVoidPtr = mempty+mentioned CInt8 = S.singleton StdInt++mentionedFunc :: CFunc -> S.Set CHeader+mentionedFunc (CFunc _ args ret) = foldMap mentioned (ret : args)++instance Pretty CType where+ pretty CInt = "int"+ pretty CBool = "bool"+ pretty CUInt64 = "uint64_t"+ pretty CVoid = "void"+ pretty CVoidPtr = "void*"+ pretty CInt8 = "int8_t"++instance Pretty CFunc where+ pretty (CFunc fname args retType) = "extern" <+> pretty retType <+> pretty fname <+> tupled (pretty <$> args) <> ";"
test/examples/bool.kmp view
@@ -15,5 +15,5 @@ nor : Bool Bool -- Bool =: [ || not ] -%foreign cabi not-%foreign cabi eq+%foreign armabi not+%foreign armabi eq
test/examples/const.kmp view
@@ -1,4 +1,4 @@ id_int : Int -- Int =: [ ] -%foreign cabi id_int+%foreign armabi id_int
test/examples/splitmix.kmp view
@@ -8,4 +8,4 @@ from_seed : Word -- Word =: [ next dip(drop) ] -%foreign cabi from_seed+%foreign armabi from_seed
test/harness/bool.c view
@@ -1,11 +1,13 @@ #include <stdbool.h> #include <stdio.h>+#include <stdlib.h> -extern bool not(bool);-extern bool eq(bool, bool);+extern bool not(void*, bool);+extern bool eq(void*, bool, bool); int main(int argc, char *argv[]) {- printf("%d\n", not(true));- printf("%d\n", not(false));- printf("%d", eq(true, false));+ void* kptr = malloc(32 * 1024);+ printf("%d\n", not(kptr, true));+ printf("%d\n", not(kptr, false));+ printf("%d", eq(kptr, true, false)); }
test/harness/const.c view
@@ -1,7 +1,9 @@ #include <stdio.h>+#include <stdlib.h> -extern int id_int(int);+extern int id_int(void*, int); int main(int argc, char *argv[]) {- printf("%d", id_int(3));+ void* kptr = malloc(32 * 1024);+ printf("%d", id_int(kptr, 3)); }
test/harness/factorial.c view
@@ -1,9 +1,11 @@ #include <stdio.h>+#include <stdlib.h> -extern int fac_tailrec(int);-extern int fac(int);+extern int fac_tailrec(void*, int);+extern int fac(void*, int); int main(int argc, char *argv[]) {- printf("%d\n", fac_tailrec(3));- printf("%d", fac(3));+ void* kptr = malloc(32 * 1024);+ printf("%d\n", fac_tailrec(kptr, 3));+ printf("%d", fac(kptr, 3)); }
test/harness/numbertheory.c view
@@ -1,11 +1,13 @@ #include <stdbool.h> #include <stdio.h>+#include <stdlib.h> -extern int k_gcd(int, int);-extern bool is_prime(int);+extern int k_gcd(void*, int, int);+extern bool is_prime(void*, int); int main(int argc, char *argv[]) {- printf("%d\n", is_prime(37));- printf("%d\n", is_prime(36));- printf("%d", k_gcd(21, 35));+ void* kptr = malloc(32 * 1024);+ printf("%d\n", is_prime(kptr, 37));+ printf("%d\n", is_prime(kptr, 36));+ printf("%d", k_gcd(kptr, 21, 35)); }
test/harness/splitmix.c view
@@ -1,8 +1,10 @@ #include <stdint.h> #include <stdio.h>+#include <stdlib.h> -extern uint64_t from_seed(uint64_t);+extern uint64_t from_seed(void*, uint64_t); int main(int argc, char *argv[]) {- printf("%u", (unsigned int) from_seed(3012512025));+ void* kptr = malloc(32 * 1024);+ printf("%u", (unsigned int) from_seed(kptr, 3012512025)); }
+ test/include/splitmix.h view
@@ -0,0 +1,2 @@+#include <stdint.h>+extern uint64_t from_seed (void*, uint64_t);