kempe 0.1.0.2 → 0.1.1.0

raw patch · 64 files changed

+773/−190 lines, 64 filesdep ~basedep ~composition-preludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, composition-prelude

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• README.md +5/−2
• bench/Bench.hs +10/−12
• docs/manual.pdf binary
• examples/factorial.kmp +21/−0
• examples/hamming.kmp +2/−0
• examples/splitmix.kmp +11/−0
• kempe.cabal +20/−7
• lib/libc.kmp +7/−0
• lib/numbertheory.kmp +2/−6
• lib/tuple.kmp +12/−0
• run/Main.hs +21/−3
• src/Kempe/AST.hs +44/−18
• src/Kempe/Asm/X86.hs +5/−5
• src/Kempe/Asm/X86/ControlFlow.hs +1/−0
• src/Kempe/Asm/X86/Linear.hs +1/−0
• src/Kempe/Asm/X86/Liveness.hs +1/−0
• src/Kempe/Asm/X86/Type.hs +1/−3
• src/Kempe/Check/Pattern.hs +3/−3
• src/Kempe/Check/Restrict.hs +1/−1
• src/Kempe/Check/TopLevel.hs +50/−0
• src/Kempe/Error.hs +3/−2
• src/Kempe/File.hs +19/−18
• src/Kempe/IR.hs +16/−14
• src/Kempe/IR/Opt.hs +2/−0
• src/Kempe/Inline.hs +6/−5
• src/Kempe/Lexer.x +26/−11
• src/Kempe/Module.hs +42/−0
• src/Kempe/Monomorphize.hs +33/−17
• src/Kempe/Name.hs +1/−0
• src/Kempe/Parser.y +24/−2
• src/Kempe/Pipeline.hs +9/−5
• src/Kempe/Shuttle.hs +4/−4
• src/Kempe/TyAssign.hs +47/−32
• src/Prettyprinter/Ext.hs +13/−0
• test/Abi.hs +36/−0
• test/Backend.hs +8/−8
• test/Spec.hs +2/−0
• test/Type.hs +14/−2
• test/data/abi.kmp +10/−0
• test/data/multiConstruct.kmp +2/−3
• test/data/mutual.kmp +1/−7
• test/data/transitive.kmp +6/−0
• test/err/kind.kmp +4/−0
• test/err/merge.kmp +2/−0
• test/err/patternMatch.kmp +6/−0
• test/err/questionable.kmp +3/−0
• test/err/stupid.kmp +5/−0
• test/examples/bool.kmp +19/−0
• test/examples/hamming.kmp +4/−0
• test/examples/splitmix.kmp +11/−0
• test/golden/a.ir +19/−0
• test/golden/abi.ir +13/−0
• test/golden/bool.out +3/−0
• test/golden/factorial.out +2/−0
• test/golden/gaussian.ir +76/−0
• test/golden/hamming.out +1/−0
• test/golden/numbertheory.out +3/−0
• test/golden/splitmix.out +1/−0
• test/harness/bool.c +12/−0
• test/harness/factorial.c +9/−0
• test/harness/hamming.c +8/−0
• test/harness/numbertheory.c +11/−0
• test/harness/splitmix.c +8/−0

@@ -1,5 +1,16 @@ # kempe +## 0.1.1.0++  * Fix internal pretty-printer (exposed as hidden `fmt` subcommand)+  * Optimize IR cases+  * Fix padding+  * Fix bug in lexer (for C foreign calls)+  * Support down to GHC 8.0.2+  * Unification no longer takes pathologically long time+  * Add test files so source distribution passes+  * Some sort of imports now supported.+ ## 0.1.0.2    * Add optimizations (simplify code so that liveness analysis is quicker)

@@ -25,11 +25,14 @@  ## Defects -  * Unification takes too long   * Errors don't have position information   * Monomorphization fails on recursive polymorphic functions++    Hopefully this isn't too sinful; I can't think of any examples of recursive+    polymorphic functions   * Can't export or call C functions with more than 6 arguments; can't call or     export large arguments (i.e. structs) passed by value.      This is less of an impediment than it sounds like.-  * Sizing for ADTs is not rigorous in places+  * Cyclic module imports are not detected+  * Modules (imports) are kind of defective

@@ -1,6 +1,6 @@ module Main (main) where -import           Control.Exception         (Exception, throw, throwIO)+import           Control.Exception         (throw) import           Criterion.Main import           Data.Bifunctor            (Bifunctor, bimap) import qualified Data.ByteString.Lazy      as BSL@@ -15,6 +15,7 @@ import           Kempe.IR.Opt import           Kempe.Inline import           Kempe.Lexer+import           Kempe.Module import           Kempe.Monomorphize import           Kempe.Parser import           Kempe.Pipeline@@ -95,15 +96,16 @@                         , bench "Generate assembly (lib/numbertheory.kmp)" $ nfIO (writeAsm "lib/numbertheory.kmp")                         , bench "Object file (examples/factorial.kmp)" $ nfIO (compile "examples/factorial.kmp" "/tmp/factorial.o" False)                         , bench "Object file (lib/numbertheory.kmp)" $ nfIO (compile "lib/numbertheory.kmp" "/tmp/numbertheory.o" False)+                        , bench "Object file (examples/splitmix.kmp)" $ nfIO (compile "examples/splitmix.kmp" "/tmp/splitmix.o" False)                         ]                 ]-    where parsedM = yeetIO . parseWithMax =<< BSL.readFile "test/data/ty.kmp"-          splitmix = yeetIO . parseWithMax =<< BSL.readFile "examples/splitmix.kmp"-          fac = yeetIO . parseWithMax =<< BSL.readFile "examples/factorial.kmp"-          num = yeetIO . parseWithMax =<< BSL.readFile "lib/numbertheory.kmp"-          eitherMod = yeetIO . parse =<< BSL.readFile "lib/either.kmp"+    where parsedM = parseProcess "test/data/ty.kmp"+          splitmix = parseProcess "examples/splitmix.kmp"+          fac = parseProcess "examples/factorial.kmp"+          num = parseProcess "lib/numbertheory.kmp"+          eitherMod = snd <$> parseProcess "lib/either.kmp"           parsedInteresting = (,) <$> fac <*> num-          prelude = yeetIO . parseWithMax =<< BSL.readFile "prelude/fn.kmp"+          prelude = parseProcess "prelude/fn.kmp"           forTyEnv = (,,) <$> parsedM <*> splitmix <*> prelude           runCheck (maxU, m) = runTypeM maxU (checkModule m)           runAssign (maxU, m) = runTypeM maxU (assignModule m)@@ -134,13 +136,9 @@           -- not even gonna justify this           yrrucnu f (y, x) = f x y -yeetIO :: Exception e => Either e a -> IO a-yeetIO = either throwIO pure- writeAsm :: FilePath          -> IO T.Text writeAsm fp = do-    contents <- BSL.readFile fp-    res <- yeetIO $ parseWithMax contents+    res <- parseProcess fp     pure $ renderText $ uncurry dumpX86 res     where renderText = renderStrict . layoutPretty defaultLayoutOptions

binary file changed (212387 → 213705 bytes)

@@ -0,0 +1,21 @@+loop : Int Int -- Int+     =: [ swap dup 0 =+          if( drop+            , dup 1 - dip(*) swap loop )+        ]++; tail recursive factorial+;+; see C example: https://wiki.c2.com/?TailRecursion+fac_tailrec : Int -- Int+            =: [ 1 loop ]++; naïve factorial+fac : Int -- Int+    =: [ dup 0 =+         if( drop 1+           , dup 1 - fac * )+       ]++%foreign cabi fac+%foreign cabi fac_tailrec

@@ -0,0 +1,2 @@+hamming : Word Word -- Int+        =: [ xoru popcount ]

@@ -0,0 +1,11 @@+; from here: http://prng.di.unimi.it/splitmix64.c++; given a seed, return a random value and the new seed+next : Word -- Word Word+     =: [ 0x9e3779b97f4a7c15u +~ dup+          dup 30i8 >>~ xoru 0xbf58476d1ce4e5b9u *~+          dup 27i8 >>~ xoru 0x94d049bb133111ebu *~+          dup 31i8 >>~ xoru+        ]++%foreign kabi next

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            kempe-version:         0.1.0.2+version:         0.1.1.0 license:         BSD-3-Clause license-file:    LICENSE copyright:       Copyright: (c) 2020 Vanessa McHale@@ -12,6 +12,12 @@ build-type:      Simple data-files:     test/data/*.kmp+    test/err/*.kmp+    test/examples/*.kmp+    test/golden/*.out+    test/golden/*.ir+    test/harness/*.c+    examples/*.kmp     prelude/*.kmp     lib/*.kmp     docs/manual.pdf@@ -40,6 +46,7 @@         Kempe.Pipeline         Kempe.Shuttle         Kempe.Inline+        Kempe.Module         Kempe.Check.Pattern         Kempe.IR         Kempe.IR.Opt@@ -51,6 +58,7 @@     hs-source-dirs:   src     other-modules:         Kempe.Check.Restrict+        Kempe.Check.TopLevel         Kempe.Unique         Kempe.Name         Kempe.Error@@ -65,9 +73,9 @@         FlexibleContexts GeneralizedNewtypeDeriving OverloadedStrings         StandaloneDeriving TupleSections DeriveAnyClass -    ghc-options:      -Wall -O2+    ghc-options:      -Wall     build-depends:-        base >=4.11 && <5,+        base >=4.9 && <5,         array -any,         bytestring -any,         containers >=0.6.0.0,@@ -76,9 +84,9 @@         mtl -any,         microlens -any,         transformers -any,-        extra -any,+        extra >=1.7.4,         prettyprinter >=1.7.0,-        composition-prelude >=1.1.0.1,+        composition-prelude >=2.0.2.0,         microlens-mtl -any,         process >=1.2.3.0,         temporary -any@@ -111,7 +119,8 @@         base -any,         optparse-applicative -any,         kempe-modules -any,-        prettyprinter >=1.7.0+        prettyprinter >=1.7.0,+        bytestring -any      if impl(ghc >=8.0)         ghc-options:@@ -135,6 +144,7 @@         Parser         Type         Backend+        Abi      default-language: Haskell2010     ghc-options:      -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall@@ -145,7 +155,10 @@         tasty-hunit -any,         bytestring -any,         prettyprinter >=1.7.0,-        deepseq -any+        deepseq -any,+        tasty-golden -any,+        text -any,+        composition-prelude -any      if impl(ghc >=8.0)         ghc-options:

@@ -0,0 +1,7 @@+; bindings to libc (x86_64 guess)++rand : -- Int+     =: $cfun"rand"++exit : Int --+     =: $cfun"exit"

@@ -1,15 +1,11 @@+import "prelude/fn.kmp"+ ; tail recursive! gcd : Int Int -- Int     =: [ dup 0 =          if( drop            , dup dip(%) swap gcd )        ]--over : a b -- a b a-     =: [ dip(dup) swap ]--dup2 : a b -- a b a b-     =: [ over over ]  square : Int -- Int        =: [ dup * ]

@@ -0,0 +1,12 @@+import "prelude/fn.kmp"++type Pair a b { Pair a b }++unPair : ((Pair a) b) -- a b+       =: [ { case | Pair -> } ]++fst : ((Pair a) b) -- a+    =: [ unPair drop ]++snd : ((Pair a) b) -- b+    =: [ unPair nip ]

@@ -1,10 +1,14 @@ module Main (main) where -import           Control.Exception         (throwIO)+import           Control.Exception         (Exception, throwIO) import           Control.Monad             ((<=<))+import qualified Data.ByteString.Lazy      as BSL+import           Data.Semigroup            ((<>)) import qualified Data.Version              as V import           Kempe.AST import           Kempe.File+import           Kempe.Lexer+import           Kempe.Parser import           Options.Applicative import qualified Paths_kempe               as P import           Prettyprinter             (LayoutOptions (LayoutOptions), PageWidth (AvailablePerLine), hardline, layoutSmart)@@ -15,14 +19,24 @@ data Command = TypeCheck !FilePath              | Compile !FilePath !(Maybe FilePath) !Bool !Bool !Bool -- TODO: take arch on cli              | Format !FilePath+             | Lint !FilePath  fmt :: FilePath -> IO ()-fmt = renderIO stdout <=< fmap (render . (<> hardline) . prettyModule . snd) . parsedFp+fmt = renderIO stdout <=< fmap (render . (<> hardline) . prettyModule) . parsedFp     where render = layoutSmart settings           settings = LayoutOptions $ AvailablePerLine 80 0.5 +parsedFp :: FilePath -> IO (Module AlexPosn AlexPosn AlexPosn)+parsedFp fp = do+     contents <- BSL.readFile fp+     yeetIO $ parse contents++yeetIO :: Exception e => Either e a -> IO a+yeetIO = either throwIO pure+ run :: Command -> IO () run (TypeCheck fp)                        = either throwIO pure =<< tcFile fp+run (Lint fp)                             = maybe (pure ()) throwIO =<< warnFile fp run (Compile _ Nothing _ False False)     = putStrLn "No output file specified!" run (Compile fp (Just o) dbg False False) = compile fp o dbg run (Compile fp Nothing False True False) = irFile fp@@ -39,6 +53,9 @@ fmtP :: Parser Command fmtP = Format <$> kmpFile +lintP :: Parser Command+lintP = Lint <$> kmpFile+ debugSwitch :: Parser Bool debugSwitch = switch     (long "debug"@@ -65,7 +82,8 @@  commandP :: Parser Command commandP = hsubparser-    (command "typecheck" (info tcP (progDesc "Type-check module contents")))+    (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)     <|> compileP     where

@@ -15,12 +15,16 @@                  , KempeDecl (..)                  , Pattern (..)                  , ABI (..)-                 , Module+                 , Declarations+                 , Module (..)                  , freeVars                  , MonoStackType                  , SizeEnv+                 , Size                  , size                  , sizeStack+                 , size'+                 , cSize                  , prettyMonoStackType                  , prettyTyped                  , prettyTypedModule@@ -41,6 +45,7 @@ import           Data.List.NonEmpty      (NonEmpty) import qualified Data.List.NonEmpty      as NE import           Data.Monoid             (Sum (..))+import           Data.Semigroup          ((<>)) import qualified Data.Set                as S import           Data.Text.Lazy.Encoding (decodeUtf8) import           Data.Word               (Word8)@@ -48,7 +53,7 @@ import           Kempe.Name import           Kempe.Unique import           Numeric.Natural-import           Prettyprinter           (Doc, Pretty (pretty), align, braces, brackets, colon, concatWith, fillSep, hsep, parens, pipe, sep, vsep, (<+>))+import           Prettyprinter           (Doc, Pretty (pretty), align, braces, brackets, colon, concatWith, dquotes, fillSep, hsep, parens, pipe, sep, vsep, (<+>)) import           Prettyprinter.Ext  data BuiltinTy = TyInt@@ -152,7 +157,7 @@ prettyTyped (BoolLit _ b)    = pretty b prettyTyped (Int8Lit _ i)    = pretty i <> "i8" prettyTyped (WordLit _ n)    = pretty n <> "u"-prettyTyped (Case _ ls)      = "case" <+> braces (vsep (toList $ fmap (uncurry prettyTypedLeaf) ls))+prettyTyped (Case _ ls)      = braces ("case" <+> vsep (toList $ fmap (uncurry prettyTypedLeaf) ls))  data Atom c b = AtName b (Name b)               | Case b (NonEmpty (Pattern c b, [Atom c b]))@@ -256,7 +261,7 @@ prettyKempeDecl :: (Atom c b -> Doc ann) -> KempeDecl a c b -> Doc ann prettyKempeDecl atomizer (FunDecl _ n is os as) = pretty n <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> brackets (align (fillSep (atomizer <$> as)))) prettyKempeDecl _ (Export _ abi n)              = "%foreign" <+> pretty abi <+> pretty n-prettyKempeDecl _ (ExtFnDecl _ n is os b)       = pretty n <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> "$cfun" <> pretty (decodeUtf8 b))+prettyKempeDecl _ (ExtFnDecl _ n is os b)       = pretty n <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> "$cfun" <> dquotes (pretty (decodeUtf8 b))) prettyKempeDecl _ (TyDecl _ tn ns ls)           = "type" <+> pretty tn <+> hsep (fmap pretty ns) <+> braces (concatWith (\x y -> x <+> pipe <+> y) $ fmap (uncurry prettyTyLeaf) ls)  instance Pretty (KempeDecl a b c) where@@ -279,20 +284,31 @@     first _ (Export l abi n)           = Export l abi n     second = fmap +prettyDeclarationsGeneral :: (Atom c b -> Doc ann) -> Declarations a c b -> Doc ann+prettyDeclarationsGeneral atomizer = sepDecls . fmap (prettyKempeDecl atomizer)++prettyImport :: BSL.ByteString -> Doc ann+prettyImport b = "import" <+> dquotes (pretty (decodeUtf8 b))+ prettyModuleGeneral :: (Atom c b -> Doc ann) -> Module a c b -> Doc ann-prettyModuleGeneral atomizer = sep . fmap (prettyKempeDecl atomizer)+prettyModuleGeneral atomizer (Module [] ds) = prettyDeclarationsGeneral atomizer ds+prettyModuleGeneral atomizer (Module is ds) = prettyLines (fmap prettyImport is) <##> prettyDeclarationsGeneral atomizer ds -prettyFancyModule :: Module () (ConsAnn (StackType ())) (StackType ()) -> Doc ann+prettyFancyModule :: Declarations () (ConsAnn (StackType ())) (StackType ()) -> Doc ann prettyFancyModule = prettyTypedModule . fmap (first consTy) -prettyTypedModule :: Module () (StackType ()) (StackType ()) -> Doc ann-prettyTypedModule = prettyModuleGeneral prettyTyped+prettyTypedModule :: Declarations () (StackType ()) (StackType ()) -> Doc ann+prettyTypedModule = prettyDeclarationsGeneral prettyTyped  prettyModule :: Module a c b -> Doc ann prettyModule = prettyModuleGeneral pretty -type Module a c b = [KempeDecl a c b]+type Declarations a c b = [KempeDecl a c b] +data Module a c b = Module { importFps :: [BSL.ByteString]+                           , body      :: [KempeDecl a c b]+                           } deriving (Generic, NFData)+ extrVars :: KempeTy a -> [Name a] extrVars TyBuiltin{}      = [] extrVars TyNamed{}        = []@@ -302,22 +318,32 @@ freeVars :: [KempeTy a] -> S.Set (Name a) freeVars tys = S.fromList (concatMap extrVars tys) -type SizeEnv = IM.IntMap Int64+-- machinery for assigning a constructor to a function of its concrete types+-- (and then curry forward...) --- the kempe sizing system is kind of fucked (it works tho)+type Size = [Int64] -> Int64+type SizeEnv = IM.IntMap Size +-- the kempe sizing system is kind of fucked (it mostly works tho)+ -- | Don't call this on ill-kinded types; it won't throw any error.-size :: SizeEnv -> KempeTy a -> Int64-size _ (TyBuiltin _ TyInt)                 = 8 -- since we're only targeting x86_64 and aarch64 we have 64-bit 'Int's-size _ (TyBuiltin _ TyBool)                = 1-size _ (TyBuiltin _ TyInt8)                = 1-size _ (TyBuiltin _ TyWord)                = 8+size :: SizeEnv -> KempeTy a -> Size+size _ (TyBuiltin _ TyInt)                 = const 8+size _ (TyBuiltin _ TyBool)                = const 1+size _ (TyBuiltin _ TyInt8)                = const 1+size _ (TyBuiltin _ TyWord)                = const 8 size _ TyVar{}                             = error "Internal error: type variables should not be present at this stage." size env (TyNamed _ (Name _ (Unique k) _)) = IM.findWithDefault (error "Size not in map!") k env-size env (TyApp _ ty ty')                  = size env ty + size env ty'+size env (TyApp _ ty ty')                  = \tys -> size env ty (size env ty' [] : tys) +cSize :: Size -> Int64+cSize = ($ [])++size' :: SizeEnv -> KempeTy a -> Int64+size' env = cSize . size env+ sizeStack :: SizeEnv -> [KempeTy a] -> Int64-sizeStack env = getSum . foldMap (Sum . size env)+sizeStack env = getSum . foldMap (Sum . size' env)  -- | Used in "Kempe.Monomorphize" for patterns flipStackType :: StackType () -> StackType ()

@@ -139,16 +139,16 @@     pure [ SubRC () (toAbsReg r1) i ] irEmit _ (IR.MovTemp r1 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r2) (IR.ConstInt i))) | r1 == r2 = do     pure [ AddRC () (toAbsReg r1) i ]-irEmit env (IR.CCall (is, []) b) | all (\i -> size env i <= 8) is && length is <= 6 =+irEmit env (IR.CCall (is, []) b) | all (\i -> size' env i <= 8) is && length is <= 6 =     pure [NasmMacro0 () "callersave", CallBS () b, NasmMacro0 () "callerrestore"]-irEmit env (IR.CCall (is, [o]) b) | all (\i -> size env i <= 8) is && size env o <= 8 && length is <= 6 =+irEmit env (IR.CCall (is, [o]) b) | all (\i -> size' env i <= 8) is && size' env o <= 8 && length is <= 6 =     pure [NasmMacro0 () "callersave", CallBS () b, NasmMacro0 () "callerrestore"] -- For 128-bit returns we'd have to use rax and rdx-irEmit env (IR.WrapKCall Cabi (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)+irEmit env (IR.WrapKCall Cabi (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 = [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+    ; 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 _ (IR.WrapKCall Kabi (_, _) n l) =     pure [BSLabel () n, Call () l, Ret ()]

@@ -7,6 +7,7 @@ import           Data.Bifunctor             (first, second) import           Data.Functor               (($>)) import qualified Data.Map                   as M+import           Data.Semigroup             ((<>)) import qualified Data.Set                   as S import           Kempe.Asm.X86.Type 

@@ -11,6 +11,7 @@ import           Data.Foldable              (traverse_) import qualified Data.Map                   as M import           Data.Maybe                 (fromMaybe)+import           Data.Semigroup             ((<>)) import qualified Data.Set                   as S import           Kempe.Asm.X86.Type import           Lens.Micro                 (Lens')

@@ -8,6 +8,7 @@ import           Control.Composition (thread) -- this seems to be faster import qualified Data.IntMap.Lazy    as IM+import           Data.Semigroup      ((<>)) import qualified Data.Set            as S import           Kempe.Asm.X86.Type 

@@ -19,6 +19,7 @@ import qualified Data.ByteString.Lazy    as BSL import           Data.Foldable           (toList) import           Data.Int                (Int64, Int8)+import           Data.Semigroup          ((<>)) import qualified Data.Set                as S import           Data.Text.Encoding      (decodeUtf8) import qualified Data.Text.Lazy.Encoding as TL@@ -281,9 +282,6 @@     pretty (MovRCTag _ r b)     = i4 ("mov" <+> pretty r <> "," <+> pretty b)     pretty (NasmMacro0 _ b)     = i4 (pretty (decodeUtf8 b))     pretty (CallBS _ b)         = i4 ("call" <+> pretty (TL.decodeUtf8 b))--prettyLines :: [Doc ann] -> Doc ann-prettyLines = concatWith (<#>)  prettyAsm :: Pretty reg => [X86 reg a] -> Doc ann prettyAsm = ((prolegomena <#> macros <#> "section .text" <> hardline) <>) . prettyLines . fmap pretty

@@ -34,10 +34,10 @@ checkDecl env (FunDecl _ _ _ _ as) = foldMapAlternative (checkAtom env) as checkDecl _ _                      = Nothing -checkModule :: PatternEnv -> Module a c b -> Maybe (Error b)+checkModule :: PatternEnv -> Declarations a c b -> Maybe (Error b) checkModule env = foldMapAlternative (checkDecl env) -checkModuleExhaustive :: Module a c b -> Maybe (Error b)+checkModuleExhaustive :: Declarations a c b -> Maybe (Error b) checkModuleExhaustive m =     let env = runPatternM $ patternEnvDecls m         in checkModule env m@@ -54,7 +54,7 @@  type PatternM = State PatternEnv -patternEnvDecls :: Module a c b -> PatternM ()+patternEnvDecls :: Declarations a c b -> PatternM () patternEnvDecls = traverse_ declAdd  declAdd :: KempeDecl a c b -> PatternM ()

@@ -6,7 +6,7 @@ import           Kempe.AST import           Kempe.Error       (Error (FatSumType)) -restrictConstructors :: Module a c b -> Maybe (Error a)+restrictConstructors :: Declarations a c b -> Maybe (Error a) restrictConstructors = foldMapAlternative restrictDecl  restrictDecl :: KempeDecl a c b -> Maybe (Error a)

@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Check.TopLevel ( topLevelCheck+                            , Warning+                            ) where++import           Control.Applicative ((<|>))+import           Control.Exception   (Exception)+import           Data.Foldable       (toList)+import           Data.Foldable.Ext+import           Data.List           (group, sort)+import           Data.Maybe          (mapMaybe)+import           Data.Semigroup      ((<>))+import           Data.Typeable       (Typeable)+import           Kempe.AST+import           Kempe.Name+import           Prettyprinter       (Pretty (pretty))++data Warning a = NameClash a (Name a)++instance Pretty a => Pretty (Warning a) where+    pretty (NameClash l x) = pretty l <> " '" <> pretty x <> "' is defined more than once."++topLevelCheck :: Declarations a c a -> Maybe (Warning a)+topLevelCheck ds =+        checkNames (collectNames ds)+    <|> checkNames (collectCons ds)++-- | Just checks function names and type names. Doesn't check constructors.+collectNames :: Declarations a c a -> [Name a]+collectNames = mapMaybe collectDeclNames where+    collectDeclNames (FunDecl _ n _ _ _)   = Just n+    collectDeclNames (ExtFnDecl _ n _ _ _) = Just n+    collectDeclNames Export{}              = Nothing+    collectDeclNames (TyDecl _ tn _ _)     = Just tn++collectCons :: Declarations a c b-> [Name b]+collectCons = concatMap collectDeclNames where+    collectDeclNames (TyDecl _ _ _ ls) = toList (fst <$> ls)+    collectDeclNames _                 = []++checkNames :: [Name a] -> Maybe (Warning a)+checkNames ns = foldMapAlternative announce (group $ sort ns) -- maybe could be better idk+    where announce (_:y:_) = Just $ NameClash (loc y) y+          announce _       = Nothing++instance (Pretty a) => Show (Warning a) where+    show = show . pretty++instance (Pretty a, Typeable a) => Exception (Warning a)

@@ -8,6 +8,7 @@  import           Control.DeepSeq   (NFData) import           Control.Exception (Exception)+import           Data.Semigroup    ((<>)) import           Data.Typeable     (Typeable) import           GHC.Generics      (Generic) import           Kempe.AST@@ -33,7 +34,7 @@ mErr Nothing    = Right () mErr (Just err) = Left err -instance (Pretty a) => Show (Error a) where+instance Show (Error a) where     show = show . pretty  instance Pretty (Error a) where@@ -50,4 +51,4 @@     pretty (FatSumType _ tn)             = "Sum type" <+> pretty tn <+> "has too many constructors! Sum types are limited to 256 constructors in Kempe."     pretty InexhaustiveMatch{}           = "Inexhaustive pattern match." -instance (Pretty a, Typeable a) => Exception (Error a)+instance (Typeable a) => Exception (Error a)

@@ -1,28 +1,31 @@ module Kempe.File ( tcFile+                  , warnFile                   , dumpMono                   , dumpTyped                   , irFile                   , x86File                   , dumpX86                   , compile-                  , parsedFp+                  , dumpIR                   ) where  -- common b/w test suite and exec, repl utils import           Control.Composition       ((.*)) import           Control.Exception         (Exception, throwIO) import           Data.Bifunctor            (bimap)-import qualified Data.ByteString.Lazy      as BSL import           Data.Functor              (void)+import           Data.Semigroup            ((<>)) import qualified Data.Set                  as S import           Data.Tuple.Extra          (fst3)+import           Data.Typeable             (Typeable) import           Kempe.AST import           Kempe.Asm.X86.Type import           Kempe.Check.Pattern+import           Kempe.Check.TopLevel import           Kempe.Error import           Kempe.IR import           Kempe.Lexer-import           Kempe.Parser+import           Kempe.Module import           Kempe.Pipeline import           Kempe.Proc.Nasm import           Kempe.Shuttle@@ -32,48 +35,47 @@  tcFile :: FilePath -> IO (Either (Error ()) ()) tcFile fp = do-    contents <- BSL.readFile fp-    (maxU, m) <- yeetIO $ parseWithMax contents+    (maxU, m) <- parseProcess fp     pure $ do         void $ runTypeM maxU (checkModule m)         mErr $ checkModuleExhaustive (void <$> m) +warnFile :: FilePath -> IO (Maybe (Warning AlexPosn))+warnFile fp = do+    (_, m) <- parseProcess fp+    pure $ topLevelCheck m+ yeetIO :: Exception e => Either e a -> IO a yeetIO = either throwIO pure  dumpTyped :: FilePath -> IO () dumpTyped fp = do-    (i, m) <- parsedFp fp+    (i, m) <- parseProcess fp     (mTyped, _) <- yeetIO $ runTypeM i (assignModule m)     putDoc $ prettyTypedModule mTyped  dumpMono :: FilePath -> IO () dumpMono fp = do-    (i, m) <- parsedFp fp+    (i, m) <- parseProcess fp     (mMono, _) <- yeetIO $ monomorphize i m     putDoc $ prettyTypedModule (fmap (bimap fromMonoConsAnn fromMono) mMono)     where fromMono (is, os) = StackType S.empty is os           fromMonoConsAnn (ConsAnn _ _ ty) = fromMono ty -dumpIR :: Int -> Module a c b -> Doc ann+dumpIR :: Typeable a => Int -> Declarations a c b -> Doc ann dumpIR = prettyIR . fst3 .* irGen -dumpX86 :: Int -> Module a c b -> Doc ann+dumpX86 :: Typeable a => Int -> Declarations a c b -> Doc ann dumpX86 = prettyAsm .* x86Alloc  irFile :: FilePath -> IO () irFile fp = do-    res <- parsedFp fp+    res <- parseProcess fp     putDoc $ uncurry dumpIR res <> hardline -parsedFp :: FilePath -> IO (Int, Module AlexPosn AlexPosn AlexPosn)-parsedFp fp = do-    contents <- BSL.readFile fp-    yeetIO $ parseWithMax contents- x86File :: FilePath -> IO () x86File fp = do-    res <- parsedFp fp+    res <- parseProcess fp     putDoc $ uncurry dumpX86 res <> hardline  compile :: FilePath@@ -81,6 +83,5 @@         -> Bool -- ^ Debug symbols?         -> IO () compile fp o dbg = do-    contents <- BSL.readFile fp-    res <- yeetIO $ parseWithMax contents+    res <- parseProcess fp     writeO (uncurry dumpX86 res) o dbg

@@ -30,6 +30,7 @@ import           Data.Foldable.Ext import           Data.Int                   (Int64, Int8) import qualified Data.IntMap                as IM+import           Data.Semigroup             ((<>)) import           Data.Text.Encoding         (decodeUtf8, encodeUtf8) import           Data.Word                  (Word8) import           GHC.Generics               (Generic)@@ -38,7 +39,7 @@ import           Kempe.Unique import           Lens.Micro                 (Lens') import           Lens.Micro.Mtl             (modifying)-import           Prettyprinter              (Doc, Pretty (pretty), braces, brackets, colon, concatWith, hardline, parens, (<+>))+import           Prettyprinter              (Doc, Pretty (pretty), braces, brackets, colon, hardline, parens, (<+>)) import           Prettyprinter.Ext  type Label = Word@@ -103,7 +104,7 @@         (IM.findWithDefault (error "Internal error in IR phase: could not look find label for name") i . atLabels)  prettyIR :: [Stmt] -> Doc ann-prettyIR = concatWith (\x y -> x <> hardline <> y) . fmap pretty+prettyIR = prettyLines . fmap pretty  prettyLabel :: Label -> Doc ann prettyLabel l = "kmp" <> pretty l@@ -216,7 +217,7 @@     pretty WordModIR    = "%~"     pretty WordDivIR    = "/~" -writeModule :: SizeEnv -> Module () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]+writeModule :: SizeEnv -> Declarations () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt] writeModule env m = traverse_ assignName m *> foldMapA (writeDecl env) m  -- optimize tail-recursion, if possible@@ -353,10 +354,10 @@ writeAtom _ _ (AtBuiltin _ IntNeg)      = intNeg writeAtom _ _ (AtBuiltin _ Popcount)    = wordCount writeAtom env _ (AtBuiltin (is, _) Drop)  =-    let sz = size env (last is) in+    let sz = size' env (last is) in         pure [ dataPointerDec sz ] writeAtom env _ (AtBuiltin (is, _) Dup)   =-    let sz = size env (last is) in+    let sz = size' env (last is) in         pure $              copyBytes 0 (-sz) sz                 ++ [ dataPointerInc sz ] -- move data pointer over sz bytes@@ -369,11 +370,11 @@     l2 <- newLabel     pure $ dataPointerDec 1 : ifIR : (Labeled l0 : asIR ++ [Jump l2]) ++ (Labeled l1 : asIR') ++ [Labeled l2] writeAtom env _ (Dip (is, _) as) =-    let sz = size env (last is)+    let sz = size' env (last is)     in foldMapA (dipify env sz) as writeAtom env _ (AtBuiltin ([i0, i1], _) Swap) =-    let sz0 = size env i0-        sz1 = size env i1+    let sz0 = size' env i0+        sz1 = size' env i1     in         pure $             copyBytes 0 (-sz0 - sz1) sz0 -- copy i0 to end of the stack@@ -385,7 +386,7 @@ writeAtom _ _ (Case ([], _) _) = error "Internal error: Ill-typed case statement?!" writeAtom env l (Case (is, _) ls) =     let (ps, ass) = NE.unzip ls-        decSz = size env (last is)+        decSz = size' env (last is)         in do             leaves <- zipWithM (mkLeaf env l) ps ass             let (switches, meat) = NE.unzip leaves@@ -422,14 +423,14 @@ dipify :: SizeEnv -> Int64 -> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt] dipify _ _ (AtBuiltin ([], _) Drop) = error "Internal error: Ill-typed drop!" dipify env sz (AtBuiltin (is, _) Drop) =-    let sz' = size env (last is)+    let sz' = size' env (last is)         shift = dataPointerDec sz' -- shift data pointer over by sz' bytes         -- copy sz bytes over (-sz') bytes from the data pointer         copyBytes' = copyBytes (-sz - sz') (-sz) sz         in pure $ copyBytes' ++ [shift] dipify env sz (AtBuiltin ([i0, i1], _) Swap) =-    let sz0 = size env i0-        sz1 = size env i1+    let sz0 = size' env i0+        sz1 = size' env i1     in         pure $             copyBytes 0 (-sz - sz0 - sz1) sz0 -- copy i0 to end of the stack@@ -437,7 +438,7 @@                 ++ copyBytes (-sz - sz0) 0 sz0 -- copy i0 at end of stack to its new place dipify _ _ (Dip ([], _) _) = error "Internal error: Ill-typed dip()!" dipify env sz (Dip (is, _) as) =-    let sz' = size env (last is)+    let sz' = size' env (last is)         in foldMapA (dipify env (sz + sz')) as dipify _ _ (AtBuiltin _ Swap)        = error "Internal error: Ill-typed swap!" dipify _ sz (AtBuiltin _ IntTimes)   = dipOp sz IntTimesIR@@ -469,7 +470,7 @@ dipify _ sz (AtBuiltin _ WordMod)    = dipOp sz WordModIR dipify _ _ (AtBuiltin ([], _) Dup) = error "Internal error: Ill-typed dup!" dipify env sz (AtBuiltin (is, _) Dup) = do-    let sz' = size env (last is) in+    let sz' = size' env (last is) in         pure $              copyBytes 0 (-sz) sz -- copy sz bytes over to the end of the stack                 ++ copyBytes (-sz) (-sz - sz') sz' -- copy sz' bytes over (duplicate)@@ -555,6 +556,7 @@     | b `mod` 8 == 0 =         let is = fmap (8*) [0..(b `div` 8 - 1)] in             [ MovMem (dataPointerPlus (i + off1)) 8 (Mem 8 $ dataPointerPlus (i + off2)) | i <- is ]+    -- TODO: 4 byte chunks, &c. (would require more registers).     | otherwise =         [ MovMem (dataPointerPlus (i + off1)) 1 (Mem 1 $ dataPointerPlus (i + off2)) | i <- [0..(b-1)] ] 

@@ -63,5 +63,7 @@ removeNop :: [Stmt] -> [Stmt] removeNop = filter (not . isNop)     where+        isNop (MovTemp e (ExprIntBinOp IntPlusIR (Reg e') (ConstInt 0))) | e == e' = True+        isNop (MovTemp e (ExprIntBinOp IntMinusIR (Reg e') (ConstInt 0))) | e == e' = True         isNop (MovMem e _ (Mem _ e')) | e == e' = True -- the Eq on Exp is kinda weird, but if the syntax trees are the same then they're certainly equivalent semantically         isNop _ = False

@@ -8,6 +8,7 @@ import qualified Data.IntMap        as IM import qualified Data.List.NonEmpty as NE import           Data.Maybe         (fromMaybe, mapMaybe)+import           Data.Semigroup     ((<>)) import           Data.Tuple.Extra   (third3) import           Kempe.AST import           Kempe.Name@@ -17,7 +18,7 @@ -- a given 'Name' type FnModuleMap c b = IM.IntMap (Maybe [Atom c b]) -inline :: Module a c b -> Module a c b+inline :: Declarations a c b -> Declarations a c b inline m = fmap inlineDecl m     where inlineDecl (FunDecl l n ty ty' as) = FunDecl l n ty ty' (inlineAtoms n as)           inlineDecl d                       = d@@ -44,7 +45,7 @@  -- | Given a module, make a map telling which top-level names are recursive or -- cannot be inlined-graphRecursiveMap :: Module a c b -> (Graph, Name b -> Vertex) -> IM.IntMap Bool+graphRecursiveMap :: Declarations a c b -> (Graph, Name b -> Vertex) -> IM.IntMap Bool graphRecursiveMap m (graph, nLookup) = IM.fromList $ mapMaybe fnRecursive m     where fnRecursive (FunDecl _ n@(Name _ (Unique i) _) _ _ as) | n `elem` namesInAtoms as = Just (i, True) -- if it calls iteself                                                                  | anyReachable n as = Just (i, True)@@ -55,18 +56,18 @@             any (\nA -> path graph (nLookup nA) (nLookup n)) (namesInAtoms as) -- TODO: lift let-binding (nLookup?)  -kempeGraph :: Module a c b -> (Graph, Vertex -> (KempeDecl a c b, Name b, [Name b]), Name b -> Vertex)+kempeGraph :: Declarations a c b -> (Graph, Vertex -> (KempeDecl a c b, Name b, [Name b]), Name b -> Vertex) kempeGraph = third3 (findVtx .) . graphFromEdges . kempePreGraph     where findVtx = fromMaybe (error "Internal error: bad name lookup!") -kempePreGraph :: Module a c b -> [(KempeDecl a c b, Name b, [Name b])]+kempePreGraph :: Declarations a c b -> [(KempeDecl a c b, Name b, [Name b])] kempePreGraph = mapMaybe kempeDeclToGraph     where kempeDeclToGraph :: KempeDecl a c b -> Maybe (KempeDecl a c b, Name b, [Name b])           kempeDeclToGraph d@(FunDecl _ n _ _ as)  = Just (d, n, foldMap namesInAtom as)           kempeDeclToGraph d@(ExtFnDecl _ n _ _ _) = Just (d, n, [])           kempeDeclToGraph _                       = Nothing -mkFnModuleMap :: Module a c b -> FnModuleMap c b+mkFnModuleMap :: Declarations a c b -> FnModuleMap c b mkFnModuleMap = IM.fromList . mapMaybe toInt where     toInt (FunDecl _ (Name _ (Unique i) _) _ _ as)  = Just (i, Just as)     toInt (ExtFnDecl _ (Name _ (Unique i) _) _ _ _) = Just (i, Nothing)

@@ -4,8 +4,10 @@     {-# LANGUAGE OverloadedStrings #-}     {-# LANGUAGE StandaloneDeriving #-}     module Kempe.Lexer ( alexMonadScan+                       , alexInitUserState                        , runAlex                        , runAlexSt+                       , withAlexSt                        , lexKempe                        , AlexPosn (..)                        , Alex (..)@@ -25,6 +27,7 @@ import Data.Int (Int8) import qualified Data.IntMap as IM import qualified Data.Map as M+import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8) import GHC.Generics (Generic)@@ -51,6 +54,8 @@  @foreign = \" $latin @follow_char* \" +@module_str = \" [^\"]+ \"+ tokens :-      <0> {@@ -119,6 +124,7 @@         False                    { mkBuiltin (BuiltinBoolLit False) }         dup                      { mkBuiltin BuiltinDup }         drop                     { mkBuiltin BuiltinDrop }+         swap                     { mkBuiltin BuiltinSwap }         xori                     { mkBuiltin BuiltinIntXor }         xoru                     { mkBuiltin BuiltinWordXor }@@ -135,12 +141,17 @@          @name                    { tok (\p s -> TokName p <$> newIdentAlex p (mkText s)) }         @tyname                  { tok (\p s -> TokTyName p <$> newIdentAlex p (mkText s)) }-        @foreign                 { tok (\p s -> alex $ TokForeign p s) }+        @foreign                 { tok (\p s -> alex $ TokForeign p (dropQuotes s)) } +        @module_str              { tok (\p s -> alex $ TokModuleStr p (dropQuotes s)) }+     }  { +dropQuotes :: BSL.ByteString -> BSL.ByteString+dropQuotes = BSL.init . BSL.tail+ readHex' :: (Eq a, Num a) => BSL.ByteString -> Alex a readHex' bs =     case readHex (ASCII.unpack bs) of@@ -166,6 +177,8 @@ instance Pretty AlexPosn where     pretty (AlexPn _ line col) = pretty line <> colon <> pretty col +deriving instance Ord AlexPosn+ deriving instance Generic AlexPosn  deriving instance NFData AlexPosn@@ -328,20 +341,22 @@              | TokInt8 { loc :: a, int8 :: Int8 }              | TokWord { loc :: a, word :: Natural }              | TokForeign { loc :: a, ident :: BSL.ByteString }+             | TokModuleStr { loc :: a, moduleFp :: BSL.ByteString }              | TokBuiltin { loc :: a, builtin :: Builtin }              deriving (Generic, NFData)  instance Pretty (Token a) where-    pretty EOF{}             = "(eof)"-    pretty (TokSym _ s)      = "symbol" <+> squotes (pretty s)-    pretty (TokName _ n)     = "identifier" <+> squotes (pretty n)-    pretty (TokTyName _ tn)  = "identifier" <+> squotes (pretty tn)-    pretty (TokKeyword _ kw) = "keyword" <+> squotes (pretty kw)-    pretty (TokInt _ i)      = pretty i-    pretty (TokWord _ n)     = pretty n <> "u"-    pretty (TokInt8 _ i)     = pretty i <> "i8"-    pretty (TokForeign _ fn) = dquotes (pretty $ mkText fn)-    pretty (TokBuiltin _ b)  = pretty b+    pretty EOF{}              = "(eof)"+    pretty (TokSym _ s)       = "symbol" <+> squotes (pretty s)+    pretty (TokName _ n)      = "identifier" <+> squotes (pretty n)+    pretty (TokTyName _ tn)   = "identifier" <+> squotes (pretty tn)+    pretty (TokKeyword _ kw)  = "keyword" <+> squotes (pretty kw)+    pretty (TokInt _ i)       = pretty i+    pretty (TokWord _ n)      = pretty n <> "u"+    pretty (TokInt8 _ i)      = pretty i <> "i8"+    pretty (TokForeign _ fn)  = dquotes (pretty $ mkText fn)+    pretty (TokModuleStr _ m) = dquotes (pretty $ mkText m)+    pretty (TokBuiltin _ b)   = pretty b  newIdentAlex :: AlexPosn -> T.Text -> Alex (Name AlexPosn) newIdentAlex pos t = do

@@ -0,0 +1,42 @@+-- | Pretty easy since doesn't need renaming.+--+-- Just thread lexer state through, remove duplicates.+module Kempe.Module ( parseProcess+                    ) where++import           Control.Exception          (Exception, throwIO)+import qualified Data.ByteString.Lazy       as BSL+import qualified Data.ByteString.Lazy.Char8 as ASCII+import qualified Data.Set                   as S+import           Data.Tuple.Extra           (fst3, third3)+import           Kempe.AST+import           Kempe.Lexer+import           Kempe.Parser+++parseProcess :: FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn)+parseProcess fp = do+    (st, [], ds) <- loopFps [fp] alexInitUserState+    pure (fst3 st, {-# SCC "dedup" #-} dedup ds)++yeetIO :: Exception e => Either e a -> IO a+yeetIO = either throwIO pure++loopFps :: [FilePath] -> AlexUserState -> IO (AlexUserState, [FilePath], Declarations AlexPosn AlexPosn AlexPosn)+loopFps [] st = pure (st, [], [])+loopFps (fp:fps) st = do+    (st', Module is ds) <- parseStep fp st+    third3 (++ ds) <$> loopFps (fmap ASCII.unpack (reverse is) ++ fps) st'++parseStep :: FilePath -> AlexUserState -> IO (AlexUserState, Module AlexPosn AlexPosn AlexPosn)+parseStep fp st = do+    contents <- BSL.readFile fp+    yeetIO $ parseWithCtx contents st++dedup :: Ord a => [a] -> [a]+dedup = loop S.empty+    where loop _ [] = []+          loop acc (x:xs) =+            if S.member x acc+                then loop acc xs+                else x : loop (S.insert x acc) xs

@@ -24,11 +24,11 @@ import           Data.Foldable              (traverse_) import           Data.Function              (on) import           Data.Functor               (($>))-import           Data.Int                   (Int64) import qualified Data.IntMap                as IM-import           Data.List                  (find, groupBy, partition)+import           Data.List                  (elemIndex, find, groupBy, partition) import qualified Data.Map                   as M import           Data.Maybe                 (fromMaybe, mapMaybe)+import           Data.Semigroup             ((<>)) import qualified Data.Set                   as S import qualified Data.Text                  as T import           Data.Tuple                 (swap)@@ -80,7 +80,7 @@ -- a given 'Name' type ModuleMap a c b = IM.IntMap (KempeDecl a c b) -mkModuleMap :: Module a c b -> ModuleMap a c b+mkModuleMap :: Declarations a c b -> ModuleMap a c b mkModuleMap = IM.fromList . concatMap toInt where     toInt d@(FunDecl _ (Name _ (Unique i) _) _ _ _)   = [(i, d)]     toInt d@(ExtFnDecl _ (Name _ (Unique i) _) _ _ _) = [(i, d)]@@ -145,11 +145,11 @@ renameDecl (TyDecl l n vars ls)       = pure $ TyDecl l n vars ls  -- | Call 'closedModule' and perform any necessary renamings-flattenModule :: Module () (StackType ()) (StackType ()) -> MonoM (Module () (ConsAnn MonoStackType) (StackType ()))+flattenModule :: Declarations () (StackType ()) (StackType ()) -> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ())) flattenModule = renameMonoM <=< closedModule  -- | To be called after 'closedModule'-renameMonoM :: Module () (StackType ()) (StackType ()) -> MonoM (Module () (ConsAnn MonoStackType) (StackType ()))+renameMonoM :: Declarations () (StackType ()) (StackType ()) -> MonoM (Declarations () (ConsAnn MonoStackType) (StackType ())) renameMonoM = traverse renameDecl  -- | Filter so that only the 'KempeDecl's necessary for exports are there, and@@ -158,7 +158,7 @@ -- This will throw an exception on ill-typed programs. -- -- The 'Module' returned will have to be renamed.-closedModule :: Module () (StackType ()) (StackType ()) -> MonoM (Module () (StackType ()) (StackType ()))+closedModule :: Declarations () (StackType ()) (StackType ()) -> MonoM (Declarations () (StackType ()) (StackType ())) closedModule m = addExports <$> do     { fn' <- traverse (uncurry specializeDecl . drop1) fnDecls     ; traverse_ insTyDecl $ nubOrd (snd3 <$> tyDecls)@@ -190,15 +190,31 @@ isTyVar TyVar{} = True isTyVar _       = False -sizeLeaf :: [KempeTy a] -> MonoM Int64-sizeLeaf tys =-    sizeStack <$> gets szEnv <*> pure (filter (not . isTyVar) tys)+extrNames :: KempeTy a -> Name a+extrNames (TyVar _ n) = n+extrNames _           = error "Internal error!" +sizeLeaf :: [Name a] -- ^ Type variables as declared+         -> [KempeTy a]+         -> MonoM Size+sizeLeaf fv tys = do+    { let (tvs, conc) = partition isTyVar tys+    ; pad <- sizeStack <$> gets szEnv <*> pure conc+    ; let tvPrecompose = fmap (forVar . extrNames) tvs+    ; let tvComposed = foldr compose (const pad) tvPrecompose+    ; pure tvComposed+    }+  where+    findIx x = fromMaybe (error "Internal error: can't find index of type variable.") $ elemIndex x fv+    forVar n =+        let i = findIx n+            in (!! i)+    compose sz sz' = \tys' -> sz tys' + sz' tys'+ insTyDecl :: KempeDecl a c b -> MonoM ()-insTyDecl (TyDecl _ (Name _ (Unique k) _) _ leaves) = do-    leafSizes <- traverse sizeLeaf (fmap snd leaves)-    -- this is kinda sketch because it takes max w/o tyvars-    let consSz = 1 + maximum leafSizes -- for the tag+insTyDecl (TyDecl _ (Name _ (Unique k) _) fv leaves) = do+    leafSizes <- traverse (sizeLeaf fv) (fmap snd leaves)+    let consSz = \tys -> 1 + maximum (($tys) <$> leafSizes) -- for the tag     modifying szEnvLens (IM.insert k consSz) insTyDecl _ = error "Shouldn't happen." @@ -210,7 +226,7 @@     where indexAt p xs = fst $ fromMaybe (error "Internal error.") $ find (\(_, x) -> p x) (zip [0..] xs)           getTag (Name _ u _) = indexAt (== u) preIxes           preIxes = fmap (unique . fst) preConstrs-          szType env (_, [o]) = size env o+          szType env (_, [o]) = size' env o           szType _ _          = error "Internal error: ill-typed constructor." mkTyDecl _ _ = error "Shouldn't happen." @@ -241,7 +257,7 @@     modifying fnEnvLens (M.insert (i, newStackType) j)     pure (Name t' j newStackType) -closure :: Ord b => (Module a b b, ModuleMap a b b) -> S.Set (Name b, b)+closure :: Ord b => (Declarations a b b, ModuleMap a b b) -> S.Set (Name b, b) closure (m, key) = loop roots S.empty     where roots = S.fromList (exports m)           loop ns avoid =@@ -272,10 +288,10 @@ namesInAtom WordLit{}                  = S.empty namesInAtom (Case _ as)                = foldMap namesInAtom (foldMap snd as) -- FIXME: patterns too -exports :: Module a c b -> [(Name b, b)]+exports :: Declarations a c b -> [(Name b, b)] exports = mapMaybe exportsDecl -exportsOnly :: Module a c b -> Module a c b+exportsOnly :: Declarations a c b -> Declarations a c b exportsOnly = mapMaybe getExport where     getExport d@Export{} = Just d     getExport _          = Nothing

@@ -8,6 +8,7 @@                   ) where  import           Control.DeepSeq (NFData (..))+import           Data.Semigroup  ((<>)) import qualified Data.Text       as T import           Kempe.Unique import           Prettyprinter   (Pretty (pretty))

@@ -4,6 +4,8 @@     {-# LANGUAGE OverloadedStrings #-}     module Kempe.Parser ( parse                         , parseWithMax+                        , parseWithCtx+                        , parseWithInitCtx                         , ParseError (..)                         ) where @@ -74,6 +76,7 @@     name { TokName _ $$ }     tyName { TokTyName  _ $$ }     foreignName { TokForeign _ $$ }+    moduleFile { TokModuleStr _ $$ }      intLit { $$@(TokInt _ _) }     wordLit { $$@(TokWord _ _) }@@ -86,6 +89,7 @@     foreign { TokKeyword $$ KwForeign }     cabi { TokKeyword $$ KwCabi }     kabi { TokKeyword $$ KwKabi }+    import { TokKeyword $$ KwImport }      dip { TokBuiltin $$ BuiltinDip }     boolLit { $$@(TokBuiltin _ (BuiltinBoolLit _)) }@@ -124,8 +128,14 @@     : lparen p rparen { $2 }  Module :: { Module AlexPosn AlexPosn AlexPosn }-       : many(Decl) { (reverse $1) }+       : many(Import) Declarations { Module (reverse $1) $2 } +Declarations :: { Declarations AlexPosn AlexPosn AlexPosn }+             : many(Decl) { (reverse $1) }++Import :: { BSL.ByteString }+       : import moduleFile { $2 }+ ABI :: { ABI }     : cabi { Cabi }     | kabi { Kabi }@@ -236,10 +246,22 @@ parse = fmap snd . parseWithMax  parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)-parseWithMax = fmap (first fst3) . runParse parseModule+parseWithMax = fmap (first fst3) . parseWithInitCtx +parseWithInitCtx :: BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, Module AlexPosn AlexPosn AlexPosn)+parseWithInitCtx bsl = parseWithCtx bsl alexInitUserState++parseWithCtx :: BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, Module AlexPosn AlexPosn AlexPosn)+parseWithCtx = parseWithInitSt parseModule+ runParse :: Parse a -> BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, a) runParse parser str = liftErr $ runAlexSt str (runExceptT parser)++parseWithInitSt :: Parse a -> BSL.ByteString -> AlexUserState -> Either (ParseError AlexPosn) (AlexUserState, a)+parseWithInitSt parser str st = liftErr $ withAlexSt str st (runExceptT parser)+    where liftErr (Left err)            = Left (LexErr err)+          liftErr (Right (_, Left err)) = Left err+          liftErr (Right (i, Right x))  = Right (i, x)  liftErr :: Either String (b, Either (ParseError a) c) -> Either (ParseError a) (b, c) liftErr (Left err)            = Left (LexErr err)

@@ -6,24 +6,28 @@ import           Control.Composition       ((.*)) import           Control.Exception         (throw) import           Data.Bifunctor            (first)+import           Data.Typeable             (Typeable) import           Kempe.AST import           Kempe.Asm.X86 import           Kempe.Asm.X86.ControlFlow import           Kempe.Asm.X86.Linear import           Kempe.Asm.X86.Liveness import           Kempe.Asm.X86.Type+import           Kempe.Check.Restrict import           Kempe.IR import           Kempe.IR.Opt import           Kempe.Shuttle -irGen :: Int -- ^ Thread uniques through-      -> Module a c b -> ([Stmt], WriteSt, SizeEnv)+irGen :: Typeable a+      => Int -- ^ Thread uniques through+      -> Declarations a c b -> ([Stmt], WriteSt, SizeEnv) irGen i m = adjEnv $ first optimize $ runTempM (writeModule env tAnnMod)-    where (tAnnMod, env) = either throw id $ monomorphize i m+    where (tAnnMod, env) = either throw id $ monomorphize i mOk+          mOk = maybe m throw (restrictConstructors m)           adjEnv (x, y) = (x, y, env) -x86Parsed :: Int -> Module a c b -> [X86 AbsReg ()]+x86Parsed :: Typeable a => Int -> Declarations a c b -> [X86 AbsReg ()] x86Parsed i m = let (ir, u, env) = irGen i m in irToX86 env u ir -x86Alloc :: Int -> Module a c b -> [X86 X86Reg ()]+x86Alloc :: Typeable a => Int -> Declarations a c b -> [X86 X86Reg ()] x86Alloc = allocRegs . reconstruct . mkControlFlow .* x86Parsed

@@ -12,8 +12,8 @@ import           Kempe.TyAssign  inlineAssignFlatten :: Int-                    -> Module a c b-                    -> Either (Error ()) (Module () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv))+                    -> Declarations a c b+                    -> Either (Error ()) (Declarations () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv)) inlineAssignFlatten ctx m = do     -- check before inlining otherwise users would get weird errors     void $ do@@ -23,8 +23,8 @@     runMonoM i (flattenModule mTy)  monomorphize :: Int-             -> Module a c b-             -> Either (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)+             -> Declarations a c b+             -> Either (Error ()) (Declarations () (ConsAnn MonoStackType) MonoStackType, SizeEnv) monomorphize ctx m = do     (flat, (_, env)) <- inlineAssignFlatten ctx m     let flatFn' = filter (not . isTyDecl) flat

@@ -18,6 +18,7 @@ import qualified Data.IntMap                as IM import           Data.List                  (foldl') import           Data.List.NonEmpty         (NonEmpty (..))+import           Data.Semigroup             ((<>)) import qualified Data.Set                   as S import qualified Data.Text                  as T import           Data.Tuple.Extra           (fst3)@@ -97,39 +98,53 @@  type TypeM a = StateT (TyState a) (Either (Error a)) -onType :: (Int, KempeTy a) -> KempeTy a -> KempeTy a-onType _ ty'@TyBuiltin{} = ty'-onType _ ty'@TyNamed{}   = ty'-onType (k, ty) ty'@(TyVar _ (Name _ (Unique i) _)) | i == k = ty-                                                   | otherwise = ty'-onType (k, ty) (TyApp l ty' ty'') = TyApp l (onType (k, ty) ty') (onType (k, ty) ty'') -- I think this is right+type UnifyMap = IM.IntMap (KempeTy ()) -renameForward :: (Int, KempeTy a) -> [(KempeTy a, KempeTy a)] -> [(KempeTy a, KempeTy a)]-renameForward _ []                      = []-renameForward (k, ty) ((ty', ty''):tys) = (onType (k, ty) ty', onType (k, ty) ty'') : renameForward (k, ty) tys+inContext :: UnifyMap -> KempeTy () -> KempeTy ()+inContext um ty'@(TyVar _ (Name _ (Unique i) _)) =+    case IM.lookup i um of+        Just ty@TyVar{} -> inContext (IM.delete i um) ty -- prevent cyclic lookups+        Just ty         -> ty+        Nothing         -> ty'+inContext _ ty'@TyBuiltin{} = ty'+inContext _ ty'@TyNamed{} = ty'+inContext um (TyApp l ty ty') = TyApp l (inContext um ty) (inContext um ty') -unify :: [(KempeTy a, KempeTy a)] -> Either (Error ()) (IM.IntMap (KempeTy ()))-unify []                                                             = Right mempty-unify ((ty@(TyBuiltin _ b0), ty'@(TyBuiltin _ b1)):tys) | b0 == b1   = unify tys-                                                        | otherwise  = Left (UnificationFailed () (void ty) (void ty'))-unify ((ty@(TyNamed _ n0), ty'@(TyNamed _ n1)):tys) | n0 == n1       = unify tys+-- | Perform substitutions before handing off to 'unifyMatch'+unifyPrep :: UnifyMap+           -> [(KempeTy (), KempeTy ())]+           -> Either (Error ()) (IM.IntMap (KempeTy ()))+unifyPrep _ [] = Right mempty+unifyPrep um ((ty, ty'):tys) =+    let ty'' = inContext um ty+        ty''' = inContext um ty'+    in unifyMatch um $ (ty'', ty'''):tys++unifyMatch :: UnifyMap -> [(KempeTy (), KempeTy ())] -> Either (Error ()) (IM.IntMap (KempeTy ()))+unifyMatch _ []                                                             = Right mempty+unifyMatch um ((ty@(TyBuiltin _ b0), ty'@(TyBuiltin _ b1)):tys) | b0 == b1   = unifyPrep um tys+                                                                | otherwise  = Left (UnificationFailed () ty ty')+unifyMatch um ((ty@(TyNamed _ n0), ty'@(TyNamed _ n1)):tys) | n0 == n1       = unifyPrep um tys                                                     | otherwise      = Left (UnificationFailed () (void ty) (void ty'))-unify ((ty@(TyNamed _ _), TyVar  _ (Name _ (Unique k) _)):tys)       = IM.insert k (void ty) <$> unify (renameForward (k, ty) tys) -- is this O(n^2) or something bad?-unify ((TyVar _ (Name _ (Unique k) _), ty@(TyNamed _ _)):tys)        = IM.insert k (void ty) <$> unify (renameForward (k, ty) tys) -- FIXME: is renameForward enough?-unify ((ty@(TyBuiltin _ _), TyVar  _ (Name _ (Unique k) _)):tys)     = IM.insert k (void ty) <$> unify (renameForward (k, ty) tys)-unify ((TyVar _ (Name _ (Unique k) _), ty@(TyBuiltin _ _)):tys)      = IM.insert k (void ty) <$> unify (renameForward (k, ty) tys)-unify ((TyVar _ (Name _ (Unique k) _), ty@(TyVar _ _)):tys)          = IM.insert k (void ty) <$> unify (renameForward (k, ty) tys)-unify ((ty@TyBuiltin{}, ty'@TyNamed{}):_)                            = Left (UnificationFailed () (void ty) (void ty'))-unify ((ty@TyNamed{}, ty'@TyBuiltin{}):_)                            = Left (UnificationFailed () (void ty) (void ty'))-unify ((ty@TyBuiltin{}, ty'@TyApp{}):_)                              = Left (UnificationFailed () (void ty) (void ty'))-unify ((ty@TyNamed{}, ty'@TyApp{}):_)                                = Left (UnificationFailed () (void ty) (void ty'))-unify ((ty@TyApp{}, ty'@TyBuiltin{}):_)                              = Left (UnificationFailed () (void ty) (void ty'))-unify ((TyVar _ (Name _ (Unique k) _), ty@TyApp{}):tys)              = IM.insert k (void ty) <$> unify (renameForward (k, ty) tys)-unify ((ty@TyApp{}, TyVar  _ (Name _ (Unique k) _)):tys)             = IM.insert k (void ty) <$> unify (renameForward (k, ty) tys)-unify ((TyApp _ ty ty', TyApp _ ty'' ty'''):tys)                     = unify ((ty, ty'') : (ty', ty''') : tys) -- TODO: I think this is right?-unify ((ty@TyApp{}, ty'@TyNamed{}):_)                                = Left (UnificationFailed () (void ty) (void ty'))+unifyMatch um ((ty@(TyNamed _ _), TyVar  _ (Name _ (Unique k) _)):tys)       = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys+unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@(TyNamed _ _)):tys)        = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys+unifyMatch um ((ty@TyBuiltin{}, TyVar  _ (Name _ (Unique k) _)):tys)         = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys+unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@(TyBuiltin _ _)):tys)      = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys+unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@(TyVar _ _)):tys)          = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys+unifyMatch _ ((ty@TyBuiltin{}, ty'@TyNamed{}):_)                             = Left (UnificationFailed () ty ty')+unifyMatch _ ((ty@TyNamed{}, ty'@TyBuiltin{}):_)                             = Left (UnificationFailed () ty ty')+unifyMatch _ ((ty@TyBuiltin{}, ty'@TyApp{}):_)                               = Left (UnificationFailed () ty ty')+unifyMatch _ ((ty@TyNamed{}, ty'@TyApp{}):_)                                 = Left (UnificationFailed () ty ty')+unifyMatch _ ((ty@TyApp{}, ty'@TyBuiltin{}):_)                               = Left (UnificationFailed () ty ty')+unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@TyApp{}):tys)              = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys+unifyMatch um ((ty@TyApp{}, TyVar  _ (Name _ (Unique k) _)):tys)             = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys+unifyMatch um ((TyApp _ ty ty', TyApp _ ty'' ty'''):tys)                     = unifyMatch um ((ty, ty'') : (ty', ty''') : tys) -- TODO: I think this is right?+unifyMatch _ ((ty@TyApp{}, ty'@TyNamed{}):_)                                 = Left (UnificationFailed () (void ty) (void ty')) -unifyM :: S.Set (KempeTy a, KempeTy a) -> TypeM () (IM.IntMap (KempeTy ()))+unify :: [(KempeTy (), KempeTy ())] -> Either (Error ()) (IM.IntMap (KempeTy ()))+unify = unifyPrep IM.empty++unifyM :: S.Set (KempeTy (), KempeTy ()) -> TypeM () (IM.IntMap (KempeTy ())) unifyM s =     case {-# SCC "unify" #-} unify (S.toList s) of         Right x  -> pure x@@ -409,13 +424,13 @@ tyInsert ExtFnDecl{} = pure () -- TODO: kind-check tyInsert Export{} = pure () -tyModule :: Module a c b -> TypeM () ()+tyModule :: Declarations a c b -> TypeM () () tyModule m = traverse_ tyHeader m *> traverse_ tyInsert m -checkModule :: Module a c b -> TypeM () ()+checkModule :: Declarations a c b -> TypeM () () checkModule m = tyModule m <* (unifyM =<< gets constraints) -assignModule :: Module a c b -> TypeM () (Module () (StackType ()) (StackType ()))+assignModule :: Declarations a c b -> TypeM () (Declarations () (StackType ()) (StackType ())) assignModule m = {-# SCC "assignModule" #-} do     traverse_ tyHeader m     m' <- traverse assignDecl m

@@ -1,16 +1,29 @@ {-# LANGUAGE OverloadedStrings #-}  module Prettyprinter.Ext ( (<#>)+                         , (<##>)                          , prettyHex+                         , prettyLines+                         , sepDecls                          ) where  import           Numeric       (showHex) import           Prettyprinter  infixr 6 <#>+infixr 6 <##>  (<#>) :: Doc a -> Doc a -> Doc a (<#>) x y = x <> hardline <> y +(<##>) :: Doc a -> Doc a -> Doc a+(<##>) x y = x <> hardline <> hardline <> y+ prettyHex :: (Integral a, Show a) => a -> Doc ann prettyHex x = "0x" <> pretty (showHex x mempty)++prettyLines :: [Doc ann] -> Doc ann+prettyLines = concatWith (<#>)++sepDecls :: [Doc ann] -> Doc ann+sepDecls = concatWith (<##>)

@@ -0,0 +1,36 @@+-- | This is to ensure consistency in the ABI.+module Abi ( backendGolden+           ) where++import           Control.Composition       ((.*))+import qualified Data.Text.Lazy            as TL+import           Data.Text.Lazy.Encoding   (encodeUtf8)+import           Data.Typeable             (Typeable)+import           Kempe.AST+import           Kempe.File+import           Kempe.Module+import           Prettyprinter             (defaultLayoutOptions, layoutPretty)+import           Prettyprinter.Render.Text (renderLazy)+import           Test.Tasty+import           Test.Tasty.Golden         (goldenVsString)++backendGolden :: TestTree+backendGolden =+    testGroup "IR goldens"+        [ goldenIR "test/data/abi.kmp" "test/golden/abi.ir"+        , goldenIR "lib/gaussian.kmp" "test/golden/gaussian.ir"+        -- not for ABI, to test it imports the right thing (transitively)+        , goldenIR "test/data/diamond/a.kmp" "test/golden/a.ir"+        ]++dumpIRLazyText :: Typeable a => Int -> Declarations a c b -> TL.Text+dumpIRLazyText = renderLazy . layoutPretty defaultLayoutOptions .* dumpIR++goldenIR :: FilePath+         -> FilePath+         -> TestTree+goldenIR fp out =+    goldenVsString fp out $+        do+            res <- parseProcess fp+            pure $ encodeUtf8 $ uncurry dumpIRLazyText res

@@ -4,8 +4,8 @@ import           Control.DeepSeq           (deepseq) import           Kempe.Asm.X86.ControlFlow import           Kempe.Asm.X86.Liveness-import           Kempe.File import           Kempe.Inline+import           Kempe.Module import           Kempe.Monomorphize import           Kempe.Pipeline import           Kempe.Shuttle@@ -46,32 +46,32 @@  codegen :: FilePath -> TestTree codegen fp = testCase ("Generates code without throwing an exception (" ++ fp ++ ")") $ do-    parsed <- parsedFp fp+    parsed <- parseProcess fp     let code = uncurry x86Alloc parsed     assertBool "Doesn't fail" (code `deepseq` True)  liveness :: FilePath -> TestTree liveness fp = testCase ("Liveness analysis terminates (" ++ fp ++ ")") $ do-    parsed <- parsedFp fp+    parsed <- parseProcess fp     let x86 = uncurry x86Parsed parsed         cf = mkControlFlow x86     assertBool "Doesn't bottom" (reconstruct cf `deepseq` True)  controlFlowGraph :: FilePath -> TestTree controlFlowGraph fp = testCase ("Doesn't crash while creating control flow graph for " ++ fp) $ do-    parsed <- parsedFp fp+    parsed <- parseProcess fp     let x86 = uncurry x86Parsed parsed     assertBool "Worked without exception" (mkControlFlow x86 `deepseq` True)  x86NoYeet :: FilePath -> TestTree x86NoYeet fp = testCase ("Selects instructions for " ++ fp) $ do-    parsed <- parsedFp fp+    parsed <- parseProcess fp     let x86 = uncurry x86Parsed parsed     assertBool "Worked without exception" (x86 `deepseq` True)  irNoYeet :: FilePath -> TestTree irNoYeet fp = testCase ("Generates IR without throwing an exception (" ++ fp ++ ")") $ do-    (i, m) <- parsedFp fp+    (i, m) <- parseProcess fp     let (res, _, _) = irGen i m     assertBool "Worked without failure" (res `deepseq` True) @@ -80,7 +80,7 @@  inlineFile :: FilePath -> Assertion inlineFile fp = do-    (_, m) <- parsedFp fp+    (_, m) <- parseProcess fp     let res = inline m     assertBool "Doesn't bottom when inlining" (res `deepseq` True) @@ -95,7 +95,7 @@  pipelineWorks :: FilePath -> TestTree pipelineWorks fp = testCase ("Functions in " ++ fp ++ " can be specialized") $ do-    (maxU, m) <- parsedFp fp+    (maxU, m) <- parseProcess fp     let res = monomorphize maxU m     case res of         Left err -> assertFailure (show $ pretty err)

@@ -2,6 +2,7 @@  module Main (main) where +import           Abi import           Backend import           Parser import           Test.Tasty@@ -13,4 +14,5 @@         [ parserTests         , typeTests         , backendTests+        , backendGolden         ]

@@ -7,6 +7,7 @@ import           Control.Exception (Exception, throwIO) import           Kempe.AST import           Kempe.File+import           Kempe.Module import           Kempe.TyAssign import           Prettyprinter     (pretty) import           Test.Tasty@@ -24,9 +25,13 @@         , tyInfer "lib/bool.kmp"         , tyInfer "examples/hamming.kmp"         , tyInfer "lib/gaussian.kmp"+        , tyInfer "test/data/transitive.kmp"+        , tyInfer "lib/tuple.kmp"         , badType "test/err/merge.kmp" "Type a_5 -- Int a_4 is not as general as type a_3 -- a_3 a_3"         , badType "test/err/kind.kmp" "Ill-kinded type: '(Maybe_1 Maybe_1)'. Note that type variables have kind \11089 in Kempe."         , badType "test/err/patternMatch.kmp" "Inexhaustive pattern match."+        , detectsWarn "test/err/stupid.kmp" "4:1 'rand_1' is defined more than once."+        , detectsWarn "test/err/questionable.kmp" "3:19 'Some_3' is defined more than once."         , testAssignment "test/data/ty.kmp"         , testAssignment "lib/either.kmp"         , testAssignment "prelude/fn.kmp"@@ -36,9 +41,9 @@ yeetIO :: Exception e => Either e a -> IO a yeetIO = either throwIO pure -assignTypes :: FilePath -> IO (Module () (StackType ()) (StackType ()), Int)+assignTypes :: FilePath -> IO (Declarations () (StackType ()) (StackType ()), Int) assignTypes fp = do-    (maxU, m) <- parsedFp fp+    (maxU, m) <- parseProcess fp     yeetIO $ runTypeM maxU (assignModule m)  testAssignment :: FilePath -> TestTree@@ -52,6 +57,13 @@     case res of         Left err -> assertFailure (show $ pretty err)         Right{}  -> assertBool "Doesn't fail type-checking" True++detectsWarn :: FilePath -> String -> TestTree+detectsWarn fp msg = testCase ("Warns (" ++ fp ++ ")") $ do+    res <- warnFile fp+    case res of+        Just err -> show (pretty err) @?= msg+        Nothing  -> assertFailure "Failed to warn!"  badType :: FilePath -> String -> TestTree badType fp msg = testCase ("Detects error (" ++ fp ++ ")") $ do

@@ -0,0 +1,10 @@+type Param a b c+    { C a b b+    | D a b c+    }++; this should have 7 bytes of padding before the D, so as to match a C constructor+mkConcrete : -- (((Param Int8) Int) Int8)+      =: [ 0i8 0 0i8 D ]++%foreign kabi mkConcrete

@@ -1,6 +1,5 @@-type Either a b { Left a | Right b }--type Maybe a { Just a | Nothing }+import "lib/maybe.kmp"+import "lib/either.kmp"  mkJustRight : Int -- ((Either Int) (Maybe Int))             =: [ Just Right ]

@@ -1,10 +1,4 @@-not : Bool -- Bool-    =: [-    { case-        | True -> False-        | _    -> True-    }-]+import "lib/bool.kmp"  odd : Int -- Bool     =: [ dup 0 =

@@ -0,0 +1,6 @@+import "lib/tuple.kmp"++enTuple : Int Int -- ((Pair Int) Int)+        =: [ Pair ]++%foreign kabi enTuple

@@ -0,0 +1,4 @@+type Maybe a { Just a | Nothing }++poorlyKinded : (Maybe Maybe) --+             =: [ drop ]

@@ -0,0 +1,2 @@+dup0 : a -- a a+     =: [ dip(3) ]

@@ -0,0 +1,6 @@+not : Bool -- Bool+    =: [+    { case+        | True  -> False+    }+]

@@ -0,0 +1,3 @@+type Option a { Some a | None }++type Optional a { Some a | None }

@@ -0,0 +1,5 @@+rand : -- Int+     =: [ 3 ]++rand : -- Int+     =: $cfun"rand"

@@ -0,0 +1,19 @@+not : Bool -- Bool+    =: [+    { case+        | True  -> False+        | False -> True+    }+]++eq : Bool Bool -- Bool+   =: [ xor not ]++nand : Bool Bool -- Bool+     =: [ & not ]++nor : Bool Bool -- Bool+    =: [ || not ]++%foreign cabi not+%foreign cabi eq

@@ -0,0 +1,4 @@+hamming : Word Word -- Int+        =: [ xoru popcount ]++%foreign cabi hamming

@@ -0,0 +1,11 @@+next : Word -- Word Word+     =: [ 0x9e3779b97f4a7c15u +~ dup+          dup 30i8 >>~ xoru 0xbf58476d1ce4e5b9u *~+          dup 27i8 >>~ xoru 0x94d049bb133111ebu *~+          dup 31i8 >>~ xoru+        ]++from_seed : Word -- Word+          =: [ next dip(drop) ]++%foreign cabi from_seed

@@ -0,0 +1,19 @@++kmp1:+(movmem (reg datapointer) (int 17))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (int 1))+(movtemp t_1 (mem [8] (reg datapointer)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_2 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (+ (reg t_2) (reg t_1)))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (int 2))+(movtemp t_3 (mem [8] (reg datapointer)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_4 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (* (reg t_4) (reg t_3)))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(ret)++export forExport { -- Int} kmp1

@@ -0,0 +1,13 @@++kmp1:+(movmem (reg datapointer) (int8 0))+(movtemp datapointer (+ (reg datapointer) (int 1)))+(movmem (reg datapointer) (int 0))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (int8 0))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (tag 0x1))+(movtemp datapointer (+ (reg datapointer) (int 1)))+(ret)++export mkConcrete { -- (((Param_1 Int8) Int) Int8)} kmp1

@@ -0,0 +1,3 @@+0+1+0

@@ -0,0 +1,2 @@+6+6

@@ -0,0 +1,76 @@++kmp1:+(movtemp datapointer (- (reg datapointer) (int 17)))+(mjump (=b (mem [1] (+ (reg datapointer) (int 0))) (tag 0x0)) kmp4)++kmp4:+(j kmp5)++kmp5:+(ret)++kmp2:+(movtemp datapointer (- (reg datapointer) (int 17)))+(call kmp1)+(movmem (- (reg datapointer) (int 0)) (mem [1] (+ (reg datapointer) (int 17))))+(movmem (+ (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 18))))+(movmem (+ (reg datapointer) (int 2)) (mem [1] (+ (reg datapointer) (int 19))))+(movmem (+ (reg datapointer) (int 3)) (mem [1] (+ (reg datapointer) (int 20))))+(movmem (+ (reg datapointer) (int 4)) (mem [1] (+ (reg datapointer) (int 21))))+(movmem (+ (reg datapointer) (int 5)) (mem [1] (+ (reg datapointer) (int 22))))+(movmem (+ (reg datapointer) (int 6)) (mem [1] (+ (reg datapointer) (int 23))))+(movmem (+ (reg datapointer) (int 7)) (mem [1] (+ (reg datapointer) (int 24))))+(movmem (+ (reg datapointer) (int 8)) (mem [1] (+ (reg datapointer) (int 25))))+(movmem (+ (reg datapointer) (int 9)) (mem [1] (+ (reg datapointer) (int 26))))+(movmem (+ (reg datapointer) (int 10)) (mem [1] (+ (reg datapointer) (int 27))))+(movmem (+ (reg datapointer) (int 11)) (mem [1] (+ (reg datapointer) (int 28))))+(movmem (+ (reg datapointer) (int 12)) (mem [1] (+ (reg datapointer) (int 29))))+(movmem (+ (reg datapointer) (int 13)) (mem [1] (+ (reg datapointer) (int 30))))+(movmem (+ (reg datapointer) (int 14)) (mem [1] (+ (reg datapointer) (int 31))))+(movmem (+ (reg datapointer) (int 15)) (mem [1] (+ (reg datapointer) (int 32))))+(movmem (+ (reg datapointer) (int 16)) (mem [1] (+ (reg datapointer) (int 33))))+(mjump (=b (mem [1] (+ (reg datapointer) (int 0))) (tag 0x0)) kmp6)++kmp6:+(j kmp7)++kmp7:+(movmem (- (reg datapointer) (int 0)) (mem [8] (- (reg datapointer) (int 24))))+(movmem (- (reg datapointer) (int 24)) (mem [8] (- (reg datapointer) (int 16))))+(movmem (- (reg datapointer) (int 16)) (mem [8] (- (reg datapointer) (int 0))))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_1 (mem [8] (reg datapointer)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_2 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (+ (reg t_2) (reg t_1)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_3 (mem [8] (reg datapointer)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_4 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (+ (reg t_4) (reg t_3)))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (- (reg datapointer) (int 0)) (mem [8] (+ (reg datapointer) (int 8))))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (tag 0x0))+(movtemp datapointer (+ (reg datapointer) (int 1)))+(ret)++kmp3:+(movtemp datapointer (- (reg datapointer) (int 17)))+(mjump (=b (mem [1] (+ (reg datapointer) (int 0))) (tag 0x0)) kmp8)++kmp8:+(j kmp9)++kmp9:+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_5 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (~ (reg t_5)))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (tag 0x0))+(movtemp datapointer (+ (reg datapointer) (int 1)))+(ret)++export add {Gaussian_1 Gaussian_1 -- Gaussian_1} kmp2++export conjugate {Gaussian_1 -- Gaussian_1} kmp3

@@ -0,0 +1,1 @@+2

@@ -0,0 +1,3 @@+1+0+7

@@ -0,0 +1,1 @@+3631356771

@@ -0,0 +1,12 @@+#include <stdbool.h>+#include <stdio.h>++extern bool not(bool);+extern bool eq(bool, bool);++int main(int argc, char *argv[]) {+    printf("%d\n", not(true));+    printf("%d\n", not(false));+    printf("%d", eq(true, false));+}+

@@ -0,0 +1,9 @@+#include <stdio.h>++extern int fac_tailrec(int);+extern int fac(int);++int main(int argc, char *argv[]) {+    printf("%d\n", fac_tailrec(3));+    printf("%d", fac(3));+}

@@ -0,0 +1,8 @@+#include <stdint.h>+#include <stdio.h>++extern int hamming(uint64_t, uint64_t);++int main(int argc, char *argv[]) {+    printf("%d", hamming(5, 3));+}

@@ -0,0 +1,11 @@+#include <stdbool.h>+#include <stdio.h>++extern int k_gcd(int, int);+extern bool is_prime(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));+}

@@ -0,0 +1,8 @@+#include <stdint.h>+#include <stdio.h>++extern uint64_t from_seed(uint64_t);++int main(int argc, char *argv[]) {+    printf("%u", (unsigned int) from_seed(3012512025));+}