kempe (empty) → 0.1.0.0
raw patch · 47 files changed
+5013/−0 lines, 47 filesdep +arraydep +basedep +bytestringbinary-added
Dependencies added: array, base, bytestring, composition-prelude, containers, criterion, deepseq, extra, filepath, kempe, microlens, microlens-mtl, mtl, optparse-applicative, prettyprinter, process, tasty, tasty-golden, tasty-hunit, temporary, text, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- README.md +37/−0
- bench/Bench.hs +140/−0
- docs/manual.pdf binary
- kempe.cabal +218/−0
- lib/bool.kmp +16/−0
- lib/either.kmp +20/−0
- lib/gaussian.kmp +23/−0
- lib/maybe.kmp +17/−0
- lib/numbertheory.kmp +40/−0
- prelude/fn.kmp +34/−0
- run/Main.hs +69/−0
- src/Data/Foldable/Ext.hs +7/−0
- src/Kempe/AST.hs +310/−0
- src/Kempe/Asm/X86.hs +373/−0
- src/Kempe/Asm/X86/ControlFlow.hs +180/−0
- src/Kempe/Asm/X86/Linear.hs +260/−0
- src/Kempe/Asm/X86/Liveness.hs +65/−0
- src/Kempe/Asm/X86/Type.hs +335/−0
- src/Kempe/Error.hs +44/−0
- src/Kempe/File.hs +82/−0
- src/Kempe/IR.hs +571/−0
- src/Kempe/IR/Opt.hs +37/−0
- src/Kempe/Inline.hs +88/−0
- src/Kempe/Lexer.x +383/−0
- src/Kempe/Monomorphize.hs +285/−0
- src/Kempe/Name.hs +32/−0
- src/Kempe/Parser.y +254/−0
- src/Kempe/Pipeline.hs +29/−0
- src/Kempe/Proc/Nasm.hs +21/−0
- src/Kempe/Shuttle.hs +32/−0
- src/Kempe/TyAssign.hs +552/−0
- src/Kempe/Unique.hs +9/−0
- src/Prettyprinter/Ext.hs +16/−0
- test/Backend.hs +101/−0
- test/Golden.hs +14/−0
- test/Harness.hs +38/−0
- test/Parser.hs +33/−0
- test/Spec.hs +16/−0
- test/Type.hs +60/−0
- test/data/ccall.kmp +7/−0
- test/data/export.kmp +11/−0
- test/data/lex.kmp +63/−0
- test/data/maybeC.kmp +7/−0
- test/data/mutual.kmp +22/−0
- test/data/ty.kmp +46/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# kempe++## 0.1.0.0++Initial release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright Vanessa McHale (c) 2020++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,37 @@+# Kempe++Kempe is a stack-based language and toy compiler for x86_64. It requires the+[nasm](https://nasm.us/) assembler.++Inspiration is primarily from [Mirth](https://github.com/mirth-lang/mirth).++See manual+[here](http://hackage.haskell.org/package/kempe/src/doc/manual.pdf).++## Installation++Installation is via [cabal-install](https://www.haskell.org/cabal/):++```+cabal install kempe+```++For shell completions put the following in your `~/.bashrc` or+`~/.bash_profile`:++```+eval "$(kc --bash-completion-script kc)"+```++## Defects++ * Unification takes too long+ * Errors don't have position information+ * Monomorphization fails on recursive polymorphic functions+ * If pattern matches fail at runtime, code just keeps running with whatever+ was after the jumps (no pattern match exhaustiveness checker)+ * 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
+ bench/Bench.hs view
@@ -0,0 +1,140 @@+module Main (main) where++import Control.Exception (Exception, throw, throwIO)+import Criterion.Main+import Data.Bifunctor (Bifunctor, bimap)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import Kempe.Asm.X86+import Kempe.Asm.X86.ControlFlow+import Kempe.Asm.X86.Linear+import Kempe.Asm.X86.Liveness+import Kempe.File+import Kempe.IR+import Kempe.IR.Opt+import Kempe.Inline+import Kempe.Lexer+import Kempe.Monomorphize+import Kempe.Parser+import Kempe.Pipeline+import Kempe.Shuttle+import Kempe.TyAssign+import Prettyprinter (defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict)++bivoid :: Bifunctor p => p a b -> p () ()+bivoid = bimap (const ()) (const ())++main :: IO ()+main =+ defaultMain [ env (BSL.readFile "test/data/lex.kmp") $ \contents ->+ bgroup "parser"+ [ bench "lex" $ nf lexKempe contents+ , bench "parse" $ nf parse contents+ ]+ , env forTyEnv $ \ ~(p, s, prel) ->+ bgroup "type assignment"+ [ bench "check (test/data/ty.kmp)" $ nf runCheck p+ , bench "check (prelude/fn.kmp)" $ nf runCheck prel+ , bench "assign (test/data/ty.kmp)" $ nf runAssign p+ , bench "assign (prelude/fn.kmp)" $ nf runAssign prel+ , bench "shuttle (test/data/ty.kmp)" $ nf (uncurry monomorphize) p+ , bench "shuttle (examples/splitmix.kmp)" $ nf (uncurry monomorphize) s+ , bench "closedModule" $ nf (runSpecialize =<<) (runAssign p)+ , bench "closure" $ nf (\m -> closure (m, mkModuleMap m)) (bivoid <$> snd p)+ ]+ , env parsedInteresting $ \ ~(f, n) ->+ bgroup "Inliner"+ [ bench "examples/factorial.kmp" $ nf inline (snd f)+ , bench "lib/numbertheory.kmp" $ nf inline (snd n)+ ]+ , env irEnv $ \ ~(s, f, n) ->+ bgroup "IR"+ [ bench "IR pipeline (examples/splitmix.kmp)" $ nf (fst . runIR) s -- IR benchmarks are a bit silly; I will use them to decide if I should use difference lists+ , bench "IR pipeline (examples/factorial.kmp)" $ nf (fst . runIR) f+ , bench "IR pipeline (lib/numbertheory.kmp)" $ nf (fst . runIR) n+ ]+ , env envIR $ \ ~(s, f) ->+ bgroup "opt"+ [ bench "IR optimization (examples/splitmix.kmp)" $ nf optimize s+ , bench "IR optimization (examples/factorial.kmp)" $ nf optimize f+ ]+ , env irEnv $ \ ~(s, f, _) ->+ bgroup "Instruction selection"+ [ bench "X86 (examples/factorial.kmp)" $ nf genX86 f+ , bench "X86 (examples/splitmix.kmp)" $ nf genX86 s+ ]+ , env x86Env $ \ ~(s, f) ->+ bgroup "Control flow graph"+ [ bench "X86 (examples/factorial.kmp)" $ nf mkControlFlow f+ , bench "X86 (examples/splitmix.kmp)" $ nf mkControlFlow s+ ]+ , env cfEnv $ \ ~(s, f, n) ->+ bgroup "Liveness analysis"+ [ bench "X86 (examples/factorial.kmp)" $ nf reconstruct f+ , bench "X86 (examples/splitmix.kmp)" $ nf reconstruct s+ , bench "X86 (lib/numbertheory.kmp)" $ nf reconstruct n+ ]+ , env absX86 $ \ ~(s, f, n) ->+ bgroup "Register allocation"+ [ bench "X86/linear (examples/factorial.kmp)" $ nf allocRegs f+ , bench "X86/linear (examples/splitmix.kmp)" $ nf allocRegs s+ , bench "X86/linear (lib/numbertheory.kmp)" $ nf allocRegs n+ ]+ , bgroup "Pipeline"+ [ bench "Validate (examples/factorial.kmp)" $ nfIO (tcFile "examples/factorial.kmp")+ , bench "Validate (examples/splitmix.kmp)" $ nfIO (tcFile "examples/splitmix.kmp")+ , bench "Validate (lib/numbertheory.kmp)" $ nfIO (tcFile "lib/numbertheory.kmp")+ , bench "Generate assembly (examples/factorial.kmp)" $ nfIO (writeAsm "examples/factorial.kmp")+ , bench "Generate assembly (examples/splitmix.kmp)" $ nfIO (writeAsm "examples/splitmix.kmp")+ , 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)+ ]+ ]+ 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"+ parsedInteresting = (,) <$> fac <*> num+ prelude = yeetIO . parseWithMax =<< BSL.readFile "prelude/fn.kmp"+ forTyEnv = (,,) <$> parsedM <*> splitmix <*> prelude+ runCheck (maxU, m) = runTypeM maxU (checkModule m)+ runAssign (maxU, m) = runTypeM maxU (assignModule m)+ runSpecialize (m, i) = runMonoM i (closedModule m)+ splitmixMono = either throw id . uncurry monomorphize <$> splitmix+ facMono = either throw id . uncurry monomorphize <$> fac+ numMono = either throw id . uncurry monomorphize <$> num+ irEnv = (,,) <$> splitmixMono <*> facMono <*> numMono+ -- TODO: bench optimization+ runIR = runTempM . yrrucnu writeModule+ genIR = fst . runTempM . yrrucnu writeModule+ genX86 m = let (ir, u) = runIR m in irToX86 undefined u (optimize ir)+ facIR = genIR <$> facMono+ splitmixIR = genIR <$> splitmixMono+ envIR = (,) <$> splitmixIR <*> facIR+ facX86 = genX86 <$> facMono+ splitmixX86 = genX86 <$> splitmixMono+ x86Env = (,) <$> splitmixX86 <*> facX86+ numX86 = uncurry x86Parsed <$> num+ facX86Cf = mkControlFlow <$> facX86+ splitmixX86Cf = mkControlFlow <$> splitmixX86+ numX86Cf = mkControlFlow <$> numX86+ cfEnv = (,,) <$> splitmixX86Cf <*> facX86Cf <*> numX86Cf+ facAbsX86 = reconstruct <$> facX86Cf+ splitmixAbsX86 = reconstruct <$> splitmixX86Cf+ numAbsX86 = reconstruct <$> numX86Cf+ absX86 = (,,) <$> splitmixAbsX86 <*> facAbsX86 <*> numAbsX86+ -- 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+ pure $ renderText $ uncurry dumpX86 res+ where renderText = renderStrict . layoutPretty defaultLayoutOptions
+ docs/manual.pdf view
binary file changed (absent → 211605 bytes)
+ kempe.cabal view
@@ -0,0 +1,218 @@+cabal-version: 3.0+name: kempe+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENSE+copyright: Copyright: (c) 2020 Vanessa McHale+maintainer: vamchale@gmail.com+author: Vanessa McHale+synopsis: Kempe compiler+description: Kempe is a stack-based language+category: Language, Compilers+build-type: Simple+data-files:+ test/data/*.kmp+ prelude/*.kmp+ lib/*.kmp+ docs/manual.pdf++extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/vmchale/kempe++flag cross+ description: Enable to ease cross-compiling+ default: False+ manual: True++library kempe-modules+ exposed-modules:+ Kempe.Lexer+ Kempe.Parser+ Kempe.AST+ Kempe.TyAssign+ Kempe.File+ Kempe.Monomorphize+ Kempe.Pipeline+ Kempe.Shuttle+ Kempe.Inline+ Kempe.IR+ Kempe.IR.Opt+ Kempe.Asm.X86+ Kempe.Asm.X86.ControlFlow+ Kempe.Asm.X86.Liveness+ Kempe.Asm.X86.Linear++ hs-source-dirs: src+ other-modules:+ Kempe.Unique+ Kempe.Name+ Kempe.Error+ Kempe.Asm.X86.Type+ Kempe.Proc.Nasm+ Prettyprinter.Ext+ Data.Foldable.Ext++ default-language: Haskell2010+ other-extensions:+ DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable+ FlexibleContexts GeneralizedNewtypeDeriving OverloadedStrings+ StandaloneDeriving TupleSections DeriveAnyClass++ ghc-options: -Wall -O2+ build-depends:+ base >=4.11 && <5,+ array -any,+ bytestring -any,+ containers >=0.6.0.0,+ deepseq -any,+ text -any,+ mtl -any,+ microlens -any,+ transformers -any,+ extra -any,+ prettyprinter >=1.7.0,+ composition-prelude >=1.1.0.1,+ microlens-mtl -any,+ process >=1.2.3.0,+ temporary -any++ if !flag(cross)+ build-tool-depends: alex:alex -any, happy:happy -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++executable kc+ main-is: Main.hs+ hs-source-dirs: run+ other-modules: Paths_kempe+ autogen-modules: Paths_kempe+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base -any,+ optparse-applicative -any,+ kempe-modules -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++test-suite kempe-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules:+ Parser+ Type+ Backend++ default-language: Haskell2010+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall+ build-depends:+ base -any,+ kempe-modules -any,+ tasty -any,+ tasty-hunit -any,+ bytestring -any,+ prettyprinter >=1.7.0,+ deepseq -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++test-suite kempe-golden+ type: exitcode-stdio-1.0+ main-is: Golden.hs+ hs-source-dirs: test+ other-modules: Harness+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -K1K" -Wall+ build-depends:+ base -any,+ kempe-modules -any,+ tasty -any,+ bytestring -any,+ process -any,+ temporary -any,+ filepath -any,+ tasty-golden -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages++benchmark kempe-bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs: bench+ default-language: Haskell2010+ ghc-options: -O3 -Wall+ build-depends:+ base -any,+ kempe-modules -any,+ bytestring -any,+ criterion -any,+ prettyprinter -any,+ text -any++ if impl(ghc >=8.0)+ ghc-options:+ -Wincomplete-uni-patterns -Wincomplete-record-updates+ -Wredundant-constraints -Widentities++ if impl(ghc >=8.4)+ ghc-options: -Wmissing-export-lists++ if impl(ghc >=8.2)+ ghc-options: -Wcpp-undef++ if impl(ghc >=8.10)+ ghc-options: -Wunused-packages
+ lib/bool.kmp view
@@ -0,0 +1,16 @@+not : Bool -- Bool+ =: [+ { case+ | True -> False+ | False -> True+ }+]++eq : Bool Bool -- Bool+ =: [ xor not ]++nand : Bool Bool -- Bool+ =: [ & not ]++nor : Bool Bool -- Bool+ =: [ || not ]
+ lib/either.kmp view
@@ -0,0 +1,20 @@+; I'm not sure how useful this module is but I have it as a test for the+; typechecker and I guess to show how pattern matching works.++type Either a b { Left a | Right b }++isLeft : ((Either a) b) -- Bool+ =: [+ { case+ | Left -> drop True+ | Right -> drop False+ }+]++isRight : ((Either a) b) -- Bool+ =: [+ { case+ | Right -> drop True+ | Left -> drop False+ }+]
+ lib/gaussian.kmp view
@@ -0,0 +1,23 @@+; Gaussian integers++type Gaussian { Gaussian Int Int }++unGaussian : Gaussian -- Int Int+ =: [+ { case+ | Gaussian ->+ }+]++grp : a b c -- b a c+ =: [ dip(swap) ]++; perhaps unimpressive but I use this to test sizing+add : Gaussian Gaussian -- Gaussian+ =: [ dip(unGaussian) unGaussian grp + dip(+) Gaussian ]++conjugate : Gaussian -- Gaussian+ =: [ unGaussian ~ Gaussian ]++%foreign kabi add+%foreign kabi conjugate
+ lib/maybe.kmp view
@@ -0,0 +1,17 @@+type Maybe a { Just a | Nothing }++isJust : (Maybe a) -- Bool+ =: [+ { case+ | Just -> drop True+ | Nothing -> False+ }+]++isNothing : (Maybe a) -- Bool+ =: [+ { case+ | Nothing -> True+ | Just -> drop False+ }+]
+ lib/numbertheory.kmp view
@@ -0,0 +1,40 @@+; 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 * ]++divides : Int Int -- Bool+ =: [ % 0 = ]++; also tail recursive!+;+; kinda sus in that squaring will be integer overflow tho+is_prime_step : Int Int -- Bool+ =: [ dup2 divides+ if( drop drop False+ , dup2 square <+ if( 1 + is_prime_step+ , drop drop True+ )+ )+ ]++is_prime : Int -- Bool+ =: [ 2 is_prime_step ]++k_gcd : Int Int -- Int+ =: [ gcd ]++%foreign cabi k_gcd+%foreign cabi is_prime
+ prelude/fn.kmp view
@@ -0,0 +1,34 @@+; from mirth++id : a -- a+ =: [ ]++trip : a -- a a a+ =: [ dup dup ]++rotr : a b c -- c a b+ =: [ swap dip(swap) ]++rotl : a b c -- c b a+ =: [ dip(swap) swap ]++over : a b -- a b a+ =: [ dip(dup) swap ]++tuck : a b -- b a b+ =: [ dup dip(swap) ]++nip : a b -- b+ =: [ dip(drop) ]++dup2 : a b -- a b a b+ =: [ over over ]++dup3 : a b c -- a b c a b c+ =: [ dip(dup2) dup dip(rotr) ]++drop2 : a b --+ =: [ drop drop ]++drop3 : a b c --+ =: [ drop drop drop ]
+ run/Main.hs view
@@ -0,0 +1,69 @@+module Main (main) where++import Control.Exception (throwIO)+import qualified Data.Version as V+import Kempe.File+import Options.Applicative+import qualified Paths_kempe as P+import System.Exit (ExitCode (ExitFailure), exitWith)++data Command = TypeCheck !FilePath+ | Compile !FilePath !(Maybe FilePath) !Bool !Bool !Bool -- TODO: take arch on cli++run :: Command -> IO ()+run (TypeCheck fp) = either throwIO pure =<< tcFile 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+run (Compile fp Nothing False False True) = x86File fp+run _ = putStrLn "Invalid combination of CLI options. Try kc --help" *> exitWith (ExitFailure 1)++kmpFile :: Parser FilePath+kmpFile = argument str+ (metavar "FILE"+ <> help "Source file"+ <> kmpCompletions)++debugSwitch :: Parser Bool+debugSwitch = switch+ (long "debug"+ <> short 'g'+ <> help "Include debug symbols")++irSwitch :: Parser Bool+irSwitch = switch+ (long "dump-ir"+ <> help "Write intermediate representation to stdout")++asmSwitch :: Parser Bool+asmSwitch = switch+ (long "dump-asm"+ <> help "Write assembly (intel syntax) to stdout")++exeFile :: Parser (Maybe FilePath)+exeFile = optional $ argument str+ (metavar "OUTPUT"+ <> help "File output")++kmpCompletions :: HasCompleter f => Mod f a+kmpCompletions = completer . bashCompleter $ "file -X '!*.kmp' -o plusdirs"++commandP :: Parser Command+commandP = hsubparser+ (command "typecheck" (info tcP (progDesc "Type-check module contents")))+ <|> compileP+ where+ tcP = TypeCheck <$> kmpFile+ compileP = Compile <$> kmpFile <*> exeFile <*> debugSwitch <*> irSwitch <*> asmSwitch++wrapper :: ParserInfo Command+wrapper = info (helper <*> versionMod <*> commandP)+ (fullDesc+ <> progDesc "Kempe language compiler, x86_64 backend"+ <> header "Kempe - a stack-based language")++versionMod :: Parser (a -> a)+versionMod = infoOption (V.showVersion P.version) (short 'V' <> long "version" <> help "Show version")++main :: IO ()+main = run =<< execParser wrapper
+ src/Data/Foldable/Ext.hs view
@@ -0,0 +1,7 @@+module Data.Foldable.Ext ( foldMapA+ ) where++import Data.Foldable (fold)++foldMapA :: (Applicative f, Traversable t, Monoid m) => (a -> f m) -> t a -> f m+foldMapA = (fmap fold .) . traverse
+ src/Kempe/AST.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Frontend AST+module Kempe.AST ( BuiltinTy (..)+ , KempeTy (..)+ , StackType (..)+ , ConsAnn (..)+ , Atom (..)+ , BuiltinFn (..)+ , KempeDecl (..)+ , Pattern (..)+ , ABI (..)+ , Module+ , freeVars+ , MonoStackType+ , SizeEnv+ , size+ , sizeStack+ , prettyMonoStackType+ , prettyTyped+ , prettyTypedModule+ , prettyFancyModule+ , prettyModule+ , flipStackType+ -- * I resent this...+ , voidStackType+ ) where++import Control.DeepSeq (NFData)+import Data.Bifunctor (Bifunctor (..))+import qualified Data.ByteString.Lazy as BSL+import Data.Functor (void)+import Data.Int (Int64, Int8)+import qualified Data.IntMap as IM+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Monoid (Sum (..))+import qualified Data.Set as S+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.Word (Word8)+import GHC.Generics (Generic)+import Kempe.Name+import Kempe.Unique+import Numeric.Natural+import Prettyprinter (Doc, Pretty (pretty), align, braces, brackets, colon, concatWith, fillSep, hsep, parens, pipe, sep, (<+>))++data BuiltinTy = TyInt+ | TyBool+ | TyInt8+ | TyWord+ deriving (Generic, NFData, Eq, Ord)++instance Pretty BuiltinTy where+ pretty TyInt = "Int"+ pretty TyBool = "Bool"+ pretty TyInt8 = "Int8"+ pretty TyWord = "Word"++-- equality for sum types &c.++data KempeTy a = TyBuiltin a BuiltinTy+ | TyNamed a (TyName a)+ | TyVar a (Name a)+ | TyApp a (KempeTy a) (KempeTy a) -- type applied to another, e.g. Just Int+ deriving (Generic, NFData, Functor, Eq, Ord) -- questionable eq instance but eh++data StackType b = StackType { quantify :: S.Set (Name b)+ , inTypes :: [KempeTy b]+ , outTypes :: [KempeTy b]+ } deriving (Generic, NFData, Eq, Ord)++type MonoStackType = ([KempeTy ()], [KempeTy ()])++-- | Annotation carried on constructors to keep size information through the IR+-- generation phase.+data ConsAnn a = ConsAnn { tySz :: Int64, tag :: Word8, consTy :: a }+ deriving (Functor, Foldable, Traversable, Generic, NFData)++instance Pretty a => Pretty (ConsAnn a) where+ pretty (ConsAnn tSz b ty) = braces ("tySz" <+> colon <+> pretty tSz <+> "tag" <+> colon <+> pretty b <+> "type" <+> colon <+> pretty ty)++prettyMonoStackType :: MonoStackType -> Doc a+prettyMonoStackType (is, os) = sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os)++instance Pretty (StackType a) where+ pretty (StackType _ ins outs) = sep (fmap pretty ins) <+> "--" <+> sep (fmap pretty outs)++voidStackType :: StackType a -> StackType ()+voidStackType (StackType vars ins outs) = StackType (S.map void vars) (void <$> ins) (void <$> outs)++instance Pretty (KempeTy a) where+ pretty (TyBuiltin _ b) = pretty b+ pretty (TyNamed _ tn) = pretty tn+ pretty (TyVar _ n) = pretty n+ pretty (TyApp _ ty ty') = parens (pretty ty <+> pretty ty')++data Pattern c b = PatternInt b Integer+ | PatternCons c (TyName c) -- a constructed pattern+ | PatternWildcard b+ | PatternBool b Bool+ deriving (Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)++instance Bifunctor Pattern where+ second = fmap+ first f (PatternCons l tn) = PatternCons (f l) (fmap f tn)+ first _ (PatternInt l i) = PatternInt l i+ first _ (PatternWildcard l) = PatternWildcard l+ first _ (PatternBool l b) = PatternBool l b++instance Pretty (Pattern c a) where+ pretty (PatternInt _ i) = pretty i+ pretty (PatternBool _ b) = pretty b+ pretty PatternWildcard{} = "_"+ pretty (PatternCons _ tn) = pretty tn++instance Pretty (Atom c a) where+ pretty (AtName _ n) = pretty n+ pretty (Dip _ as) = "dip(" <> fillSep (fmap pretty as) <> ")"+ pretty (AtBuiltin _ b) = pretty b+ pretty (AtCons _ tn) = pretty tn+ pretty (If _ as as') = "if(" <> align (fillSep (fmap pretty as)) <> ", " <> align (fillSep (fmap pretty as')) <> ")"+ pretty (IntLit _ i) = pretty i+ pretty (BoolLit _ b) = pretty b+ pretty (WordLit _ w) = pretty w <> "u"+ pretty (Int8Lit _ i) = pretty i <> "i8"++prettyTyped :: Atom (StackType ()) (StackType ()) -> Doc ann+prettyTyped (AtName ty n) = parens (pretty n <+> ":" <+> pretty ty)+prettyTyped (Dip _ as) = "dip(" <> fillSep (prettyTyped <$> as) <> ")"+prettyTyped (AtBuiltin ty b) = parens (pretty b <+> ":" <+> pretty ty)+prettyTyped (AtCons ty tn) = parens (pretty tn <+> ":" <+> pretty ty)+prettyTyped (If _ as as') = "if(" <> align (fillSep (prettyTyped <$> as)) <> ", " <> align (fillSep (prettyTyped <$> as')) <> ")"+prettyTyped (IntLit _ i) = pretty i+prettyTyped (BoolLit _ b) = pretty b+prettyTyped (Int8Lit _ i) = pretty i <> "i8"+prettyTyped (WordLit _ n) = pretty n <> "u"++data Atom c b = AtName b (Name b)+ | Case b (NonEmpty (Pattern c b, [Atom c b]))+ | If b [Atom c b] [Atom c b]+ | Dip b [Atom c b]+ | IntLit b Integer+ | WordLit b Natural+ | Int8Lit b Int8+ | BoolLit b Bool+ | AtBuiltin b BuiltinFn+ | AtCons c (TyName c)+ deriving (Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)++instance Bifunctor Atom where+ second = fmap+ first f (AtCons l n) = AtCons (f l) (fmap f n)+ first _ (AtName l n) = AtName l n+ first _ (IntLit l i) = IntLit l i+ first _ (WordLit l w) = WordLit l w+ first _ (Int8Lit l i) = Int8Lit l i+ first _ (BoolLit l b) = BoolLit l b+ first _ (AtBuiltin l b) = AtBuiltin l b+ first f (Dip l as) = Dip l (fmap (first f) as)+ first f (If l as as') = If l (fmap (first f) as) (fmap (first f) as')+ first f (Case l ls) =+ let (ps, aLs) = NE.unzip ls+ in Case l $ NE.zip (fmap (first f) ps) (fmap (fmap (first f)) aLs)++data BuiltinFn = Drop+ | Swap+ | Dup+ | IntPlus+ | IntMinus+ | IntTimes+ | IntDiv+ | IntMod+ | IntEq+ | IntLeq+ | IntLt+ | IntGeq+ | IntGt+ | IntNeq+ | IntShiftR+ | IntShiftL+ | IntXor+ | WordPlus+ | WordTimes+ | WordMinus+ | WordDiv+ | WordMod+ | WordShiftR+ | WordShiftL+ | WordXor+ | And+ | Or+ | Xor+ | IntNeg+ | Popcount+ deriving (Eq, Ord, Generic, NFData)++instance Pretty BuiltinFn where+ pretty Drop = "drop"+ pretty Swap = "swap"+ pretty Dup = "dup"+ pretty IntPlus = "+"+ pretty IntMinus = "-"+ pretty IntTimes = "*"+ pretty IntDiv = "/"+ pretty IntMod = "%"+ pretty IntEq = "="+ pretty IntLeq = "<="+ pretty IntLt = "<"+ pretty IntShiftR = ">>"+ pretty IntShiftL = "<<"+ pretty WordPlus = "+~"+ pretty WordTimes = "*~"+ pretty WordShiftL = "<<~"+ pretty WordShiftR = ">>~"+ pretty IntXor = "xori"+ pretty WordXor = "xoru"+ pretty IntGeq = ">="+ pretty IntGt = ">"+ pretty IntNeq = "!="+ pretty WordMinus = "-~"+ pretty WordDiv = "/~"+ pretty WordMod = "%~"+ pretty And = "&"+ pretty Or = "||"+ pretty Xor = "xor"+ pretty IntNeg = "~"+ pretty Popcount = "popcount"++data ABI = Cabi+ | Kabi+ deriving (Eq, Ord, Generic, NFData)++instance Pretty ABI where+ pretty Cabi = "cabi"+ pretty Kabi = "kabi"++prettyKempeDecl :: (Atom c b -> Doc ann) -> KempeDecl a c b -> Doc ann+prettyKempeDecl atomizer (FunDecl _ n is os as) = pretty n <+> ":" <+> 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 <+> ":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <+> "=:" <+> "$cfun" <> 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+ pretty = prettyKempeDecl pretty++prettyTyLeaf :: TyName a -> [KempeTy b] -> Doc ann+prettyTyLeaf cn vars = pretty cn <+> hsep (fmap pretty vars)++-- TODO: separate annotations for TyName in TyDecl+data KempeDecl a c b = TyDecl a (TyName a) [Name a] [(TyName b, [KempeTy a])]+ | FunDecl b (Name b) [KempeTy a] [KempeTy a] [Atom c b]+ | ExtFnDecl b (Name b) [KempeTy a] [KempeTy a] BSL.ByteString -- ShortByteString?+ | Export b ABI (Name b)+ deriving (Eq, Ord, Generic, NFData, Functor, Foldable, Traversable)++instance Bifunctor (KempeDecl a) where+ first _ (TyDecl x tn ns ls) = TyDecl x tn ns ls+ first f (FunDecl l n tys tys' as) = FunDecl l n tys tys' (fmap (first f) as)+ first _ (ExtFnDecl l n tys tys' b) = ExtFnDecl l n tys tys' b+ first _ (Export l abi n) = Export l abi n+ second = fmap++prettyModuleGeneral :: (Atom c b -> Doc ann) -> Module a c b -> Doc ann+prettyModuleGeneral atomizer = sep . fmap (prettyKempeDecl atomizer)++prettyFancyModule :: Module () (ConsAnn (StackType ())) (StackType ()) -> Doc ann+prettyFancyModule = prettyTypedModule . fmap (first consTy)++prettyTypedModule :: Module () (StackType ()) (StackType ()) -> Doc ann+prettyTypedModule = prettyModuleGeneral prettyTyped++prettyModule :: Module a c b -> Doc ann+prettyModule = prettyModuleGeneral pretty++type Module a c b = [KempeDecl a c b]++extrVars :: KempeTy a -> [Name a]+extrVars TyBuiltin{} = []+extrVars TyNamed{} = []+extrVars (TyVar _ n) = [n]+extrVars (TyApp _ ty ty') = extrVars ty ++ extrVars ty'++freeVars :: [KempeTy a] -> S.Set (Name a)+freeVars tys = S.fromList (concatMap extrVars tys)++type SizeEnv = IM.IntMap Int64++-- the kempe sizing system is kind of fucked (it 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 _ 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'++sizeStack :: SizeEnv -> [KempeTy a] -> Int64+sizeStack env = getSum . foldMap (Sum . size env)++-- | Used in "Kempe.Monomorphize" for patterns+flipStackType :: StackType () -> StackType ()+flipStackType (StackType vars is os) = StackType vars os is
+ src/Kempe/Asm/X86.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Started out trying to implement maximal munch but ended with something+-- "flatter" that works with Kempe IR and my shitty register allocator.+module Kempe.Asm.X86 ( irToX86+ ) where++import Control.Monad.State.Strict (State, evalState, gets, modify)+import Data.Foldable.Ext+import Data.List (scanl')+import Data.Word (Word8)+import Kempe.AST+import Kempe.Asm.X86.Type+import qualified Kempe.IR as IR++toAbsReg :: IR.Temp -> AbsReg+toAbsReg (IR.Temp8 i) = AllocReg8 i+toAbsReg (IR.Temp64 i) = AllocReg64 i+toAbsReg IR.DataPointer = DataPointer++type WriteM = State IR.WriteSt++irToX86 :: SizeEnv -> IR.WriteSt -> [IR.Stmt] -> [X86 AbsReg ()]+irToX86 env w = runWriteM w . foldMapA (irEmit env)++nextLabels :: IR.WriteSt -> IR.WriteSt+nextLabels (IR.WriteSt ls ts) = IR.WriteSt (tail ls) ts++nextInt :: IR.WriteSt -> IR.WriteSt+nextInt (IR.WriteSt ls ts) = IR.WriteSt ls (tail ts)++getInt :: WriteM Int+getInt = gets (head . IR.temps) <* modify nextInt++getLabel :: WriteM IR.Label+getLabel = gets (head . IR.wlabels) <* modify nextLabels++allocTemp64 :: WriteM IR.Temp+allocTemp64 = IR.Temp64 <$> getInt++allocTemp8 :: WriteM IR.Temp+allocTemp8 = IR.Temp8 <$> getInt++allocReg64 :: WriteM AbsReg+allocReg64 = AllocReg64 <$> getInt++allocReg8 :: WriteM AbsReg+allocReg8 = AllocReg8 <$> getInt++runWriteM :: IR.WriteSt -> WriteM a -> a+runWriteM = flip evalState++irEmit :: SizeEnv -> IR.Stmt -> WriteM [X86 AbsReg ()]+irEmit _ (IR.Jump l) = pure [Jump () l]+irEmit _ (IR.Labeled l) = pure [Label () l]+irEmit _ (IR.KCall l) = pure [Call () l]+irEmit _ IR.Ret = pure [Ret ()]+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.Reg r2))) = do+ { r' <- allocReg64+ ; pure [ MovRR () r' (toAbsReg r1), SubRR () r' (toAbsReg r2), MovAR () (Reg $ toAbsReg r) r' ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ConstInt i)) =+ pure [ MovAC () (Reg $ toAbsReg r) i ]+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ConstBool b)) =+ pure [ MovABool () (Reg $ toAbsReg r) (toByte b) ]+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ConstTag b)) =+ pure [ MovACTag () (Reg $ toAbsReg r) b ]+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.IntTimesIR (IR.Reg r1) (IR.Reg r2))) = do+ { r' <- allocReg64+ ; pure [ MovRR () r' (toAbsReg r1), ImulRR () r' (toAbsReg r2), MovAR () (Reg $ toAbsReg r) r' ]+ }+irEmit _ (IR.MovMem (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r0) (IR.ConstInt i)) _ (IR.Mem 1 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.ConstInt j)))) = do+ { r' <- allocReg8+ ; pure [ MovRA () r' (AddrRCPlus (toAbsReg r1) j), MovAR () (AddrRCPlus (toAbsReg r0) i) r' ]+ }+irEmit _ (IR.MovMem (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r0) (IR.ConstInt i)) _ (IR.Mem 1 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt j)))) = do+ { r' <- allocReg8+ ; pure [ MovRA () r' (AddrRCMinus (toAbsReg r1) j), MovAR () (AddrRCPlus (toAbsReg r0) i) r' ]+ }+irEmit _ (IR.MovMem (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r0) (IR.ConstInt i)) _ (IR.Mem 1 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt j)))) = do+ { r' <- allocReg8+ ; pure [ MovRA () r' (AddrRCMinus (toAbsReg r1) j), MovAR () (AddrRCMinus (toAbsReg r0) i) r' ]+ }+irEmit _ (IR.MovMem (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r0) (IR.ConstInt i)) _ (IR.Mem 1 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.ConstInt j)))) = do+ { r' <- allocReg8+ ; pure [ MovRA () r' (AddrRCPlus (toAbsReg r1) j), MovAR () (AddrRCMinus (toAbsReg r0) i) r' ]+ }+irEmit _ (IR.MovMem (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r0) (IR.ConstInt i)) _ (IR.Mem 8 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt j)))) = do+ { r' <- allocReg64+ ; pure [ MovRA () r' (AddrRCMinus (toAbsReg r1) j), MovAR () (AddrRCMinus (toAbsReg r0) i) r' ]+ }+irEmit _ (IR.MovMem (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r0) (IR.ConstInt i)) _ (IR.Mem 8 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.ConstInt j)))) = do+ { r' <- allocReg64+ ; pure [ MovRA () r' (AddrRCPlus (toAbsReg r1) j), MovAR () (AddrRCMinus (toAbsReg r0) i) r' ]+ }+irEmit _ (IR.MovMem (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r0) (IR.ConstInt i)) _ (IR.Mem 8 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.ConstInt j)))) = do+ { r' <- allocReg64+ ; pure [ MovRA () r' (AddrRCPlus (toAbsReg r1) j), MovAR () (AddrRCPlus (toAbsReg r0) i) r' ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntRel IR.IntEqIR (IR.Reg r1) (IR.Reg r2))) = do -- TODO: int eq more general (Reg r1) could be e1 &c.+ { l0 <- getLabel+ ; l1 <- getLabel+ ; l2 <- getLabel+ ; pure [ CmpRegReg () (toAbsReg r1) (toAbsReg r2), Je () l0, Jump () l1, Label () l0, MovABool () (Reg $ toAbsReg r) 1, Jump () l2, Label () l1, MovABool () (Reg $ toAbsReg r) 0, Label () l2 ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntRel IR.IntLtIR (IR.Reg r1) (IR.Reg r2))) = do+ { l0 <- getLabel+ ; l1 <- getLabel+ ; l2 <- getLabel+ ; pure [ CmpRegReg () (toAbsReg r1) (toAbsReg r2), Jl () l0, Jump () l1, Label () l0, MovABool () (Reg $ toAbsReg r) 1, Jump () l2, Label () l1, MovABool () (Reg $ toAbsReg r) 0, Label () l2 ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntRel IR.IntGtIR (IR.Reg r1) (IR.Reg r2))) = do+ { l0 <- getLabel+ ; l1 <- getLabel+ ; l2 <- getLabel+ ; pure [ CmpRegReg () (toAbsReg r1) (toAbsReg r2), Jg () l0, Jump () l1, Label () l0, MovABool () (Reg $ toAbsReg r) 1, Jump () l2, Label () l1, MovABool () (Reg $ toAbsReg r) 0, Label () l2 ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntRel IR.IntGeqIR (IR.Reg r1) (IR.Reg r2))) = do+ { l0 <- getLabel+ ; l1 <- getLabel+ ; l2 <- getLabel+ ; pure [ CmpRegReg () (toAbsReg r1) (toAbsReg r2), Jge () l0, Jump () l1, Label () l0, MovABool () (Reg $ toAbsReg r) 1, Jump () l2, Label () l1, MovABool () (Reg $ toAbsReg r) 0, Label () l2 ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntRel IR.IntNeqIR (IR.Reg r1) (IR.Reg r2))) = do+ { l0 <- getLabel+ ; l1 <- getLabel+ ; l2 <- getLabel+ ; pure [ CmpRegReg () (toAbsReg r1) (toAbsReg r2), Jne () l0, Jump () l1, Label () l0, MovABool () (Reg $ toAbsReg r) 1, Jump () l2, Label () l1, MovABool () (Reg $ toAbsReg r) 0, Label () l2 ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntRel IR.IntLeqIR (IR.Reg r1) (IR.Reg r2))) = do+ { l0 <- getLabel+ ; l1 <- getLabel+ ; l2 <- getLabel+ ; pure [ CmpRegReg () (toAbsReg r1) (toAbsReg r2), Jle () l0, Jump () l1, Label () l0, MovABool () (Reg $ toAbsReg r) 1, Jump () l2, Label () l1, MovABool () (Reg $ toAbsReg r) 0, Label () l2 ]+ }+irEmit _ (IR.MovTemp r1 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r2) (IR.ConstInt i))) | r1 == r2 = do+ 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 =+ 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 =+ 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)+ ; 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+ }+irEmit _ (IR.WrapKCall Kabi (_, _) n l) =+ pure [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+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.IntXorIR (IR.Reg r1) (IR.Reg r2))) = do+ { r' <- allocReg64+ ; pure [ MovRR () r' (toAbsReg r1), XorRR () r' (toAbsReg r2), MovAR () (Reg $ toAbsReg r) r' ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.Reg r2))) = do+ { r' <- allocReg64+ ; pure [ MovRR () r' (toAbsReg r1), AddRR () r' (toAbsReg r2), MovAR () (Reg $ toAbsReg r) r' ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.WordShiftRIR (IR.Reg r1) (IR.Reg r2))) = do+ { r' <- allocReg64+ ; pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () r' (toAbsReg r1), ShiftRRR () r' ShiftExponent, MovAR () (Reg $ toAbsReg r) r' ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.WordShiftLIR (IR.Reg r1) (IR.Reg r2))) = do+ { r' <- allocReg64+ ; pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () r' (toAbsReg r1), ShiftLRR () r' ShiftExponent, MovAR () (Reg $ toAbsReg r) r' ]+ }+irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.IntModIR (IR.Reg r1) (IR.Reg r2))) =+ -- QuotRes is rax, so move r1 to rax first+ pure [ MovRR () QuotRes (toAbsReg r1), Cqo (), IdivR () (toAbsReg r2), MovAR () (Reg $ toAbsReg r) RemRes ]+irEmit _ (IR.MovTemp r e) = evalE e r+irEmit _ (IR.MovMem (IR.Reg r) 1 e) = do+ { r' <- allocTemp8+ ; put <- evalE e r'+ ; pure $ put ++ [MovAR () (Reg $ toAbsReg r) (toAbsReg r')]+ }+irEmit _ (IR.MovMem e 8 e') = do+ { r <- allocTemp64+ ; r' <- allocTemp64+ ; eEval <- evalE e r+ ; e'Eval <- evalE e' r'+ ; pure (eEval ++ e'Eval ++ [MovAR () (Reg $ toAbsReg r) (toAbsReg r')])+ }+irEmit _ (IR.MovMem e 1 e') = do+ { r <- allocTemp64+ ; r' <- allocTemp8+ ; eEval <- evalE e r+ ; e'Eval <- evalE e' r'+ ; pure (eEval ++ e'Eval ++ [MovAR () (Reg $ toAbsReg r) (toAbsReg r')])+ }+irEmit _ (IR.CJump (IR.Mem 1 (IR.Reg r)) l l') =+ pure [CmpAddrBool () (Reg (toAbsReg r)) 1, Je () l, Jump () l']+irEmit _ (IR.MJump (IR.Mem 1 (IR.Reg r)) l) =+ pure [CmpAddrBool () (Reg (toAbsReg r)) 1, Je () l]+irEmit _ (IR.CJump (IR.Mem 1 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r) (IR.ConstInt i))) l l') =+ pure [CmpAddrBool () (AddrRCMinus (toAbsReg r) i) 1, Je () l, Jump () l']+irEmit _ (IR.MJump (IR.Mem 1 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r) (IR.ConstInt i))) l) =+ pure [CmpAddrBool () (AddrRCMinus (toAbsReg r) i) 1, Je () l]+irEmit _ (IR.CJump (IR.Mem 1 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r) (IR.ConstInt i))) l l') =+ pure [CmpAddrBool () (AddrRCPlus (toAbsReg r) i) 1, Je () l, Jump () l']+irEmit _ (IR.MJump (IR.Mem 1 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r) (IR.ConstInt i))) l) =+ pure [CmpAddrBool () (AddrRCPlus (toAbsReg r) i) 1, Je () l]+irEmit _ (IR.CJump e l l') = do+ { r <- allocTemp8+ ; bEval <- evalE e r+ ; pure (bEval ++ [CmpRegBool () (toAbsReg r) 1, Je () l, Jump () l'])+ }+irEmit _ (IR.MJump (IR.EqByte (IR.Mem 1 (IR.Reg r)) (IR.ConstTag b)) l) =+ pure [CmpAddrBool () (Reg $ toAbsReg r) b, Je () l]+irEmit _ (IR.MJump (IR.EqByte e0 e1) l) = do+ { r0 <- allocTemp8+ ; r1 <- allocTemp8+ ; placeE0 <- evalE e0 r0+ ; placeE1 <- evalE e1 r1+ ; pure $ placeE0 ++ placeE1 ++ [CmpRegReg () (toAbsReg r0) (toAbsReg r1), Je () l]+ }+irEmit _ (IR.MJump e l) = do+ { r <- allocTemp8+ ; bEval <- evalE e r+ ; pure (bEval ++ [CmpRegBool () (toAbsReg r) 1, Je () l])+ }++-- | Code to evaluate and put some expression in a chosen 'Temp'+--+-- This more or less conforms to maximal munch.+evalE :: IR.Exp -> IR.Temp -> WriteM [X86 AbsReg ()]+evalE (IR.ConstInt i) r = pure [MovRC () (toAbsReg r) i]+evalE (IR.ConstBool b) r = pure [MovRCBool () (toAbsReg r) (toByte b)]+evalE (IR.ConstInt8 i) r = pure [MovRCi8 () (toAbsReg r) i]+evalE (IR.ConstWord w) r = pure [MovRWord () (toAbsReg r) w]+evalE (IR.ConstTag b) r = pure [MovRCTag () (toAbsReg r) b]+evalE (IR.Reg r') r = pure [MovRR () (toAbsReg r) (toAbsReg r')]+evalE (IR.Mem _ (IR.Reg r1)) r = pure [MovRA () (toAbsReg r) (Reg $ toAbsReg r1) ] -- TODO: sanity check reg/mem access size?+evalE (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt i)) r | r == r1 = pure [SubRC () (toAbsReg r) i]+evalE (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.ConstInt i)) r | r == r1 = pure [AddRC () (toAbsReg r) i]+evalE (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt 0)) r = pure [MovRR () (toAbsReg r) (toAbsReg r1)]+evalE (IR.Mem 8 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt i))) r =+ pure [ MovRA () (toAbsReg r) (AddrRCMinus (toAbsReg r1) i) ]+evalE (IR.Mem 8 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.ConstInt i))) r =+ pure [ MovRA () (toAbsReg r) (AddrRCPlus (toAbsReg r1) i) ]+evalE (IR.Mem _ e) r = do -- don't need to check size b/c we're storing in r+ { r' <- allocTemp64+ ; placeE <- evalE e r'+ ; pure $ placeE ++ [MovRA () (toAbsReg r) (Reg $ toAbsReg r')]+ }+evalE (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.Reg r2)) r =+ pure [ MovRR () (toAbsReg r) (toAbsReg r1), AddRR () (toAbsReg r) (toAbsReg r2) ]+evalE (IR.ExprIntBinOp IR.IntTimesIR (IR.Reg r1) (IR.Reg r2)) r = do+ pure [ MovRR () (toAbsReg r) (toAbsReg r1), ImulRR () (toAbsReg r) (toAbsReg r2) ]+evalE (IR.ExprIntBinOp IR.IntXorIR (IR.Reg r1) (IR.Reg r2)) r = do+ pure [ MovRR () (toAbsReg r) (toAbsReg r1), XorRR () (toAbsReg r) (toAbsReg r2) ]+evalE (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt i)) r = do+ pure [ MovRR () (toAbsReg r) (toAbsReg r1), SubRC () (toAbsReg r) i ]+evalE (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.Reg r2)) r = do+ pure [ MovRR () (toAbsReg r) (toAbsReg r1), SubRR () (toAbsReg r) (toAbsReg r2) ]+-- FIXME: because my linear register allocator is shitty, I can't keep+-- registers across jumps... so evaluating = or < as an expression in+-- general is hard ?+evalE (IR.ExprIntBinOp IR.WordShiftLIR (IR.Reg r1) (IR.Reg r2)) r =+ pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () (toAbsReg r) (toAbsReg r1), ShiftLRR () (toAbsReg r) ShiftExponent ]+evalE (IR.ExprIntBinOp IR.WordShiftRIR (IR.Reg r1) (IR.Reg r2)) r = -- FIXME: maximal munch use evalE recursively+ pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () (toAbsReg r) (toAbsReg r1), ShiftRRR () (toAbsReg r) ShiftExponent]+evalE (IR.ExprIntBinOp IR.WordShiftLIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp8+ ; placeE0 <- evalE e0 r0+ ; placeE1 <- evalE e1 r1+ ; pure $ placeE0 ++ placeE1 ++ [ MovRR () ShiftExponent (toAbsReg r0), MovRR () (toAbsReg r) (toAbsReg r1), ShiftLRR () (toAbsReg r) ShiftExponent ]+ }+evalE (IR.ExprIntBinOp IR.WordShiftRIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp8+ ; placeE0 <- evalE e0 r0+ ; placeE1 <- evalE e1 r1+ ; pure $ placeE0 ++ placeE1 ++ [ MovRR () ShiftExponent (toAbsReg r0), MovRR () (toAbsReg r) (toAbsReg r1), ShiftRRR () (toAbsReg r) ShiftExponent ]+ }+evalE (IR.ExprIntBinOp IR.IntModIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ -- QuotRes is rax, so move r1 to rax first+ ; pure $ placeE ++ placeE' ++ [ MovRR () QuotRes (toAbsReg r0), Cqo (), IdivR () (toAbsReg r1), MovRR () (toAbsReg r) RemRes ]+ }+evalE (IR.ExprIntBinOp IR.IntDivIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () QuotRes (toAbsReg r0), Cqo (), IdivR () (toAbsReg r1), MovRR () (toAbsReg r) QuotRes ]+ }+evalE (IR.ExprIntBinOp IR.WordDivIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () QuotRes (toAbsReg r0), XorRR () RemRes RemRes, DivR () (toAbsReg r1), MovRR () (toAbsReg r) QuotRes ]+ }+evalE (IR.ExprIntBinOp IR.WordModIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () QuotRes (toAbsReg r0), XorRR () RemRes RemRes, DivR () (toAbsReg r1), MovRR () (toAbsReg r) RemRes ]+ }+evalE (IR.BoolBinOp IR.BoolAnd e0 e1) r = do+ { r0 <- allocTemp8+ ; r1 <- allocTemp8+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () (toAbsReg r) (toAbsReg r0), AndRR () (toAbsReg r) (toAbsReg r1) ]+ }+evalE (IR.BoolBinOp IR.BoolOr e0 e1) r = do+ { r0 <- allocTemp8+ ; r1 <- allocTemp8+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () (toAbsReg r) (toAbsReg r0), OrRR () (toAbsReg r) (toAbsReg r1) ]+ }+evalE (IR.BoolBinOp IR.BoolXor e0 e1) r = do+ { r0 <- allocTemp8+ ; r1 <- allocTemp8+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () (toAbsReg r) (toAbsReg r0), XorRR () (toAbsReg r) (toAbsReg r1) ]+ }+evalE (IR.ExprIntBinOp IR.IntMinusIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () (toAbsReg r) (toAbsReg r0), SubRR () (toAbsReg r) (toAbsReg r1) ]+ }+evalE (IR.ExprIntBinOp IR.IntPlusIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () (toAbsReg r) (toAbsReg r0), AddRR () (toAbsReg r) (toAbsReg r1) ]+ }+evalE (IR.ExprIntBinOp IR.IntTimesIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () (toAbsReg r) (toAbsReg r0), ImulRR () (toAbsReg r) (toAbsReg r1) ]+ }+evalE (IR.ExprIntBinOp IR.IntXorIR e0 e1) r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; placeE <- evalE e0 r0+ ; placeE' <- evalE e1 r1+ ; pure $ placeE ++ placeE' ++ [ MovRR () (toAbsReg r) (toAbsReg r0), XorRR () (toAbsReg r) (toAbsReg r1) ]+ }+evalE (IR.PopcountIR e0) r = do+ { r' <- allocTemp64+ ; placeE <- evalE e0 r'+ ; pure $ placeE ++ [ PopcountRR () (toAbsReg r) (toAbsReg r') ]+ }+evalE (IR.IntNegIR e) r = do+ { placeE <- evalE e r+ ; pure $ placeE ++ [ NegR () (toAbsReg r) ]+ }++toByte :: Bool -> Word8+toByte False = 0+toByte True = 1++-- I wonder if I could use a hylo.?
+ src/Kempe/Asm/X86/ControlFlow.hs view
@@ -0,0 +1,180 @@+module Kempe.Asm.X86.ControlFlow ( mkControlFlow+ , ControlAnn (..)+ ) where++-- seems to pretty clearly be faster+import Control.Monad.State.Strict (State, evalState, gets, modify)+import Data.Bifunctor (first, second)+import Data.Functor (($>))+import qualified Data.Map as M+import qualified Data.Set as S+import Kempe.Asm.X86.Type++-- map of labels by node+type FreshM = State (Int, M.Map Label Int) -- TODO: map int to asm++runFreshM :: FreshM a -> a+runFreshM = flip evalState (0, mempty)++mkControlFlow :: [X86 AbsReg ()] -> [X86 AbsReg ControlAnn]+mkControlFlow instrs = runFreshM (broadcasts instrs *> addControlFlow instrs)++getFresh :: FreshM Int+getFresh = gets fst <* modify (first (+1))++lookupLabel :: Label -> FreshM Int+lookupLabel l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd)++broadcast :: Int -> Label -> FreshM ()+broadcast i l = modify (second (M.insert l i))++addrRegs :: Ord reg => Addr reg -> S.Set reg+addrRegs (Reg r) = S.singleton r+addrRegs (AddrRRPlus r r') = S.fromList [r, r']+addrRegs (AddrRCPlus r _) = S.singleton r+addrRegs (AddrRCMinus r _) = S.singleton r+addrRegs (AddrRRScale r r' _) = S.fromList [r, r']++-- | Annotate instructions with a unique node name and a list of all possible+-- destinations.+addControlFlow :: [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]+addControlFlow [] = pure []+addControlFlow ((Label _ l):asms) = do+ { i <- lookupLabel l+ ; (f, asms') <- next asms+ ; pure (Label (ControlAnn i (f []) S.empty S.empty) l : asms')+ }+addControlFlow ((Je _ l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l -- TODO: is this what's wanted?+ ; pure (Je (ControlAnn i (f [l_i]) S.empty S.empty) l : asms')+ }+addControlFlow ((Jl _ l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (Jl (ControlAnn i (f [l_i]) S.empty S.empty) l : asms')+ }+addControlFlow ((Jle _ l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (Jle (ControlAnn i (f [l_i]) S.empty S.empty) l : asms')+ }+addControlFlow ((Jne _ l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (Jne (ControlAnn i (f [l_i]) S.empty S.empty) l : asms')+ }+addControlFlow ((Jge _ l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (Jge (ControlAnn i (f [l_i]) S.empty S.empty) l : asms')+ }+addControlFlow ((Jg _ l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (Jg (ControlAnn i (f [l_i]) S.empty S.empty) l : asms')+ }+addControlFlow ((Jump _ l):asms) = do+ { i <- getFresh+ ; nextAsms <- addControlFlow asms+ ; l_i <- lookupLabel l+ ; pure (Jump (ControlAnn i [l_i] S.empty S.empty) l : nextAsms)+ }+addControlFlow ((Call _ l):asms) = do+ { i <- getFresh+ ; nextAsms <- addControlFlow asms+ ; l_i <- lookupLabel l+ ; pure (Call (ControlAnn i [l_i] S.empty S.empty) l : nextAsms)+ }+addControlFlow (Ret{}:asms) = do+ { i <- getFresh+ ; nextAsms <- addControlFlow asms+ ; pure (Ret (ControlAnn i [] S.empty S.empty) : nextAsms)+ }+addControlFlow (asm:asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; pure ((asm $> ControlAnn i (f []) (uses asm) (defs asm)) : asms')+ }++uses :: Ord reg => X86 reg ann -> S.Set reg+uses (PushReg _ r) = S.singleton r+uses (PushMem _ a) = addrRegs a+uses (PopMem _ a) = addrRegs a+uses (MovRA _ _ a) = addrRegs a+uses (MovAR _ a r) = S.singleton r <> addrRegs a+uses (MovRR _ _ r) = S.singleton r+uses (AddRR _ r r') = S.fromList [r, r']+uses (SubRR _ r r') = S.fromList [r, r']+uses (ImulRR _ r r') = S.fromList [r, r']+uses (AddRC _ r _) = S.singleton r+uses (SubRC _ r _) = S.singleton r+uses (AddAC _ a _) = addrRegs a+uses (MovABool _ a _) = addrRegs a+uses (MovAC _ a _) = addrRegs a+uses (MovACi8 _ a _) = addrRegs a+uses (XorRR _ r r') = S.fromList [r, r']+uses (CmpAddrReg _ a r) = S.singleton r <> addrRegs a+uses (CmpRegReg _ r r') = S.fromList [r, r']+uses (CmpRegBool _ r _) = S.singleton r+uses (CmpAddrBool _ a _) = addrRegs a+uses (ShiftLRR _ r r') = S.fromList [r, r']+uses (ShiftRRR _ r r') = S.fromList [r, r']+uses (MovRCi8 _ r _) = S.singleton r+uses (MovACTag _ a _) = addrRegs a+uses (IdivR _ r) = S.singleton r+uses (DivR _ r) = S.singleton r+uses Cqo{} = S.empty -- TODO?+uses (AndRR _ r r') = S.fromList [r, r']+uses (OrRR _ r r') = S.fromList [r, r']+uses (PopcountRR _ _ r') = S.singleton r'+uses (NegR _ r) = S.singleton r+uses _ = S.empty++defs :: X86 reg ann -> S.Set reg+defs (MovRA _ r _) = S.singleton r+defs (MovRR _ r _) = S.singleton r+defs (MovRC _ r _) = S.singleton r+defs (MovRCBool _ r _) = S.singleton r+defs (MovRCi8 _ r _) = S.singleton r+defs (MovRWord _ r _) = S.singleton r+defs (AddRR _ r _) = S.singleton r+defs (SubRR _ r _) = S.singleton r+defs (ImulRR _ r _) = S.singleton r+defs (AddRC _ r _) = S.singleton r+defs (SubRC _ r _) = S.singleton r+defs (XorRR _ r _) = S.singleton r+defs (MovRL _ r _) = S.singleton r+defs (ShiftRRR _ r _) = S.singleton r+defs (PopReg _ r) = S.singleton r+defs (ShiftLRR _ r _) = S.singleton r+defs (AndRR _ r _) = S.singleton r+defs (OrRR _ r _) = S.singleton r+defs (PopcountRR _ r _) = S.singleton r+defs (NegR _ r) = S.singleton r+defs (MovRCTag _ r _) = S.singleton r+-- defs for IdivR &c.?+defs _ = S.empty++next :: [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn])+next asms = do+ nextAsms <- addControlFlow asms+ case nextAsms of+ [] -> pure (id, [])+ (asm:_) -> pure ((node (ann asm) :), nextAsms)++-- | Construct map assigning labels to their node name.+broadcasts :: [X86 reg ()] -> FreshM [X86 reg ()]+broadcasts [] = pure []+broadcasts (asm@(Label _ l):asms) = do+ { i <- getFresh+ ; broadcast i l+ ; (asm :) <$> broadcasts asms+ }+broadcasts (asm:asms) = (asm :) <$> broadcasts asms
+ src/Kempe/Asm/X86/Linear.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Linear scan register allocator+--+-- See: https://web.stanford.edu/class/archive/cs/cs143/cs143.1128/lectures/17/Slides17.pdf+module Kempe.Asm.X86.Linear ( X86Reg (..)+ , allocRegs+ ) where++import Control.Monad.State.Strict (State, evalState, gets)+import Data.Foldable (traverse_)+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import qualified Data.Set as S+import Kempe.Asm.X86.Type+import Lens.Micro (Lens')+import Lens.Micro.Mtl (modifying, (.=))++-- brief problem:+--+-- mov HL16, 1 {datapointer,rdx ; datapointer,HL16,rdx}+-- jmp kmp_16 {datapointer,HL16,rdx ; datapointer,HL16,rdx}+-- kmp_15: {datapointer,rdx ; datapointer,rdx}+-- mov HL16, 0 {datapointer,rdx ; datapointer,HL16,rdx}+-- kmp_16: {datapointer,HL16,rdx ; datapointer,HL16,rdx}+-- mov [datapointer], HL16 {datapointer,HL16,rdx ; datapointer,rdx}+--+-- so it feels free to allocate HL16 after kmp_15, though they must match!++-- set of free registers we iterate over+data AllocSt = AllocSt { allocs :: M.Map AbsReg X86Reg -- ^ Already allocated registers+ , free64 :: S.Set X86Reg -- TODO: IntSet here?+ , free8 :: S.Set X86Reg+ }++allocsLens :: Lens' AllocSt (M.Map AbsReg X86Reg)+allocsLens f s = fmap (\x -> s { allocs = x }) (f (allocs s))++free64Lens :: Lens' AllocSt (S.Set X86Reg)+free64Lens f s = fmap (\x -> s { free64 = x }) (f (free64 s))++free8Lens :: Lens' AllocSt (S.Set X86Reg)+free8Lens f s = fmap (\x -> s { free8 = x }) (f (free8 s))++-- | Mark all registers as free (at the beginning).+allFree :: AllocSt+allFree = AllocSt mempty allReg64 (S.fromList [R8b .. R15b])++allReg64 :: S.Set X86Reg+allReg64 = S.fromList [R8 .. Rsi]++type AllocM = State AllocSt++runAllocM :: AllocM a -> a+runAllocM = flip evalState allFree++-- | On X86, certain registers interfere/are dependent. Thus, if we are using+-- some 'X86Reg', we need to remove several from the set of free registers up to+-- that point.+assoc :: X86Reg -> S.Set X86Reg+assoc Rax = S.fromList [AH, AL]+assoc Rdx = S.fromList [DH, DL]+assoc R8 = S.singleton R8b+assoc R9 = S.singleton R9b+assoc R10 = S.singleton R10b+assoc R11 = S.singleton R11b+assoc R12 = S.singleton R12b+assoc R13 = S.singleton R13b+assoc R14 = S.singleton R14b+assoc R15 = S.singleton R15b+assoc AH = S.singleton Rax+assoc AL = S.singleton Rax+assoc DH = S.singleton Rdx+assoc DL = S.singleton Rdx+assoc R8b = S.singleton R8+assoc R9b = S.singleton R9+assoc R10b = S.singleton R10+assoc R11b = S.singleton R11+assoc R12b = S.singleton R12+assoc R13b = S.singleton R13+assoc R14b = S.singleton R14+assoc R15b = S.singleton R15+assoc Rcx = S.fromList [CH, CL]+assoc CH = S.singleton Rcx+assoc CL = S.singleton Rcx+assoc Rsi = S.singleton Sil+assoc Rdi = S.singleton Dil+assoc Sil = S.singleton Rsi+assoc Dil = S.singleton Rdi++allocRegs :: [X86 AbsReg Liveness] -> [X86 X86Reg ()]+allocRegs = runAllocM . traverse allocReg++new :: Liveness -> S.Set AbsReg+new (Liveness i o) = o S.\\ i++done :: Liveness -> S.Set AbsReg+done (Liveness i o) = i S.\\ o++freeDone :: Liveness -> AllocM ()+freeDone l = traverse_ freeAbsReg absRs+ where absRs = done l++freeAbsReg :: AbsReg -> AllocM ()+freeAbsReg (AllocReg64 i) = freeAbsReg64 i+freeAbsReg (AllocReg8 i) = freeAbsReg8 i+freeAbsReg _ = pure () -- maybe sketchy?++freeAbsReg8 :: Int -> AllocM ()+freeAbsReg8 i = do+ xR <- findReg absR+ modifying allocsLens (M.delete absR)+ modifying free8Lens (S.insert xR)+ modifying free64Lens (<> assoc xR)++ where absR = AllocReg8 i++freeAbsReg64 :: Int -> AllocM ()+freeAbsReg64 i = do+ xR <- findReg absR+ modifying allocsLens (M.delete absR)+ modifying free64Lens (S.insert xR)+ modifying free8Lens (<> assoc xR)++ where absR = AllocReg64 i++assignReg64 :: Int -> X86Reg -> AllocM ()+assignReg64 i xr =+ modifying allocsLens (M.insert (AllocReg64 i) xr)++assignReg8 :: Int -> X86Reg -> AllocM ()+assignReg8 i xr =+ modifying allocsLens (M.insert (AllocReg8 i) xr)++newReg64 :: AllocM X86Reg+newReg64 = do+ r64St <- gets free64+ let (res, newSt) = fromMaybe err $ S.minView r64St+ assocRes = assoc res+ -- register is no longer free+ free64Lens .= newSt+ modifying free8Lens (S.\\ assocRes)+ pure res++ where err = error "(internal error) No register available."++newReg8 :: AllocM X86Reg+newReg8 = do+ r8St <- gets free8+ let (res, newSt) = fromMaybe err $ S.minView r8St+ assocRes = assoc res+ -- register is no longer free+ free8Lens .= newSt+ modifying free64Lens (S.\\ assocRes)+ pure res++ where err = error "(internal error) No register available."++findReg :: AbsReg -> AllocM X86Reg+findReg absR = gets+ (M.findWithDefault (error "Internal error in register allocator: unfound register") absR . allocs)++useReg64 :: Liveness -> Int -> AllocM X86Reg+useReg64 l i =+ if absR `S.member` new l+ then do { res <- newReg64 ; assignReg64 i res ; pure res }+ else findReg absR+ where absR = AllocReg64 i++useReg8 :: Liveness -> Int -> AllocM X86Reg+useReg8 l i =+ if absR `S.member` new l+ then do { res <- newReg8 ; assignReg8 i res ; pure res }+ else findReg absR+ where absR = AllocReg8 i++useAddr :: Liveness -> Addr AbsReg -> AllocM (Addr X86Reg)+useAddr l (Reg r) = Reg <$> useReg l r+useAddr l (AddrRCPlus r c) = AddrRCPlus <$> useReg l r <*> pure c+useAddr l (AddrRCMinus r c) = AddrRCMinus <$> useReg l r <*> pure c+useAddr l (AddrRRPlus r0 r1) = AddrRRPlus <$> useReg l r0 <*> useReg l r1+useAddr l (AddrRRScale r0 r1 c) = AddrRRScale <$> useReg l r0 <*> useReg l r1 <*> pure c++useReg :: Liveness -> AbsReg -> AllocM X86Reg+useReg l (AllocReg64 i) = useReg64 l i+useReg l (AllocReg8 i) = useReg8 l i+useReg _ DataPointer = pure Rbx+useReg _ CArg1 = pure Rdi -- shouldn't clobber anything because it's just used in function wrapper to push onto the kempe stack+useReg _ CArg2 = pure Rsi+useReg _ CArg3 = pure Rdx+useReg _ CArg4 = pure Rcx+useReg _ CArg5 = pure R8+useReg _ CArg6 = pure R9+useReg _ ShiftExponent = pure CL+useReg _ CRet = pure Rax -- shouldn't clobber anything because this is used at end of function calls/wrappers anyway+useReg _ QuotRes = pure Rax+useReg _ RemRes = pure Rdx+-- TODO: ig we should have a sanity check here?++-- There's no spill code buuut that's probably not necessary since the whole+-- kempe model is basically to start with everything pre-spilled+allocReg :: X86 AbsReg Liveness -> AllocM (X86 X86Reg ())+allocReg (PushReg l r) = PushReg () <$> useReg l r <* freeDone l+allocReg Ret{} = pure $ Ret ()+allocReg (Call _ l) = pure $ Call () l+allocReg (PushConst _ i) = pure $ PushConst () i+allocReg (Je _ l) = pure $ Je () l+allocReg (Jump _ l) = pure $ Jump () l+allocReg (Label _ l) = pure $ Label () l+allocReg (MovRCBool l r b) = (MovRCBool () <$> useReg l r <*> pure b) <* freeDone l+allocReg (CmpAddrReg l a r) = (CmpAddrReg () <$> useAddr l a <*> useReg l r) <* freeDone l+allocReg (CmpAddrBool l a b) = (CmpAddrBool () <$> useAddr l a <*> pure b) <* freeDone l+allocReg (AddRC _ DataPointer c) = pure $ AddRC () Rbx c+allocReg (SubRC _ DataPointer c) = pure $ SubRC () Rbx c+allocReg (MovRA l r0 (Reg r1)) = (MovRA () <$> useReg l r0 <*> fmap Reg (useReg l r1)) <* freeDone l+allocReg (SubRR l r0 r1) = (SubRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (MovAR l a r) = (MovAR () <$> useAddr l a <*> useReg l r) <* freeDone l+allocReg (MovAC _ (Reg DataPointer) i) = pure $ MovAC () (Reg Rbx) i+allocReg (MovRR l r0 r1) = (MovRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (MovRA l r a) = (MovRA () <$> useReg l r <*> useAddr l a) <* freeDone l+allocReg (CmpRegReg l r0 r1) = (CmpRegReg () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (CmpRegBool l r b) = (CmpRegBool () <$> useReg l r <*> pure b) <* freeDone l+allocReg (MovABool _ (Reg DataPointer) b) = pure $ MovABool () (Reg Rbx) b+allocReg (BSLabel _ b) = pure $ BSLabel () b+allocReg (MovRC l r c) = (MovRC () <$> useReg l r <*> pure c) <* freeDone l+allocReg (PopMem _ (AddrRCPlus DataPointer c)) = pure $ PopMem () (AddrRCPlus Rbx c)+allocReg (AddAC _ (Reg DataPointer) c) = pure $ AddAC () (Reg Rbx) c+allocReg (AddRC l r c) = (AddRC () <$> useReg l r <*> pure c) <* freeDone l+allocReg (SubRC l r c) = (SubRC () <$> useReg l r <*> pure c) <* freeDone l+allocReg (MovAC l a c) = (MovAC () <$> useAddr l a <*> pure c) <* freeDone l+allocReg (MovACi8 l a c) = (MovACi8 () <$> useAddr l a <*> pure c) <* freeDone l+allocReg (MovABool l a b) = (MovABool () <$> useAddr l a <*> pure b) <* freeDone l+allocReg (PopMem l a) = PopMem () <$> useAddr l a <* freeDone l+allocReg (AddAC l a c) = (AddAC () <$> useAddr l a <*> pure c) <* freeDone l+allocReg (PushMem l a) = PushMem () <$> useAddr l a <* freeDone l+allocReg (AddRR l r0 r1) = (AddRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (MovRL l r bl) = (MovRL () <$> useReg l r <*> pure bl) <* freeDone l+allocReg (XorRR l r0 r1) = (XorRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (ShiftLRR l r0 r1) = (ShiftLRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (ShiftRRR l r0 r1) = (ShiftRRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (ImulRR l r0 r1) = (ImulRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (MovRWord l r w) = (MovRWord () <$> useReg l r <*> pure w) <* freeDone l+allocReg (IdivR l r) = (IdivR () <$> useReg l r) <* freeDone l+allocReg Cqo{} = pure $ Cqo ()+allocReg (PopReg l r) = (PopReg () <$> useReg l r) <* freeDone l+allocReg (MovRCi8 l r c) = (MovRCi8 () <$> useReg l r <*> pure c) <* freeDone l+allocReg (Jl _ l) = pure $ Jl () l+allocReg (MovACTag l a t) = (MovACTag () <$> useAddr l a <*> pure t) <* freeDone l+allocReg (AndRR l r0 r1) = (AndRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (OrRR l r0 r1) = (OrRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (PopcountRR l r0 r1) = (PopcountRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (NegR l r) = NegR () <$> useReg l r -- shouldn't be anything to free+allocReg (Jle _ l) = pure $ Jle () l+allocReg (Jge _ l) = pure $ Jge () l+allocReg (Jg _ l) = pure $ Jg () l+allocReg (Jne _ l) = pure $ Jne () l+allocReg (MovRCTag l r b) = MovRCTag () <$> useReg l r <*> pure b -- don't need to free anything+allocReg (DivR l r) = (DivR () <$> useReg l r) <* freeDone l+allocReg (NasmMacro0 _ b) = pure $ NasmMacro0 () b+allocReg (CallBS _ b) = pure $ CallBS () b
+ src/Kempe/Asm/X86/Liveness.hs view
@@ -0,0 +1,65 @@+-- FIXME: this module is slow++-- | Based on the Appel book.+module Kempe.Asm.X86.Liveness ( Liveness+ , reconstruct+ ) where++import Control.Composition (thread)+-- this seems to be faster+import qualified Data.IntMap.Lazy as IM+import qualified Data.Set as S+import Kempe.Asm.X86.Type++emptyLiveness :: Liveness+emptyLiveness = Liveness S.empty S.empty++-- need: succ for a node++initLiveness :: [X86 reg ControlAnn] -> LivenessMap+initLiveness = IM.fromList . fmap (\asm -> let x = ann asm in (node x, (x, emptyLiveness)))++type LivenessMap = IM.IntMap (ControlAnn, Liveness)++-- | All program points accessible from some node.+succNode :: ControlAnn -- ^ 'ControlAnn' associated w/ node @n@+ -> LivenessMap+ -> [Liveness] -- ^ 'Liveness' associated with 'succNode' @n@+succNode x ns =+ let conns = conn x+ in fmap (snd . flip lookupNode ns) conns++lookupNode :: Int -> LivenessMap -> (ControlAnn, Liveness)+lookupNode = IM.findWithDefault (error "Internal error: failed to look up instruction")++done :: LivenessMap -> LivenessMap -> Bool+done n0 n1 = {-# SCC "done" #-} and $ zipWith (\(_, l) (_, l') -> l == l') (IM.elems n0) (IM.elems n1) -- should be safe b/c n0, n1 must have same length++-- order in which to inspect nodes during liveness analysis+inspectOrder :: [X86 reg ControlAnn] -> [Int]+inspectOrder = fmap (node . ann) -- don't need to reverse because thread goes in opposite order++reconstruct :: [X86 reg ControlAnn] -> [X86 reg Liveness]+reconstruct asms = {-# SCC "reconstructL" #-} fmap (fmap lookupL) asms+ where l = {-# SCC "mkLiveness" #-} mkLiveness asms+ lookupL x = snd $ lookupNode (node x) l++mkLiveness :: [X86 reg ControlAnn] -> LivenessMap+mkLiveness asms = liveness is (initLiveness asms)+ where is = inspectOrder asms++liveness :: [Int] -> LivenessMap -> LivenessMap+liveness is nSt =+ if done nSt nSt'+ then nSt+ else liveness is nSt'+ where nSt' = {-# SCC "iterNodes" #-} iterNodes is nSt++iterNodes :: [Int] -> LivenessMap -> LivenessMap+iterNodes is = thread (fmap stepNode is)++stepNode :: Int -> LivenessMap -> LivenessMap+stepNode n ns = {-# SCC "stepNode" #-} IM.insert n (c, Liveness ins' out') ns+ where (c, l) = lookupNode n ns+ ins' = usesNode c <> (out l S.\\ defsNode c)+ out' = S.unions (fmap ins (succNode c ns))
+ src/Kempe/Asm/X86/Type.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Asm.X86.Type ( X86 (..)+ , Addr (..)+ , AbsReg (..)+ , X86Reg (..)+ , ControlAnn (..)+ , Liveness (..)+ , Label+ , prettyAsm+ , prettyDebugAsm+ ) where++import Control.DeepSeq (NFData)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Foldable (toList)+import Data.Int (Int64, Int8)+import qualified Data.Set as S+import Data.Text.Encoding (decodeUtf8)+import qualified Data.Text.Lazy.Encoding as TL+import Data.Word (Word8)+import GHC.Generics (Generic)+import Prettyprinter (Doc, Pretty (pretty), braces, brackets, colon, concatWith, hardline, indent, punctuate, (<+>))+import Prettyprinter.Ext++type Label = Word++data Liveness = Liveness { ins :: !(S.Set AbsReg), out :: !(S.Set AbsReg) } -- strictness annotations make it perform better+ deriving (Eq, Generic, NFData)++instance Pretty Liveness where+ pretty (Liveness is os) = braces (pp is <+> ";" <+> pp os)+ where pp = mconcat . punctuate "," . fmap pretty . toList++data ControlAnn = ControlAnn { node :: !Int+ , conn :: [Int]+ , usesNode :: S.Set AbsReg+ , defsNode :: S.Set AbsReg+ } deriving (Generic, NFData)++-- currently just has 64-bit and 8-bit registers+data X86Reg = R8+ | R9+ | R10+ | R11+ | R12+ | R13+ | R14+ | R15+ | Rdi -- can I use rsi/rdi??+ | Rsi+ -- -- | BH+ -- -- | BL+ | R8b+ | R9b+ | R10b+ | R11b+ | R12b+ | R13b+ | R14b+ | R15b+ | Sil+ | Dil+ | Rsp+ | Rbp+ | Rbx+ -- cl is reserved in this implementation which it really shouldn't be+ -- rax and rdx (and friends) are reserved for unsigned mult.+ | Rcx+ | CH+ | CL+ -- Rax, Rdx and friends are reserved for integer division (and+ -- unsigned multiplication lol)+ | Rax+ | Rdx+ | AH+ | AL+ | DH+ | DL+ deriving (Eq, Ord, Enum, Bounded, Generic, NFData)++instance Pretty X86Reg where+ pretty Rax = "rax"+ pretty Rcx = "rcx"+ pretty Rdx = "rdx"+ pretty Rsp = "rsp"+ pretty Rbp = "rbp"+ pretty AH = "ah"+ pretty AL = "al"+ pretty CH = "ch"+ pretty CL = "cl"+ pretty DH = "dh"+ pretty DL = "dl"+ pretty Rbx = "rbx"+ pretty R8 = "r8"+ pretty R9 = "r9"+ pretty R10 = "r10"+ pretty R11 = "r11"+ pretty R12 = "r12"+ pretty R13 = "r13"+ pretty R14 = "r14"+ pretty R15 = "r15"+ pretty R8b = "r8b"+ pretty R9b = "r9b"+ pretty R10b = "r10b"+ pretty R11b = "r11b"+ pretty R12b = "r12b"+ pretty R13b = "r13b"+ pretty R14b = "r14b"+ pretty R15b = "r15b"+ pretty Rsi = "rsi"+ pretty Rdi = "rdi"+ pretty Sil = "sil"+ pretty Dil = "dil"++data AbsReg = DataPointer+ | AllocReg64 !Int -- TODO: register by size+ | AllocReg8 !Int+ | CArg1+ | CArg2+ | CArg3+ | CArg4+ | CArg5+ | CArg6+ | CRet -- x0 on aarch64+ | ShiftExponent+ | QuotRes -- quotient register for idiv, rax+ | RemRes -- remainder register for idiv, rdx+ deriving (Eq, Ord, Generic, NFData)++instance Pretty AbsReg where+ pretty DataPointer = "datapointer"+ pretty (AllocReg64 i) = "r" <> pretty i+ pretty (AllocReg8 i) = "HL" <> pretty i+ pretty CRet = "rax"+ pretty CArg1 = "rdi"+ pretty CArg2 = "rsi"+ pretty CArg3 = "rdx"+ pretty CArg4 = "rcx"+ pretty CArg5 = "r8"+ pretty CArg6 = "r9"+ pretty ShiftExponent = "cl"+ pretty QuotRes = "rax"+ pretty RemRes = "rdx"++-- [ebx+ecx*4h-20h]+data Addr reg = Reg reg+ | AddrRRPlus reg reg+ | AddrRCPlus reg Int64+ | AddrRCMinus reg Int64+ | AddrRRScale reg reg Int64+ deriving (Generic, NFData)++-- TODO: sanity-check pass to make sure no Reg8's are in e.g. MovRCBool++-- parametric in @reg@; we do register allocation second+data X86 reg a = PushReg { ann :: a, rSrc :: reg }+ | PushMem { ann :: a, addr :: Addr reg }+ | PopMem { ann :: a, addr :: Addr reg }+ | PopReg { ann :: a, reg :: reg }+ | PushConst { ann :: a, iSrc :: Int64 }+ | Jump { ann :: a, label :: Label }+ | Call { ann :: a, label :: Label }+ | CallBS { ann :: a, bslLabel :: BSL.ByteString }+ | Ret { ann :: a }+ -- intel-ish syntax; destination first+ | MovRA { ann :: a, rDest :: reg, addrSrc :: Addr reg }+ | MovAR { ann :: a, addrDest :: Addr reg, rSrc :: reg }+ | MovABool { ann :: a, addrDest :: Addr reg, boolSrc :: Word8 }+ | MovRR { ann :: a, rDest :: reg, rSrc :: reg } -- for convenience+ | MovRC { ann :: a, rDest :: reg, iSrc :: Int64 }+ | MovRL { ann :: a, rDest :: reg, bsLabel :: BS.ByteString }+ | MovAC { ann :: a, addrDest :: Addr reg, iSrc :: Int64 }+ | MovACi8 { ann :: a, addrDest :: Addr reg, i8Src :: Int8 }+ | MovACTag { ann :: a, addrDest :: Addr reg, tagSrc :: Word8 }+ | MovRCBool { ann :: a, rDest :: reg, boolSrc :: Word8 }+ | MovRCi8 { ann :: a, rDest :: reg, i8Src :: Int8 }+ | MovRCTag { ann :: a, rDest :: reg, tagSrc :: Word8 }+ | MovRWord { ann :: a, rDest :: reg, wSrc :: Word }+ | AddRR { ann :: a, rAdd1 :: reg, rAdd2 :: reg }+ | SubRR { ann :: a, rSub1 :: reg, rSub2 :: reg }+ | XorRR { ann :: a, rXor1 :: reg, rXor2 :: reg }+ | ImulRR { ann :: a, rMul1 :: reg, rMul2 :: reg }+ | AddAC { ann :: a, addrAdd1 :: Addr reg, iAdd2 :: Int64 }+ | AddRC { ann :: a, rAdd1 :: reg, iAdd2 :: Int64 }+ | SubRC { ann :: a, rSub1 :: reg, iSub2 :: Int64 }+ | ShiftLRR { ann :: a, rDest :: reg, rSrc :: reg }+ | ShiftRRR { ann :: a, rDest :: reg, rSrc :: reg }+ | Label { ann :: a, label :: Label }+ | BSLabel { ann :: a, bsLabel :: BS.ByteString }+ | Je { ann :: a, jLabel :: Label }+ | Jne { ann :: a, jLabel :: Label }+ | Jg { ann :: a, jLabel :: Label }+ | Jge { ann :: a, jLabel :: Label }+ | Jl { ann :: a, jLabel :: Label }+ | Jle { ann :: a, jLabel :: Label }+ | CmpAddrReg { ann :: a, addrCmp :: Addr reg, rCmp :: reg }+ | CmpRegReg { ann :: a, rCmp :: reg, rCmp' :: reg } -- for simplicity+ | CmpAddrBool { ann :: a, addrCmp :: Addr reg, bCmp :: Word8 }+ | CmpRegBool { ann :: a, rCmp :: reg, bCmp :: Word8 }+ | IdivR { ann :: a, rDiv :: reg }+ | DivR { ann :: a, rDiv :: reg }+ | Cqo { ann :: a }+ | AndRR { ann :: a, rDest :: reg, rSrc :: reg }+ | OrRR { ann :: a, rDest :: reg, rSrc :: reg }+ | PopcountRR { ann :: a, rDest :: reg, rSrc :: reg }+ | NegR { ann :: a, rSrc :: reg }+ | NasmMacro0 { ann :: a, macroName :: BS.ByteString }+ deriving (Generic, NFData, Functor)++i4 :: Doc ann -> Doc ann+i4 = indent 4++instance Pretty reg => Pretty (Addr reg) where+ pretty (Reg r) = brackets (pretty r)+ pretty (AddrRRPlus r0 r1) = brackets (pretty r0 <> "+" <> pretty r1)+ pretty (AddrRCPlus r c) = brackets (pretty r <> "+" <> pretty c)+ pretty (AddrRCMinus r c) = brackets (pretty r <> "-" <> pretty c)+ pretty (AddrRRScale r0 r1 c) = brackets (pretty r0 <> "+" <> pretty r1 <> "*" <> pretty c)++prettyLabel :: Label -> Doc ann+prettyLabel l = "kmp_" <> pretty l++prettyLive :: Pretty reg => X86 reg Liveness -> Doc ann+prettyLive r = pretty r <+> pretty (ann r)++-- intel syntax+instance Pretty reg => Pretty (X86 reg a) where+ pretty (PushReg _ r) = i4 ("push" <+> pretty r)+ pretty (PushMem _ a) = i4 ("push" <+> pretty a)+ pretty (PopMem _ a) = i4 ("pop qword" <+> pretty a)+ pretty (PopReg _ r) = i4 ("pop" <+> pretty r)+ pretty (PushConst _ i) = i4 ("push" <+> pretty i)+ pretty (Jump _ l) = i4 ("jmp" <+> prettyLabel l)+ pretty (Call _ l) = i4 ("call" <+> prettyLabel l)+ pretty Ret{} = i4 "ret"+ pretty (MovRA _ r a) = i4 ("mov" <+> pretty r <> "," <+> pretty a)+ pretty (MovAR _ a r) = i4 ("mov" <+> pretty a <> "," <+> pretty r)+ pretty (MovABool _ a b) = i4 ("mov byte" <+> pretty a <> "," <+> pretty b)+ pretty (MovACi8 _ a i) = i4 ("mov byte" <+> pretty a <> "," <+> pretty i)+ pretty (MovRCi8 _ r i) = i4 ("mov byte" <+> pretty r <> "," <+> pretty i)+ pretty (MovRWord _ r w) = i4 ("mov qword" <+> pretty r <> "," <+> prettyHex w)+ pretty (MovRR _ r0 r1) = i4 ("mov" <+> pretty r0 <> "," <+> pretty r1)+ pretty (MovRC _ r i) = i4 ("mov" <+> pretty r <> "," <+> pretty i)+ pretty (MovAC _ a i) = i4 ("mov qword" <+> pretty a <> "," <+> pretty i)+ pretty (MovRCBool _ r b) = i4 ("mov" <+> pretty r <> "," <+> pretty b)+ pretty (MovRL _ r bl) = i4 ("mov" <+> pretty r <> "," <+> pretty (decodeUtf8 bl))+ pretty (AddRR _ r0 r1) = i4 ("add" <+> pretty r0 <> "," <> pretty r1)+ pretty (AddAC _ a c) = i4 ("add" <+> pretty a <> "," <+> pretty c)+ pretty (SubRR _ r0 r1) = i4 ("sub" <+> pretty r0 <> "," <> pretty r1)+ pretty (ImulRR _ r0 r1) = i4 ("imul" <+> pretty r0 <> "," <+> pretty r1)+ pretty (XorRR _ r0 r1) = i4 ("xor" <+> pretty r0 <> "," <+> pretty r1)+ pretty (AddRC _ r0 c) = i4 ("add" <+> pretty r0 <> "," <+> pretty c)+ pretty (SubRC _ r0 c) = i4 ("sub" <+> pretty r0 <> "," <+> pretty c)+ pretty (Label _ l) = prettyLabel l <> colon+ pretty (BSLabel _ b) = let pl = pretty (decodeUtf8 b) in "global" <+> pl <> hardline <> pl <> colon+ pretty (Je _ l) = i4 ("je" <+> prettyLabel l)+ pretty (Jl _ l) = i4 ("jl" <+> prettyLabel l)+ pretty (CmpAddrReg _ a r) = i4 ("cmp" <+> pretty a <> "," <+> pretty r)+ pretty (CmpRegReg _ r0 r1) = i4 ("cmp" <+> pretty r0 <> "," <+> pretty r1)+ pretty (CmpAddrBool _ a b) = i4 ("cmp byte" <+> pretty a <> "," <+> pretty b)+ pretty (CmpRegBool _ r b) = i4 ("cmp" <+> pretty r <> "," <+> pretty b)+ pretty (ShiftRRR _ r0 r1) = i4 ("shr" <+> pretty r0 <> "," <+> pretty r1)+ pretty (ShiftLRR _ r0 r1) = i4 ("shl" <+> pretty r0 <> "," <+> pretty r1)+ pretty (IdivR _ r) = i4 ("idiv" <+> pretty r)+ pretty (DivR _ r) = i4 ("div" <+> pretty r)+ pretty Cqo{} = i4 "cqo"+ pretty (MovACTag _ a t) = i4 ("mov" <+> pretty a <> "," <+> pretty t)+ pretty (AndRR _ r0 r1) = i4 ("and" <+> pretty r0 <+> pretty r1)+ pretty (OrRR _ r0 r1) = i4 ("or" <+> pretty r0 <+> pretty r1)+ pretty (PopcountRR _ r0 r1) = i4 ("popcnt" <+> pretty r0 <> "," <+> pretty r1)+ pretty (NegR _ r) = i4 ("neg" <+> pretty r)+ pretty (Jne _ l) = i4 ("jne" <+> prettyLabel l)+ pretty (Jg _ l) = i4 ("jg" <+> prettyLabel l)+ pretty (Jge _ l) = i4 ("jge" <+> prettyLabel l)+ pretty (Jle _ l) = i4 ("jle" <+> prettyLabel l)+ 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++prettyDebugAsm :: Pretty reg => [X86 reg Liveness] -> Doc ann+prettyDebugAsm = concatWith (\x y -> x <> hardline <> y) . fmap prettyLive++prolegomena :: Doc ann+prolegomena = "section .bss" <> hardline <> "kempe_data: resb 0x8012" -- 32 kb++macros :: Doc ann+macros = prettyLines+ [ calleeSave+ , calleeRestore+ , callerSave+ , callerRestore+ ]++-- rbx, rbp, r12-r15 callee-saved (non-volatile)+-- rest caller-saved (volatile)++-- | Save non-volatile registers+calleeSave :: Doc ann+calleeSave =+ "%macro calleesave 0"+ <#> prettyLines (fmap pretty toPush)+ <#> "%endmacro"+ where toPush = PushReg () <$> [Rbx, Rbp, R12, R13, R14, R15]++calleeRestore :: Doc ann+calleeRestore =+ "%macro calleerestore 0"+ <#> prettyLines (fmap pretty toPop)+ <#> "%endmacro"+ where toPop = PopReg () <$> [R15, R14, R13, R12, Rbp, Rbx]++callerSave :: Doc ann+callerSave =+ "%macro callersave 0"+ <#> prettyLines (fmap pretty toPush)+ <#> "%endmacro"+ where toPush = PushReg () <$> [Rax, Rcx, Rdx, Rsi, Rdi, R8, R9, R10, R11]++callerRestore :: Doc ann+callerRestore =+ "%macro callerrestore 0"+ <#> prettyLines (fmap pretty toPop)+ <#> "%endmacro"+ where toPop = PopReg () <$> [R11, R10, R9, R8, Rdi, Rsi, Rdx, Rcx, Rax]
+ src/Kempe/Error.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Error ( Error (..)+ ) where++import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Kempe.AST+import Kempe.Name+import Prettyprinter (Pretty (pretty), comma, squotes, (<+>))++-- reject mutually recursive types? idk :p+data Error a = PoorScope a (Name a)+ | MismatchedLengths a (StackType a) (StackType a)+ | UnificationFailed a (KempeTy a) (KempeTy a) -- TODO: include atom expression?+ | TyVarExt a (Name a)+ | MonoFailed a+ | LessGeneral a (StackType a) (StackType a)+ | InvalidCExport a (Name a)+ | InvalidCImport a (Name a)+ | IllKinded a (KempeTy a)+ | BadType a+ deriving (Generic, NFData)++instance (Pretty a) => Show (Error a) where+ show = show . pretty++instance Pretty (Error a) where+ pretty (PoorScope _ n) = "name" <+> squotes (pretty n) <+> "not in scope"+ pretty (MismatchedLengths _ st0 st1) = "mismatched type lengths" <+> pretty st0 <> comma <+> pretty st1+ pretty (UnificationFailed _ ty ty') = "could not unify type" <+> squotes (pretty ty) <+> "with" <+> squotes (pretty ty')+ pretty (TyVarExt _ n) = "Error in function" <+> pretty n <> ": type variables may not occur in external or exported functions."+ pretty (MonoFailed _) = "Monomorphization step failed"+ pretty (LessGeneral _ sty sty') = "Type" <+> pretty sty' <+> "is not as general as type" <+> pretty sty+ pretty (InvalidCExport _ n) = "C export" <+> pretty n <+> "has more than one return value"+ pretty (InvalidCImport _ n) = pretty n <+> "imported functions can have at most one return value"+ pretty (IllKinded _ ty) = "Ill-kinded type:" <+> squotes (pretty ty) <> ". Note that type variables have kind ⭑ in Kempe."+ pretty (BadType _) = "All types appearing in a signature must have kind ⭑"++instance (Pretty a, Typeable a) => Exception (Error a)
+ src/Kempe/File.hs view
@@ -0,0 +1,82 @@+module Kempe.File ( tcFile+ , dumpMono+ , dumpTyped+ , irFile+ , x86File+ , dumpX86+ , compile+ , parsedFp+ ) 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 qualified Data.Set as S+import Data.Tuple.Extra (fst3)+import Kempe.AST+import Kempe.Asm.X86.Type+import Kempe.Error+import Kempe.IR+import Kempe.Lexer+import Kempe.Parser+import Kempe.Pipeline+import Kempe.Proc.Nasm+import Kempe.Shuttle+import Kempe.TyAssign+import Prettyprinter (Doc, hardline)+import Prettyprinter.Render.Text (putDoc)++tcFile :: FilePath -> IO (Either (Error ()) ())+tcFile fp = do+ contents <- BSL.readFile fp+ (maxU, m) <- yeetIO $ parseWithMax contents+ pure $ fst <$> runTypeM maxU (checkModule m)++yeetIO :: Exception e => Either e a -> IO a+yeetIO = either throwIO pure++dumpTyped :: FilePath -> IO ()+dumpTyped fp = do+ (i, m) <- parsedFp fp+ (mTyped, _) <- yeetIO $ runTypeM i (assignModule m)+ putDoc $ prettyTypedModule mTyped++dumpMono :: FilePath -> IO ()+dumpMono fp = do+ (i, m) <- parsedFp 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 = prettyIR . fst3 .* irGen++dumpX86 :: Int -> Module a c b -> Doc ann+dumpX86 = prettyAsm .* x86Alloc++irFile :: FilePath -> IO ()+irFile fp = do+ res <- parsedFp 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+ putDoc $ uncurry dumpX86 res <> hardline++compile :: FilePath+ -> FilePath+ -> Bool -- ^ Debug symbols?+ -> IO ()+compile fp o dbg = do+ contents <- BSL.readFile fp+ res <- yeetIO $ parseWithMax contents+ writeO (uncurry dumpX86 res) o dbg
+ src/Kempe/IR.hs view
@@ -0,0 +1,571 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- | IR loosely based on Appel book.+module Kempe.IR ( writeModule+ , Stmt (..)+ , Exp (..)+ , RelBinOp (..)+ , IntBinOp (..)+ , BoolBinOp (..)+ , Label+ , Temp (..)+ , runTempM+ , TempM+ , prettyIR+ , WriteSt (..)+ , size+ ) where++import Control.DeepSeq (NFData)+import Data.Foldable (toList, traverse_)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+-- strict b/c it's faster according to benchmarks+import Control.Monad.State.Strict (State, gets, modify, runState)+import Data.Bifunctor (second)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Foldable.Ext+import Data.Int (Int64, Int8)+import qualified Data.IntMap as IM+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Word (Word8)+import GHC.Generics (Generic)+import Kempe.AST+import Kempe.Name+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.Ext++type Label = Word++data Temp = Temp64 !Int+ | Temp8 !Int+ | DataPointer -- RBP on x86 and x19 on aarch64?+ deriving (Eq, Generic, NFData)++instance Pretty Temp where+ pretty (Temp64 i) = "t_" <> pretty i+ pretty (Temp8 i) = "t8_" <> pretty i+ pretty DataPointer = "datapointer"++data WriteSt = WriteSt { wlabels :: [Label]+ , temps :: [Int]+ }++data TempSt = TempSt { labels :: [Label]+ , tempSupply :: [Int]+ , atLabels :: IM.IntMap Label+ -- TODO: type sizes in state+ }++asWriteSt :: TempSt -> WriteSt+asWriteSt (TempSt ls ts _) = WriteSt ls ts++runTempM :: TempM a -> (a, WriteSt)+runTempM = second asWriteSt . flip runState (TempSt [1..] [1..] mempty)++atLabelsLens :: Lens' TempSt (IM.IntMap Label)+atLabelsLens f s = fmap (\x -> s { atLabels = x }) (f (atLabels s))++nextLabels :: TempSt -> TempSt+nextLabels (TempSt ls ts ats) = TempSt (tail ls) ts ats++nextTemps :: TempSt -> TempSt+nextTemps (TempSt ls ts ats) = TempSt ls (tail ts) ats++type TempM = State TempSt++getTemp :: TempM Int+getTemp = gets (head . tempSupply) <* modify nextTemps++getTemp64 :: TempM Temp+getTemp64 = Temp64 <$> getTemp++getTemp8 :: TempM Temp+getTemp8 = Temp8 <$> getTemp++newLabel :: TempM Label+newLabel = gets (head . labels) <* modify nextLabels++broadcastName :: Unique -> TempM ()+broadcastName (Unique i) = do+ l <- newLabel+ modifying atLabelsLens (IM.insert i l)++lookupName :: Name a -> TempM Label+lookupName (Name _ (Unique i) _) =+ gets+ (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++prettyLabel :: Label -> Doc ann+prettyLabel l = "kmp" <> pretty l++instance Pretty Stmt where+ pretty (Labeled l) = hardline <> prettyLabel l <> colon+ pretty (Jump l) = parens ("j" <+> prettyLabel l)+ pretty (CCall ty bs) = parens ("C" <+> pretty (decodeUtf8 (BSL.toStrict bs)) <+> braces (prettyMonoStackType ty))+ pretty (KCall l) = parens ("call" <+> prettyLabel l)+ pretty Ret = parens "ret"+ pretty (MovTemp t e) = parens ("movtemp" <+> pretty t <+> pretty e)+ pretty (MovMem e _ e') = parens ("movmem" <+> pretty e <+> pretty e') -- TODO: maybe print size?+ pretty (CJump e l l') = parens ("cjump" <+> pretty e <+> prettyLabel l <+> prettyLabel l')+ pretty (WrapKCall _ ty fn l) = hardline <> "export" <+> pretty (decodeUtf8 fn) <+> braces (prettyMonoStackType ty) <+> prettyLabel l+ pretty (MJump e l) = parens ("mjump" <+> pretty e <+> prettyLabel l)++instance Pretty Exp where+ pretty (ConstInt i) = parens ("int" <+> pretty i)+ pretty (ConstInt8 i) = parens ("int8" <+> pretty i)+ pretty (ConstWord n) = parens ("word" <+> pretty n)+ pretty (ConstBool False) = parens "bool false"+ pretty (ConstBool True) = parens "bool true"+ pretty (Reg t) = parens ("reg" <+> pretty t)+ pretty (Mem sz e) = parens ("mem" <+> brackets (pretty sz) <+> pretty e)+ pretty (ExprIntBinOp op e e') = parens (pretty op <+> pretty e <+> pretty e')+ pretty (ExprIntRel op e e') = parens (pretty op <+> pretty e <+> pretty e')+ pretty (ConstTag b) = parens ("tag" <+> prettyHex b)+ pretty (BoolBinOp op e e') = parens (pretty op <+> pretty e <+> pretty e')+ pretty (IntNegIR e) = parens ("~" <+> pretty e)+ pretty (PopcountIR e) = parens ("popcount" <+> pretty e)+ pretty (EqByte e e') = parens ("=b" <+> pretty e <+> pretty e')++data Stmt = Labeled Label+ | Jump Label+ -- conditional jump for ifs+ | CJump Exp Label Label+ | MJump Exp Label+ | CCall MonoStackType BSL.ByteString+ | KCall Label -- KCall is a jump to a Kempe procedure+ | WrapKCall ABI MonoStackType BS.ByteString Label+ | MovTemp Temp Exp -- put e in temp+ | MovMem Exp Int64 Exp -- store e2 at address given by e1+ | Ret+ deriving (Generic, NFData)++data Exp = ConstInt Int64+ | ConstInt8 Int8+ | ConstTag Word8+ | ConstWord Word+ | ConstBool Bool+ | Reg Temp -- TODO: size?+ | Mem Int64 Exp -- fetch from address+ | ExprIntBinOp IntBinOp Exp Exp+ | ExprIntRel RelBinOp Exp Exp+ | BoolBinOp BoolBinOp Exp Exp+ | IntNegIR Exp+ | PopcountIR Exp+ | EqByte Exp Exp+ deriving (Generic, NFData)+ -- TODO: one for data, one for C ABI++data BoolBinOp = BoolAnd+ | BoolOr+ | BoolXor+ deriving (Generic, NFData)++instance Pretty BoolBinOp where+ pretty BoolAnd = "&"+ pretty BoolOr = "||"+ pretty BoolXor = "xor"++data RelBinOp = IntEqIR+ | IntNeqIR+ | IntLtIR+ | IntGtIR+ | IntLeqIR+ | IntGeqIR+ deriving (Generic, NFData)++instance Pretty RelBinOp where+ pretty IntEqIR = "="+ pretty IntNeqIR = "!="+ pretty IntLtIR = "<"+ pretty IntGtIR = ">"+ pretty IntLeqIR = "<="+ pretty IntGeqIR = ">="++data IntBinOp = IntPlusIR+ | IntTimesIR+ | IntDivIR+ | IntMinusIR+ | IntModIR -- rem?+ | IntXorIR+ | WordShiftRIR -- compiles to shr on x86+ | WordShiftLIR+ -- int/word mod are different, see: https://stackoverflow.com/questions/8231882/how-to-implement-the-mod-operator-in-assembly+ | WordModIR+ | WordDivIR+ deriving (Generic, NFData)++instance Pretty IntBinOp where+ pretty IntPlusIR = "+"+ pretty IntTimesIR = "*"+ pretty IntDivIR = "/"+ pretty IntMinusIR = "-"+ pretty IntModIR = "%"+ pretty IntXorIR = "xor"+ pretty WordShiftRIR = ">>"+ pretty WordShiftLIR = "<<"+ pretty WordModIR = "%~"+ pretty WordDivIR = "/~"++writeModule :: SizeEnv -> Module () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]+writeModule env m = traverse_ assignName m *> foldMapA (writeDecl env) m++-- optimize tail-recursion, if possible+-- This is a little slow+tryTCO :: Bool -- ^ Can it be optimized here?+ -> [Stmt]+ -> [Stmt]+tryTCO _ [] = []+tryTCO False stmts = stmts+tryTCO True stmts =+ let end = last stmts+ in+ case end of+ KCall l' -> init stmts ++ [Jump l']+ _ -> stmts++assignName :: KempeDecl a c b -> TempM ()+assignName (FunDecl _ (Name _ u _) _ _ _) = broadcastName u+assignName (ExtFnDecl _ (Name _ u _) _ _ _) = broadcastName u+assignName Export{} = pure ()+assignName TyDecl{} = error "Internal error: type declarations should not exist at this stage"+++-- FIXME: Current broadcast + write approach fails mutually recursive functions+writeDecl :: SizeEnv -> KempeDecl () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]+writeDecl env (FunDecl _ n _ _ as) = do+ bl <- lookupName n+ (++ [Ret]) . (Labeled bl:) . tryTCO True <$> writeAtoms env True as+writeDecl _ (ExtFnDecl ty n _ _ cName) = do+ bl <- lookupName n+ pure [Labeled bl, CCall ty cName, Ret]+writeDecl _ (Export sTy abi n) = pure . WrapKCall abi sTy (encodeUtf8 $ name n) <$> lookupName n+writeDecl _ TyDecl{} = error "Internal error: type declarations should not exist at this stage"++writeAtoms :: SizeEnv -> Bool -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]+writeAtoms _ _ [] = pure []+writeAtoms env False stmts = foldMapA (writeAtom env False) stmts+writeAtoms env l stmts =+ let end = last stmts+ in (++) <$> foldMapA (writeAtom env False) (init stmts) <*> writeAtom env l end++intShift :: IntBinOp -> TempM [Stmt]+intShift cons = do+ t0 <- getTemp8+ t1 <- getTemp64+ pure $+ pop 1 t0 ++ pop 8 t1 ++ push 8 (ExprIntBinOp cons (Reg t1) (Reg t0))++boolOp :: BoolBinOp -> TempM [Stmt]+boolOp op = do+ t0 <- getTemp8+ t1 <- getTemp8+ pure $+ pop 1 t0 ++ pop 1 t1 ++ push 1 (BoolBinOp op (Reg t1) (Reg t0))++intOp :: IntBinOp -> TempM [Stmt]+intOp cons = do+ t0 <- getTemp64 -- registers are 64 bits for integers+ t1 <- getTemp64+ pure $+ pop 8 t0 ++ pop 8 t1 ++ push 8 (ExprIntBinOp cons (Reg t1) (Reg t0))++-- | Push bytes onto the Kempe data pointer+push :: Int64 -> Exp -> [Stmt]+push off e =+ [ MovMem (Reg DataPointer) off e+ , dataPointerInc off -- increment instead of decrement b/c this is the Kempe ABI+ ]++pop :: Int64 -> Temp -> [Stmt]+pop sz t =+ [ dataPointerDec sz+ , MovTemp t (Mem sz (Reg DataPointer))+ ]++-- FIXME: just use expressions from memory accesses+intRel :: RelBinOp -> TempM [Stmt]+intRel cons = do+ t0 <- getTemp64+ t1 <- getTemp64+ pure $+ pop 8 t0 ++ pop 8 t1 ++ push 1 (ExprIntRel cons (Reg t1) (Reg t0))++intNeg :: TempM [Stmt]+intNeg = do+ t0 <- getTemp64+ pure $+ pop 8 t0 ++ push 8 (IntNegIR (Reg t0))++wordCount :: TempM [Stmt]+wordCount = do+ t0 <- getTemp64+ pure $+ pop 8 t0 ++ push 8 (PopcountIR (Reg t0))++-- | This throws exceptions on nonsensical input.+writeAtom :: SizeEnv+ -> Bool -- ^ Can we do TCO?+ -> Atom (ConsAnn MonoStackType) MonoStackType+ -> TempM [Stmt]+writeAtom _ _ (IntLit _ i) = pure $ push 8 (ConstInt $ fromInteger i)+writeAtom _ _ (Int8Lit _ i) = pure $ push 1 (ConstInt8 i)+writeAtom _ _ (WordLit _ w) = pure $ push 8 (ConstWord $ fromIntegral w)+writeAtom _ _ (BoolLit _ b) = pure $ push 1 (ConstBool b)+writeAtom _ _ (AtName _ n) = pure . KCall <$> lookupName n+writeAtom _ _ (AtBuiltin ([], _) Drop) = error "Internal error: Ill-typed drop!"+writeAtom _ _ (AtBuiltin ([], _) Dup) = error "Internal error: Ill-typed dup!"+writeAtom _ _ (Dip ([], _) _) = error "Internal error: Ill-typed dip()!"+writeAtom _ _ (AtBuiltin _ IntPlus) = intOp IntPlusIR+writeAtom _ _ (AtBuiltin _ IntMinus) = intOp IntMinusIR+writeAtom _ _ (AtBuiltin _ IntTimes) = intOp IntTimesIR+writeAtom _ _ (AtBuiltin _ IntDiv) = intOp IntDivIR -- what to do on failure?+writeAtom _ _ (AtBuiltin _ IntMod) = intOp IntModIR+writeAtom _ _ (AtBuiltin _ IntXor) = intOp IntXorIR+writeAtom _ _ (AtBuiltin _ IntShiftR) = intShift WordShiftRIR -- TODO: shr or sar?+writeAtom _ _ (AtBuiltin _ IntShiftL) = intShift WordShiftLIR+writeAtom _ _ (AtBuiltin _ IntEq) = intRel IntEqIR+writeAtom _ _ (AtBuiltin _ IntLt) = intRel IntLtIR+writeAtom _ _ (AtBuiltin _ IntLeq) = intRel IntLeqIR+writeAtom _ _ (AtBuiltin _ WordPlus) = intOp IntPlusIR+writeAtom _ _ (AtBuiltin _ WordTimes) = intOp IntTimesIR+writeAtom _ _ (AtBuiltin _ WordXor) = intOp IntXorIR+writeAtom _ _ (AtBuiltin _ WordMinus) = intOp IntMinusIR+writeAtom _ _ (AtBuiltin _ IntNeq) = intRel IntNeqIR+writeAtom _ _ (AtBuiltin _ IntGeq) = intRel IntGeqIR+writeAtom _ _ (AtBuiltin _ IntGt) = intRel IntGtIR+writeAtom _ _ (AtBuiltin _ WordShiftL) = intShift WordShiftLIR+writeAtom _ _ (AtBuiltin _ WordShiftR) = intShift WordShiftRIR+writeAtom _ _ (AtBuiltin _ WordDiv) = intOp WordDivIR+writeAtom _ _ (AtBuiltin _ WordMod) = intOp WordModIR+writeAtom _ _ (AtBuiltin _ And) = boolOp BoolAnd+writeAtom _ _ (AtBuiltin _ Or) = boolOp BoolOr+writeAtom _ _ (AtBuiltin _ Xor) = boolOp BoolXor+writeAtom _ _ (AtBuiltin _ IntNeg) = intNeg+writeAtom _ _ (AtBuiltin _ Popcount) = wordCount+writeAtom env _ (AtBuiltin (is, _) Drop) =+ let sz = size env (last is) in+ pure [ dataPointerDec sz ]+writeAtom env _ (AtBuiltin (is, _) Dup) =+ let sz = size env (last is) in+ pure $+ copyBytes 0 (-sz) sz+ ++ [ dataPointerInc sz ] -- move data pointer over sz bytes+writeAtom env l (If _ as as') = do+ l0 <- newLabel+ l1 <- newLabel+ let ifIR = CJump (Mem 1 (Reg DataPointer)) l0 l1+ asIR <- tryTCO l <$> writeAtoms env l as+ asIR' <- tryTCO l <$> writeAtoms env l as'+ 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)+ in foldMapA (dipify env sz) as+writeAtom env _ (AtBuiltin ([i0, i1], _) Swap) =+ let sz0 = size env i0+ sz1 = size env i1+ in+ pure $+ copyBytes 0 (-sz0 - sz1) sz0 -- copy i0 to end of the stack+ ++ copyBytes (-sz0 - sz1) (-sz1) sz1 -- copy i1 to where i0 used to be+ ++ copyBytes (-sz0) 0 sz0 -- copy i0 at end of stack to its new place+writeAtom _ _ (AtBuiltin _ Swap) = error "Ill-typed swap!"+writeAtom env _ (AtCons ann@(ConsAnn _ tag' _) _) =+ pure $ dataPointerInc (padBytes env ann) : push 1 (ConstTag tag')+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)+ in do+ leaves <- zipWithM (mkLeaf env l) ps ass+ let (switches, meat) = NE.unzip leaves+ ret <- newLabel+ let meat' = (++ [Jump ret]) . toList <$> meat+ pure $ dataPointerDec decSz : concatMap toList switches ++ concat meat' ++ [Labeled ret]++zipWithM :: (Applicative m) => (a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m (NonEmpty c)+zipWithM f xs ys = sequenceA (NE.zipWith f xs ys)++mkLeaf :: SizeEnv -> Bool -> Pattern (ConsAnn MonoStackType) MonoStackType -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM ([Stmt], [Stmt])+mkLeaf env l p as = do+ l' <- newLabel+ as' <- writeAtoms env l as+ let s = patternSwitch env p l'+ pure (s, Labeled l' : as')++patternSwitch :: SizeEnv -> Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt]+patternSwitch _ (PatternBool _ True) l = [MJump (Mem 1 (Reg DataPointer)) l]+patternSwitch _ (PatternBool _ False) l = [MJump (EqByte (Mem 1 (Reg DataPointer)) (ConstTag 0)) l]+patternSwitch _ (PatternWildcard _) l = [Jump l]+patternSwitch _ (PatternInt _ i) l = [MJump (ExprIntRel IntEqIR (Mem 8 (Reg DataPointer)) (ConstInt $ fromInteger i)) l]+patternSwitch env (PatternCons ann@(ConsAnn _ tag' _) _) l =+ let padAt = padBytes env ann + 1+ -- decrement by padAt bytes (to discard padding), then we need to access+ -- the tag at [datapointer+padAt] when we check+ in [ dataPointerDec padAt, MJump (EqByte (Mem 1 (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt padAt))) (ConstTag tag')) l]++-- | Constructors may need to be padded, this computes the number of bytes of+-- padding+padBytes :: SizeEnv -> ConsAnn MonoStackType -> Int64+padBytes env (ConsAnn sz _ (is, _)) = sz - sizeStack env is - 1++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)+ 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+ in+ pure $+ copyBytes 0 (-sz - sz0 - sz1) sz0 -- copy i0 to end of the stack+ ++ copyBytes (-sz - sz0 - sz1) (-sz - sz1) sz1 -- copy i1 to where i0 used to be+ ++ 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)+ in foldMapA (dipify env (sz + sz')) as+dipify _ _ (AtBuiltin _ Swap) = error "Internal error: Ill-typed swap!"+dipify _ sz (AtBuiltin _ IntTimes) = dipOp sz IntTimesIR+dipify _ sz (AtBuiltin _ IntPlus) = dipOp sz IntPlusIR+dipify _ sz (AtBuiltin _ IntMinus) = dipOp sz IntMinusIR+dipify _ sz (AtBuiltin _ IntDiv) = dipOp sz IntDivIR+dipify _ sz (AtBuiltin _ IntMod) = dipOp sz IntModIR+dipify _ sz (AtBuiltin _ IntXor) = dipOp sz IntXorIR+dipify _ sz (AtBuiltin _ IntEq) = dipRel sz IntEqIR+dipify _ sz (AtBuiltin _ IntLt) = dipRel sz IntLtIR+dipify _ sz (AtBuiltin _ IntLeq) = dipRel sz IntLeqIR+dipify _ sz (AtBuiltin _ IntShiftL) = dipShift sz WordShiftLIR+dipify _ sz (AtBuiltin _ IntShiftR) = dipShift sz WordShiftRIR+dipify _ sz (AtBuiltin _ WordXor) = dipOp sz IntXorIR+dipify _ sz (AtBuiltin _ WordShiftL) = dipShift sz WordShiftLIR+dipify _ sz (AtBuiltin _ WordShiftR) = dipShift sz WordShiftRIR+dipify _ sz (AtBuiltin _ WordPlus) = dipOp sz IntPlusIR+dipify _ sz (AtBuiltin _ WordTimes) = dipOp sz IntTimesIR+dipify _ sz (AtBuiltin _ IntGeq) = dipRel sz IntGeqIR+dipify _ sz (AtBuiltin _ IntGt) = dipRel sz IntGtIR+dipify _ sz (AtBuiltin _ IntNeq) = dipRel sz IntNeqIR+dipify _ sz (AtBuiltin _ IntNeg) = plainShift sz <$> intNeg+dipify _ sz (AtBuiltin _ Popcount) = plainShift sz <$> wordCount+dipify _ sz (AtBuiltin _ And) = dipBoolOp sz BoolAnd+dipify _ sz (AtBuiltin _ Or) = dipBoolOp sz BoolOr+dipify _ sz (AtBuiltin _ Xor) = dipBoolOp sz BoolXor+dipify _ sz (AtBuiltin _ WordMinus) = dipOp sz IntMinusIR+dipify _ sz (AtBuiltin _ WordDiv) = dipOp sz WordDivIR+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+ 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)+ ++ copyBytes (-sz + sz') 0 sz -- copy sz bytes back+ ++ [ dataPointerInc sz' ] -- move data pointer over sz' bytes+dipify _ sz (IntLit _ i) = pure $ dipPush sz 8 (ConstInt $ fromInteger i)+dipify _ sz (WordLit _ w) = pure $ dipPush sz 8 (ConstWord $ fromIntegral w)+dipify _ sz (Int8Lit _ i) = pure $ dipPush sz 1 (ConstInt8 i)+dipify _ sz (BoolLit _ b) = pure $ dipPush sz 1 (ConstBool b)+dipify env sz (AtCons ann@(ConsAnn _ tag' _) _) =+ pure $+ copyBytes 0 (-sz) sz+ ++ dataPointerInc (padBytes env ann) : push 1 (ConstTag tag')+ ++ copyBytes (-sz) 0 sz+dipify env sz a@(If sty _ _) =+ dipSupp env sz sty <$> writeAtom env False a+dipify env sz (AtName sty n) =+ dipSupp env sz sty . pure . KCall <$> lookupName n+dipify env sz a@(Case sty _) =+ dipSupp env sz sty <$> writeAtom env False a++dipSupp :: SizeEnv -> Int64 -> MonoStackType -> [Stmt] -> [Stmt]+dipSupp env sz (is, os) stmts =+ let excessSz = sizeStack env os - sizeStack env is -- how much the atom(s) grow the stack+ in case compare excessSz 0 of+ EQ -> plainShift sz stmts+ LT -> dipDo sz stmts+ GT -> dipHelp excessSz sz stmts++dipHelp :: Int64 -> Int64 -> [Stmt] -> [Stmt]+dipHelp excessSz dipSz stmts =+ let shiftNext = dataPointerDec dipSz+ shiftBack = dataPointerInc dipSz+ in+ shiftNext+ : copyBytes excessSz (-dipSz) dipSz -- copy bytes past end of stack+ ++ stmts+ ++ copyBytes (-dipSz) 0 dipSz -- copy bytes back (now from 0 of stack; data pointer has been set)+ ++ [shiftBack]++dipPush :: Int64 -> Int64 -> Exp -> [Stmt]+dipPush sz sz' e =+ -- FIXME: is this right?+ copyBytes 0 (-sz) sz+ ++ push sz' e+ ++ copyBytes (-sz) 0 sz -- copy bytes back (data pointer has been incremented already by push)++-- for e.g. negation where the stack size stays the same+plainShift :: Int64 -> [Stmt] -> [Stmt]+plainShift sz stmt =+ let shiftNext = dataPointerDec sz+ shiftBack = dataPointerInc sz+ in+ (shiftNext : stmt ++ [shiftBack])++-- works in general because relations, shifts, operations shrink the size of the+-- stack.+dipDo :: Int64 -> [Stmt] -> [Stmt]+dipDo sz stmt =+ let shiftNext = dataPointerDec sz+ shiftBack = dataPointerInc sz+ copyBytes' = copyBytes 0 sz sz+ in+ (shiftNext : stmt ++ copyBytes' ++ [shiftBack])++dipShift :: Int64 -> IntBinOp -> TempM [Stmt]+dipShift sz op = dipDo sz <$> intShift op++dipRel :: Int64 -> RelBinOp -> TempM [Stmt]+dipRel sz rel = dipDo sz <$> intRel rel++dipOp :: Int64 -> IntBinOp -> TempM [Stmt]+dipOp sz op = dipDo sz <$> intOp op++dipBoolOp :: Int64 -> BoolBinOp -> TempM [Stmt]+dipBoolOp sz op = dipDo sz <$> boolOp op++copyBytes :: Int64 -- ^ dest offset+ -> Int64 -- ^ src offset+ -> Int64 -- ^ Number of bytes to copy+ -> [Stmt]+copyBytes off1 off2 b+ | 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 ]+ | otherwise =+ [ MovMem (dataPointerPlus (i + off1)) 1 (Mem 1 $ dataPointerPlus (i + off2)) | i <- [0..(b-1)] ]++dataPointerDec :: Int64 -> Stmt+dataPointerDec i = MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i))++dataPointerInc :: Int64 -> Stmt+dataPointerInc i = MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i))++dataPointerPlus :: Int64 -> Exp+dataPointerPlus off =+ if off > 0+ then ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt off)+ else ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt (negate off))
+ src/Kempe/IR/Opt.hs view
@@ -0,0 +1,37 @@+module Kempe.IR.Opt ( optimize+ ) where++import Kempe.IR++optimize :: [Stmt] -> [Stmt]+optimize = successiveBumps++-- | Often IR generation will leave us with something like+--+-- > (movtemp datapointer (+ (reg datapointer) (int 8)))+-- > (movtemp datapointer (- (reg datapointer) (int 8)))+--+-- i.e. push a value and immediately pop it for use.+--+-- This is silly and we remove it in this pass.+successiveBumps :: [Stmt] -> [Stmt]+successiveBumps [] = []+successiveBumps+ ((MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i)))+ :(MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i')))+ :ss) | i == i' = successiveBumps ss+successiveBumps+ ((MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i)))+ :(MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i')))+ :ss) | i == i' = successiveBumps ss+successiveBumps+ ((MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i)))+ :(MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i')))+ :ss) =+ MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt $ i+i')) : successiveBumps ss+successiveBumps+ ((MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i)))+ :(MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i')))+ :ss) =+ MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt $ i+i')) : successiveBumps ss+successiveBumps (s:ss) = s : successiveBumps ss
+ src/Kempe/Inline.hs view
@@ -0,0 +1,88 @@+-- | A simple inliner. Inlines all non-recursive functions.+--+-- This should all work.+module Kempe.Inline ( inline+ ) where++import Data.Graph (Graph, Vertex, graphFromEdges, path)+import qualified Data.IntMap as IM+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Tuple.Extra (third3)+import Kempe.AST+import Kempe.Name+import Kempe.Unique++-- | A 'FnModuleMap' is a map which retrives the 'Atoms's defining+-- a given 'Name'+type FnModuleMap c b = IM.IntMap (Maybe [Atom c b])++inline :: Module a c b -> Module 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+ inlineAtoms n = concatMap (inlineAtom n)+ inlineAtom declName a@(AtName _ n) =+ if path graph (nLookup n) (nLookup declName) || don'tInline n+ then [a] -- no inline+ else foldMap (inlineAtom declName) $ findDecl a n+ inlineAtom declName (If l as as') =+ [If l (inlineAtoms declName as) (inlineAtoms declName as')]+ inlineAtom declName (Case l ls) =+ let (ps, ass) = NE.unzip ls+ in [Case l (NE.zip ps $ fmap (inlineAtoms declName) ass)]+ inlineAtom _ a = [a]+ fnMap = mkFnModuleMap m+ (graph, _, nLookup) = kempeGraph m+ findDecl at (Name _ (Unique k) _) =+ case findPreDecl k fnMap of+ Just as -> as+ Nothing -> pure at -- tried to inline an extern function+ findPreDecl = IM.findWithDefault (error "Internal error: FnModuleMap does not contain name/declaration!")+ recMap = graphRecursiveMap m (graph, nLookup)+ don'tInline (Name _ (Unique i) _) = IM.findWithDefault (error "Internal error! recursive map missing key!") i recMap++-- | 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 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)+ | otherwise = Just (i, False)+ fnRecursive (ExtFnDecl _ (Name _ (Unique i) _) _ _ _) = Just (i, True) -- not recursive but don't try to inline this+ fnRecursive _ = Nothing+ anyReachable n as =+ 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 = 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 = 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 = IM.fromList . mapMaybe toInt where+ toInt (FunDecl _ (Name _ (Unique i) _) _ _ as) = Just (i, Just as)+ toInt (ExtFnDecl _ (Name _ (Unique i) _) _ _ _) = Just (i, Nothing)+ toInt _ = Nothing++namesInAtoms :: [Atom c a] -> [Name a]+namesInAtoms = foldMap namesInAtom++namesInAtom :: Atom c a -> [Name a]+namesInAtom AtBuiltin{} = []+namesInAtom (If _ as as') = foldMap namesInAtom as <> foldMap namesInAtom as'+namesInAtom (Dip _ as) = foldMap namesInAtom as+namesInAtom (AtName _ n) = [n]+namesInAtom AtCons{} = []+namesInAtom IntLit{} = []+namesInAtom BoolLit{} = []+namesInAtom Int8Lit{} = []+namesInAtom WordLit{} = []+namesInAtom (Case _ as) = foldMap namesInAtom (foldMap snd as)
+ src/Kempe/Lexer.x view
@@ -0,0 +1,383 @@+{+ {-# LANGUAGE DeriveAnyClass #-}+ {-# LANGUAGE DeriveGeneric #-}+ {-# LANGUAGE OverloadedStrings #-}+ {-# LANGUAGE StandaloneDeriving #-}+ module Kempe.Lexer ( alexMonadScan+ , runAlex+ , runAlexSt+ , lexKempe+ , AlexPosn (..)+ , Alex (..)+ , Token (..)+ , Keyword (..)+ , Sym (..)+ , Builtin (..)+ , AlexUserState+ ) where++import Control.Arrow ((&&&))+import Control.DeepSeq (NFData)+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as ASCII+import Data.Functor (($>))+import Data.Int (Int8)+import qualified Data.IntMap as IM+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import GHC.Generics (Generic)+import Kempe.Name+import Kempe.Unique+import Numeric (readHex)+import Numeric.Natural (Natural)+import Prettyprinter (Pretty (pretty), (<+>), colon, dquotes, squotes)++}++%wrapper "monadUserState-bytestring"++$digit = [0-9]++$hexit = [0-9a-z]++$latin = [a-zA-Z]++@follow_char = [$latin $digit \-\!\_]++@name = [a-z] @follow_char*+@tyname = [A-Z] @follow_char*++@foreign = \" $latin @follow_char* \"++tokens :-++ <0> {++ $white+ ;++ ";".* ; -- comment++ "--" { mkSym Arrow }+ "=:" { mkSym DefEq }+ ":" { mkSym Colon }+ "{" { mkSym LBrace }+ "}" { mkSym RBrace }+ "[" { mkSym LSqBracket }+ "]" { mkSym RSqBracket }+ "(" { mkSym LParen }+ ")" { mkSym RParen }+ \| { mkSym VBar }+ "->" { mkSym CaseArr }+ "," { mkSym Comma }+ \_ { mkSym Underscore }++ -- ¬ ∧ ∨ ⇨ ⊻++ -- symbols/operators+ "%" { mkSym Percent }+ "*" { mkSym Times }+ "/" { mkSym Div }+ "+" { mkSym Plus }+ "-" { mkSym Minus }+ "<<" { mkSym ShiftL }+ ">>" { mkSym ShiftR }+ "+~" { mkSym PlusU }+ "*~" { mkSym TimesU }+ "-~" { mkSym MinusU }+ "/~" { mkSym DivU }+ "%~" { mkSym ModU }+ ">>~" { mkSym ShiftRU }+ "<<~" { mkSym ShiftLU }+ "=" { mkSym Eq }+ "!=" { mkSym Neq }+ "<=" { mkSym Leq }+ "<" { mkSym Lt }+ ">=" { mkSym Geq }+ ">" { mkSym Gt }+ "&" { mkSym AndTok }+ "||" { mkSym OrTok }+ "~" { mkSym NegTok }++ type { mkKw KwType }+ import { mkKw KwImport }+ case { mkKw KwCase }+ "$cfun" { mkKw KwCfun }+ if { mkKw KwIf }+ "%foreign" { mkKw KwForeign }+ "cabi" { mkKw KwCabi }+ "kabi" { mkKw KwKabi }++ -- builtin+ dip { mkBuiltin BuiltinDip }+ Int { mkBuiltin BuiltinInt }+ Int8 { mkBuiltin BuiltinInt8 }+ Word { mkBuiltin BuiltinWord }+ Bool { mkBuiltin BuiltinBool }+ True { mkBuiltin (BuiltinBoolLit True) }+ False { mkBuiltin (BuiltinBoolLit False) }+ dup { mkBuiltin BuiltinDup }+ drop { mkBuiltin BuiltinDrop }+ swap { mkBuiltin BuiltinSwap }+ xori { mkBuiltin BuiltinIntXor }+ xoru { mkBuiltin BuiltinWordXor }+ xor { mkBuiltin BuiltinBoolXor }+ popcount { mkBuiltin BuiltinPopcount }+++ $digit+ { tok (\p s -> alex $ TokInt p (read $ ASCII.unpack s)) }+ "_"$digit+ { tok (\p s -> alex $ TokInt p (negate $ read $ ASCII.unpack $ BSL.tail s)) }+ "0x"$hexit+u { tok (\p s -> TokWord p <$> readHex' (BSL.init $ BSL.drop 2 s)) }+ $digit+u { tok (\p s -> alex $ TokWord p $ (read $ ASCII.unpack (BSL.init s))) }+ $digit+"i8" { tok (\p s -> alex $ TokInt8 p (read $ ASCII.unpack (BSL.init $ BSL.init s))) }+ "_"$digit+"i8" { tok (\p s -> alex $ TokInt8 p (negate $ read $ ASCII.unpack (BSL.tail $ BSL.init $ BSL.init s))) }++ @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) }++ }++{++readHex' :: (Eq a, Num a) => BSL.ByteString -> Alex a+readHex' bs =+ case readHex (ASCII.unpack bs) of+ [] -> alexError "Invalid hexadecimal literal"+ ((i,_):_) -> pure i++alex :: a -> Alex a+alex = pure++tok f (p,_,s,_) len = f p (BSL.take len s)++constructor c t = tok (\p _ -> alex $ c p t)++mkKw = constructor TokKeyword++mkSym = constructor TokSym++mkBuiltin = constructor TokBuiltin++mkText :: BSL.ByteString -> T.Text+mkText = decodeUtf8 . BSL.toStrict++instance Pretty AlexPosn where+ pretty (AlexPn _ line col) = pretty line <> colon <> pretty col++deriving instance Generic AlexPosn++deriving instance NFData AlexPosn++-- functional bimap?+type AlexUserState = (Int, M.Map T.Text Int, IM.IntMap (Name AlexPosn))++alexInitUserState :: AlexUserState+alexInitUserState = (0, mempty, mempty)++gets_alex :: (AlexState -> a) -> Alex a+gets_alex f = Alex (Right . (id &&& f))++get_ust :: Alex AlexUserState+get_ust = gets_alex alex_ust++get_pos :: Alex AlexPosn+get_pos = gets_alex alex_pos++set_ust :: AlexUserState -> Alex ()+set_ust st = Alex (Right . (go &&& (const ())))+ where go s = s { alex_ust = st }++alexEOF = EOF <$> get_pos++data Sym = Arrow+ | Plus+ | PlusU+ | Minus+ | Percent+ | Div+ | Times+ | TimesU+ | DefEq+ | Eq+ | ShiftL+ | ShiftR+ | ShiftLU+ | ShiftRU+ | Colon+ | LBrace+ | RBrace+ | Semicolon+ | LSqBracket+ | RSqBracket+ | VBar+ | CaseArr+ | LParen+ | RParen+ | Comma+ | Underscore+ | Leq+ | Lt+ | MinusU+ | DivU+ | ModU+ | Neq+ | Geq+ | Gt+ | AndTok+ | OrTok+ | NegTok+ deriving (Generic, NFData)++instance Pretty Sym where+ pretty Arrow = "--"+ pretty Plus = "+"+ pretty PlusU = "+~"+ pretty Minus = "-"+ pretty Percent = "%"+ pretty Div = "/"+ pretty Times = "*"+ pretty TimesU = "*~"+ pretty DefEq = "=:"+ pretty Eq = "="+ pretty Colon = ":"+ pretty LBrace = "{"+ pretty RBrace = "}"+ pretty Semicolon = ";"+ pretty LSqBracket = "["+ pretty RSqBracket = "]"+ pretty VBar = "|"+ pretty CaseArr = "->"+ pretty LParen = "("+ pretty RParen = ")"+ pretty Comma = ","+ pretty Underscore = "_"+ pretty ShiftR = ">>"+ pretty ShiftL = "<<"+ pretty ShiftRU = ">>~"+ pretty ShiftLU = "<<~"+ pretty Leq = "<="+ pretty Lt = "<"+ pretty MinusU = "-~"+ pretty DivU = "/~"+ pretty ModU = "%~"+ pretty Neq = "!="+ pretty Geq = ">="+ pretty Gt = ">"+ pretty AndTok = "&"+ pretty OrTok = "||"+ pretty NegTok = "~"++data Keyword = KwType+ | KwImport+ | KwCase+ | KwCfun+ | KwIf+ | KwForeign+ | KwCabi+ | KwKabi+ deriving (Generic, NFData)++instance Pretty Keyword where+ pretty KwType = "type"+ pretty KwImport = "import"+ pretty KwCase = "case"+ pretty KwCfun = "$cfun"+ pretty KwIf = "if"+ pretty KwForeign = "%foreign"+ pretty KwCabi = "cabi"+ pretty KwKabi = "kabi"++data Builtin = BuiltinBool+ | BuiltinBoolLit { bool :: !Bool }+ | BuiltinInt+ | BuiltinInt8+ | BuiltinWord+ | BuiltinDip+ | BuiltinDrop+ | BuiltinSwap+ | BuiltinDup+ | BuiltinIntXor+ | BuiltinWordXor+ | BuiltinBoolXor+ | BuiltinPopcount+ deriving (Generic, NFData)++instance Pretty Builtin where+ pretty BuiltinBool = "Bool"+ pretty (BuiltinBoolLit b) = pretty b+ pretty BuiltinInt = "Int"+ pretty BuiltinInt8 = "Int8"+ pretty BuiltinWord = "Word"+ pretty BuiltinDip = "dip"+ pretty BuiltinDrop = "drop"+ pretty BuiltinSwap = "swap"+ pretty BuiltinDup = "dup"+ pretty BuiltinIntXor = "xori"+ pretty BuiltinWordXor = "xoru"+ pretty BuiltinBoolXor = "xor"+ pretty BuiltinPopcount = "popcount"++data Token a = EOF { loc :: a }+ | TokSym { loc :: a, _sym :: Sym }+ | TokName { loc :: a, _name :: (Name a) }+ | TokTyName { loc :: a, _tyName :: (TyName a) }+ | TokKeyword { loc :: a, _kw :: Keyword }+ | TokInt { loc :: a, int :: Integer }+ | TokInt8 { loc :: a, int8 :: Int8 }+ | TokWord { loc :: a, word :: Natural }+ | TokForeign { loc :: a, ident :: 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++newIdentAlex :: AlexPosn -> T.Text -> Alex (Name AlexPosn)+newIdentAlex pos t = do+ st <- get_ust+ let (st', n) = newIdent pos t st+ set_ust st' $> (n $> pos)++newIdent :: AlexPosn -> T.Text -> AlexUserState -> (AlexUserState, Name AlexPosn)+newIdent pos t pre@(max', names, uniqs) =+ case M.lookup t names of+ Just i -> (pre, Name t (Unique i) pos)+ Nothing -> let i = max' + 1+ in let newName = Name t (Unique i) pos+ in ((i, M.insert t i names, IM.insert i newName uniqs), newName)++loop :: Alex [Token AlexPosn]+loop = do+ tok' <- alexMonadScan+ case tok' of+ EOF{} -> pure []+ _ -> (tok' :) <$> loop++lexKempe :: BSL.ByteString -> Either String [Token AlexPosn]+lexKempe = flip runAlex loop++runAlexSt :: BSL.ByteString -> Alex a -> Either String (AlexUserState, a)+runAlexSt inp = withAlexSt inp alexInitUserState++withAlexSt :: BSL.ByteString -> AlexUserState -> Alex a -> Either String (AlexUserState, a)+withAlexSt inp ust (Alex f) = first alex_ust <$> f+ (AlexState { alex_bpos = 0+ , alex_pos = alexStartPos+ , alex_inp = inp+ , alex_chr = '\n'+ , alex_ust = ust+ , alex_scd = 0+ })++}
+ src/Kempe/Monomorphize.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | This module is kind of half-assed. I don't have any references and it fails+-- under various corner cases.+module Kempe.Monomorphize ( closedModule+ , MonoM+ , runMonoM+ , flattenModule+ , tryMono+ , ConsAnn (..)+ -- * Benchmark+ , closure+ , mkModuleMap+ ) where++import Control.Arrow ((&&&))+import Control.Monad ((<=<))+import Control.Monad.Except (MonadError, throwError)+import Control.Monad.State.Strict (StateT, gets, runStateT)+import Data.Bifunctor (second)+import Data.Containers.ListUtils (nubOrd)+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 qualified Data.Map as M+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Tuple (swap)+import Data.Tuple.Extra (fst3, snd3, thd3)+import Kempe.AST+import Kempe.Error+import Kempe.Name+import Kempe.Unique+import Lens.Micro (Lens')+import Lens.Micro.Mtl (modifying)++-- | New function names, keyed by name + specialized type+--+-- also max state threaded through.+data RenameEnv = RenameEnv { maxState :: Int+ , fnEnv :: M.Map (Unique, StackType ()) Unique+ , consEnv :: M.Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType)+ , szEnv :: SizeEnv+ }++type MonoM = StateT RenameEnv (Either (Error ()))++maxStateLens :: Lens' RenameEnv Int+maxStateLens f s = fmap (\x -> s { maxState = x }) (f (maxState s))++consEnvLens :: Lens' RenameEnv (M.Map (Unique, StackType ()) (Unique, ConsAnn MonoStackType))+consEnvLens f s = fmap (\x -> s { consEnv = x }) (f (consEnv s))++fnEnvLens :: Lens' RenameEnv (M.Map (Unique, StackType ()) Unique)+fnEnvLens f s = fmap (\x -> s { fnEnv = x }) (f (fnEnv s))++szEnvLens :: Lens' RenameEnv SizeEnv+szEnvLens f s = fmap (\x -> s { szEnv = x }) (f (szEnv s))++runMonoM :: Int -> MonoM a -> Either (Error ()) (a, (Int, SizeEnv))+runMonoM maxI = fmap (second (maxState &&& szEnv)) . flip runStateT (RenameEnv maxI mempty mempty mempty)++freshName :: T.Text -> a -> MonoM (Name a)+freshName n ty = do+ pSt <- gets maxState+ Name n (Unique $ pSt + 1) ty+ <$ modifying maxStateLens (+1)++tryMono :: MonadError (Error ()) m => StackType () -> m MonoStackType+tryMono (StackType _ is os) | S.null (freeVars (is ++ os)) = pure (is, os)+ | otherwise = throwError $ MonoFailed ()++-- | A 'ModuleMap' is a map which retrives the 'KempeDecl' associated with+-- a given 'Name'+type ModuleMap a c b = IM.IntMap (KempeDecl a c b)++mkModuleMap :: Module 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)]+ toInt d@(TyDecl _ _ _ ds) =+ let us = unUnique . unique . fst <$> ds+ in (, d) <$> us+ toInt _ = []++squishTypeName :: BuiltinTy -> T.Text+squishTypeName TyInt = "int"+squishTypeName TyBool = "bool"+squishTypeName TyWord = "word"+squishTypeName TyInt8 = "int8"++squishType :: KempeTy a -> T.Text+squishType (TyBuiltin _ b) = squishTypeName b+squishType (TyNamed _ (Name t _ _)) = T.toLower t+squishType TyVar{} = error "not meant to be monomorphized!"+squishType (TyApp _ ty ty') = squishType ty <> squishType ty'++squishMonoStackType :: MonoStackType -> T.Text+squishMonoStackType (is, os) = foldMap squishType is <> "TT" <> foldMap squishType os++renamePattern :: Pattern (StackType ()) (StackType ()) -> MonoM (Pattern (ConsAnn MonoStackType) (StackType ()))+renamePattern (PatternInt ty i) = pure $ PatternInt ty i+renamePattern (PatternWildcard ty) = pure $ PatternWildcard ty+renamePattern (PatternBool ty b) = pure $ PatternBool ty b+renamePattern (PatternCons ty (Name t u _)) = do+ cSt <- gets consEnv+ let (u', ann) = M.findWithDefault (error "Internal error? unfound constructor") (u, flipStackType ty) cSt+ ann' = swap <$> ann+ pure $ PatternCons ann' (Name t u' ann')++renameCase :: (Pattern (StackType ()) (StackType ()), [Atom (StackType ()) (StackType ())]) -> MonoM (Pattern (ConsAnn MonoStackType) (StackType ()), [Atom (ConsAnn MonoStackType) (StackType ())])+renameCase (p, as) = (,) <$> renamePattern p <*> traverse renameAtom as++renameAtom :: Atom (StackType ()) (StackType ()) -> MonoM (Atom (ConsAnn MonoStackType) (StackType ()))+renameAtom (AtBuiltin ty b) = pure $ AtBuiltin ty b+renameAtom (If ty as as') = If ty <$> traverse renameAtom as <*> traverse renameAtom as'+renameAtom (IntLit ty i) = pure $ IntLit ty i+renameAtom (Int8Lit ty i) = pure $ Int8Lit ty i+renameAtom (WordLit ty w) = pure $ WordLit ty w+renameAtom (BoolLit ty b) = pure $ BoolLit ty b+renameAtom (Dip ty as) = Dip ty <$> traverse renameAtom as+renameAtom (AtName ty (Name t u l)) = do+ mSt <- gets fnEnv+ let u' = M.findWithDefault u (u, ty) mSt+ pure $ AtName ty (Name t u' l)+renameAtom (Case ty ls) = Case ty <$> traverse renameCase ls+renameAtom (AtCons ty (Name t u _)) = do+ cSt <- gets consEnv+ let (u', ann) = M.findWithDefault (error "Internal error? unfound constructor") (u, ty) cSt+ pure $ AtCons ann (Name t u' ann)++renameDecl :: KempeDecl () (StackType ()) (StackType ()) -> MonoM (KempeDecl () (ConsAnn MonoStackType) (StackType ()))+renameDecl (FunDecl l n is os as) = FunDecl l n is os <$> traverse renameAtom as+renameDecl (Export ty abi (Name t u l)) = do+ mSt <- gets fnEnv+ let u' = M.findWithDefault (error "Shouldn't happen; might be user error or internal error") (u, ty) mSt+ pure $ Export ty abi (Name t u' l)+renameDecl (ExtFnDecl l n tys tys' b) = pure $ ExtFnDecl l n tys tys' b+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 = renameMonoM <=< closedModule++-- | To be called after 'closedModule'+renameMonoM :: Module () (StackType ()) (StackType ()) -> MonoM (Module () (ConsAnn MonoStackType) (StackType ()))+renameMonoM = traverse renameDecl++-- | Filter so that only the 'KempeDecl's necessary for exports are there, and+-- fan out top-level functions into all necessary specializations.+--+-- 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 m = addExports <$> do+ { fn' <- traverse (uncurry specializeDecl . drop1) fnDecls+ ; traverse_ insTyDecl $ nubOrd (snd3 <$> tyDecls)+ ; ty' <- specializeTyDecls tyDecls+ ; pure (ty' ++ fn')+ }+ where addExports = (++ exportsOnly m)+ key = mkModuleMap m+ roots = S.toList $ closure (m, key)+ gatherDecl (n@(Name _ (Unique i) _), ty) = -- TODO: findWithDefault?+ case IM.lookup i key of+ Just decl -> (n, decl, ty)+ Nothing -> error "Internal error! module map should contain all names."+ rootDecl = gatherDecl <$> roots -- FIXME: two-steps away, the roots are not monomorphized! So it tries to create specialized declarations of type a b -- a b a &c.+ drop1 ~(_, y, z) = (y, z)+ (tyDecls, fnDecls) = partition (isTyDecl . snd3) rootDecl+ isTyDecl TyDecl{} = True+ isTyDecl _ = False++-- group specializations by type name?+specializeTyDecls :: [(TyName (StackType ()), KempeDecl () (StackType ()) (StackType ()), StackType ())] -> MonoM [KempeDecl () (StackType ()) (StackType ())]+specializeTyDecls ds = traverse (uncurry mkTyDecl) processed+ where toMerge = groupBy ((==) `on` snd3) ds+ processed = fmap process toMerge+ process tyDs@((_, x, _):_) = (x, zip (fst3 <$> tyDs) (thd3 <$> tyDs))+ process [] = error "Empty group!"++isTyVar :: KempeTy a -> Bool+isTyVar TyVar{} = True+isTyVar _ = False++sizeLeaf :: [KempeTy a] -> MonoM Int64+sizeLeaf tys =+ sizeStack <$> gets szEnv <*> pure (filter (not . isTyVar) 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+ modifying szEnvLens (IM.insert k consSz)+insTyDecl _ = error "Shouldn't happen."++mkTyDecl :: KempeDecl () (StackType ()) (StackType ()) -> [(TyName (StackType ()), StackType ())] -> MonoM (KempeDecl () (StackType ()) (StackType ()))+mkTyDecl (TyDecl _ tn ns preConstrs) constrs = do+ env <- gets szEnv+ renCons <- traverse (\(tn', ty) -> do { ty'@(is, _) <- tryMono ty ; (, is) <$> renamedCons (tn' $> ty') ty' (ConsAnn (szType env ty') (getTag tn')) }) constrs+ pure $ TyDecl () tn ns renCons+ 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 _ _ = error "Internal error: ill-typed constructor."+mkTyDecl _ _ = error "Shouldn't happen."++specializeDecl :: KempeDecl () (StackType ()) (StackType ()) -> StackType () -> MonoM (KempeDecl () (StackType ()) (StackType ()))+specializeDecl (FunDecl _ n _ _ as) sty = do+ (Name t u newStackType@(StackType _ is os)) <- renamed n =<< tryMono sty+ pure $ FunDecl newStackType (Name t u newStackType) is os as+specializeDecl (ExtFnDecl l n tys tys' b) _ = pure $ ExtFnDecl l n tys tys' b+specializeDecl (Export l abi n) _ = pure $ Export l abi n+specializeDecl TyDecl{} _ = error "Shouldn't happen."+-- leave exports and foreign imports alone (have to be monomorphic)++renamedCons :: TyName a -> MonoStackType -> (MonoStackType -> ConsAnn MonoStackType) -> MonoM (TyName (StackType ()))+renamedCons (Name t i _) sty@(is, os) fAnn = do+ let t' = t <> squishMonoStackType sty+ (Name _ j _) <- freshName t' sty+ let newStackType = StackType S.empty is os+ ann = fAnn sty+ modifying consEnvLens (M.insert (i, newStackType) (j, ann))+ pure (Name t' j newStackType)++-- | Insert a specialized rename.+renamed :: Name a -> MonoStackType -> MonoM (Name (StackType ()))+renamed (Name t i _) sty@(is, os) = do+ let t' = t <> squishMonoStackType sty+ (Name _ j _) <- freshName t' sty+ let newStackType = StackType S.empty is os+ 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 (m, key) = loop roots S.empty+ where roots = S.fromList (exports m)+ loop ns avoid =+ let res = foldMap (step . fst) (ns S.\\ avoid)+ in if res == ns+ then res+ else ns <> loop res (ns <> avoid)+ step (Name _ (Unique i) _) =+ case IM.lookup i key of+ Just decl -> namesInDecl decl+ Nothing -> error "Internal error! module map should contain all names."++namesInDecl :: Ord b => KempeDecl a b b -> S.Set (Name b, b)+namesInDecl TyDecl{} = S.empty+namesInDecl ExtFnDecl{} = S.empty+namesInDecl Export{} = S.empty+namesInDecl (FunDecl _ _ _ _ as) = foldMap namesInAtom as++namesInAtom :: Ord a => Atom a a -> S.Set (Name a, a)+namesInAtom AtBuiltin{} = S.empty+namesInAtom (If _ as as') = foldMap namesInAtom as <> foldMap namesInAtom as'+namesInAtom (Dip _ as) = foldMap namesInAtom as+namesInAtom (AtName _ n@(Name _ _ l)) = S.singleton (n, l)+namesInAtom (AtCons _ tn@(Name _ _ l)) = S.singleton (tn, l)+namesInAtom IntLit{} = S.empty+namesInAtom BoolLit{} = S.empty+namesInAtom Int8Lit{} = S.empty+namesInAtom WordLit{} = S.empty+namesInAtom (Case _ as) = foldMap namesInAtom (foldMap snd as) -- FIXME: patterns too++exports :: Module a c b -> [(Name b, b)]+exports = mapMaybe exportsDecl++exportsOnly :: Module a c b -> Module a c b+exportsOnly = mapMaybe getExport where+ getExport d@Export{} = Just d+ getExport _ = Nothing++exportsDecl :: KempeDecl a c b -> Maybe (Name b, b)+exportsDecl (Export _ _ n@(Name _ _ l)) = Just (n, l)+exportsDecl _ = Nothing
+ src/Kempe/Name.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Name ( Name (..)+ , TyName+ ) where++import Control.DeepSeq (NFData (..))+import qualified Data.Text as T+import Kempe.Unique+import Prettyprinter (Pretty (pretty))++data Name a = Name { name :: T.Text+ , unique :: !Unique+ , loc :: a+ } deriving (Functor, Foldable, Traversable)++instance Eq (Name a) where+ (==) (Name _ u _) (Name _ u' _) = u == u'++instance Pretty (Name a) where+ pretty (Name t u _) = pretty t <> "_" <> pretty u++instance Ord (Name a) where+ compare (Name _ u _) (Name _ u' _) = compare u u'++instance NFData a => NFData (Name a) where+ rnf (Name _ u x) = rnf x `seq` u `seq` ()++type TyName = Name
+ src/Kempe/Parser.y view
@@ -0,0 +1,254 @@+{+ {-# LANGUAGE DeriveAnyClass #-}+ {-# LANGUAGE DeriveGeneric #-}+ {-# LANGUAGE OverloadedStrings #-}+ module Kempe.Parser ( parse+ , parseWithMax+ , ParseError (..)+ ) where++import Control.Composition ((.*))+import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad.Except (ExceptT, runExceptT, throwError)+import Control.Monad.Trans.Class (lift)+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as BSL+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Kempe.AST+import Kempe.Lexer+import qualified Kempe.Name as Name+import Kempe.Name hiding (loc)+import Prettyprinter (Pretty (pretty), (<+>))++}++%name parseModule Module+%tokentype { Token AlexPosn }+%error { parseError }+%monad { Parse } { (>>=) } { pure }+%lexer { lift alexMonadScan >>= } { EOF _ }++%token++ arrow { TokSym $$ Arrow }+ defEq { TokSym $$ DefEq }+ colon { TokSym $$ Colon }+ lbrace { TokSym $$ LBrace }+ rbrace { TokSym $$ RBrace }+ lsqbracket { TokSym $$ LSqBracket }+ rsqbracket { TokSym $$ RSqBracket }+ lparen { TokSym $$ LParen }+ rparen { TokSym $$ RParen }+ vbar { TokSym $$ VBar }+ caseArr { TokSym $$ CaseArr }+ comma { TokSym $$ Comma }+ underscore { TokSym $$ Underscore }++ plus { TokSym $$ Plus }+ plusU { TokSym $$ PlusU }+ minus { TokSym $$ Minus }+ times { TokSym $$ Times }+ timesU { TokSym $$ TimesU }+ div { TokSym $$ Div }+ percent { TokSym $$ Percent }+ eq { TokSym $$ Eq }+ neq { TokSym $$ Neq }+ leq { TokSym $$ Leq }+ lt { TokSym $$ Lt }+ geq { TokSym $$ Geq }+ gt { TokSym $$ Gt }+ shiftrU { TokSym $$ ShiftRU }+ shiftlU { TokSym $$ ShiftLU }+ shiftr { TokSym $$ ShiftR }+ shiftl { TokSym $$ ShiftL }+ neg { TokSym $$ NegTok }+ and { TokSym $$ AndTok }+ or { TokSym $$ OrTok }++ name { TokName _ $$ }+ tyName { TokTyName _ $$ }+ foreignName { TokForeign _ $$ }++ intLit { $$@(TokInt _ _) }+ wordLit { $$@(TokWord _ _) }+ int8Lit { $$@(TokInt8 _ _) }++ type { TokKeyword $$ KwType }+ case { TokKeyword $$ KwCase }+ cfun { TokKeyword $$ KwCfun }+ if { TokKeyword $$ KwIf }+ foreign { TokKeyword $$ KwForeign }+ cabi { TokKeyword $$ KwCabi }+ kabi { TokKeyword $$ KwKabi }++ dip { TokBuiltin $$ BuiltinDip }+ boolLit { $$@(TokBuiltin _ (BuiltinBoolLit _)) }+ bool { TokBuiltin $$ BuiltinBool }+ int { TokBuiltin $$ BuiltinInt }+ int8 { TokBuiltin $$ BuiltinInt8 }+ word { TokBuiltin $$ BuiltinWord }+ dup { TokBuiltin $$ BuiltinDup }+ swap { TokBuiltin $$ BuiltinSwap }+ drop { TokBuiltin $$ BuiltinDrop }+ intXor { TokBuiltin $$ BuiltinIntXor }+ wordXor { TokBuiltin $$ BuiltinWordXor }+ boolXor { TokBuiltin $$ BuiltinBoolXor }+ popcount { TokBuiltin $$ BuiltinPopcount }++%%++many(p)+ : many(p) p { $2 : $1 }+ | { [] }++some(p)+ : many(p) p { $2 :| $1 }++sepBy(p,q)+ : sepBy(p,q) q p { $3 : $1 }+ | p q p { $3 : [$1] }++braces(p)+ : lbrace p rbrace { $2 }++brackets(p)+ : lsqbracket p rsqbracket { $2 }++parens(p)+ : lparen p rparen { $2 }++Module :: { Module AlexPosn AlexPosn AlexPosn }+ : many(Decl) { (reverse $1) }++ABI :: { ABI }+ : cabi { Cabi }+ | kabi { Kabi }++Decl :: { KempeDecl AlexPosn AlexPosn AlexPosn }+ : TyDecl { $1 }+ | FunDecl { $1 }+ | foreign ABI name { Export $1 $2 $3 }++TyDecl :: { KempeDecl AlexPosn AlexPosn AlexPosn }+ : type tyName many(name) braces(sepBy(TyLeaf, vbar)) { TyDecl $1 $2 (reverse $3) (reverse $4) }+ | type tyName many(name) braces(TyLeaf) { TyDecl $1 $2 (reverse $3) [$4] }+ | type tyName many(name) lbrace rbrace { TyDecl $1 $2 (reverse $3) [] } -- necessary since sepBy always has some "flesh"++Type :: { KempeTy AlexPosn }+ : name { TyVar (Name.loc $1) $1 }+ | tyName { TyNamed (Name.loc $1) $1 }+ | bool { TyBuiltin $1 TyBool }+ | int { TyBuiltin $1 TyInt }+ | int8 { TyBuiltin $1 TyInt8 }+ | word { TyBuiltin $1 TyWord }+ | lparen Type Type rparen { TyApp $1 $2 $3 }++FunDecl :: { KempeDecl AlexPosn AlexPosn AlexPosn }+ : FunSig FunBody { uncurry4 FunDecl $1 $2 }+ | FunSig defEq cfun foreignName { uncurry4 ExtFnDecl $1 $4 }+++FunSig :: { (AlexPosn, Name AlexPosn, [KempeTy AlexPosn], [KempeTy AlexPosn]) }+ : name colon many(Type) arrow many(Type) { ($2, $1, reverse $3, reverse $5) }++FunBody :: { [Atom AlexPosn AlexPosn] }+ : defEq brackets(many(Atom)) { reverse $2 }++Atom :: { Atom AlexPosn AlexPosn }+ : name { AtName (Name.loc $1) $1 }+ | tyName { AtCons (Name.loc $1) $1 }+ | lbrace case some(CaseLeaf) rbrace { Case $2 (NE.reverse $3) }+ | intLit { IntLit (loc $1) (int $1) }+ | wordLit { WordLit (loc $1) (word $1) }+ | int8Lit { Int8Lit (loc $1) (int8 $1) }+ | dip parens(many(Atom)) { Dip $1 (reverse $2) }+ | if lparen many(Atom) comma many(Atom) rparen { If $1 (reverse $3) (reverse $5) }+ | boolLit { BoolLit (loc $1) (bool $ builtin $1) }+ | dup { AtBuiltin $1 Dup }+ | drop { AtBuiltin $1 Drop }+ | swap { AtBuiltin $1 Swap }+ | plus { AtBuiltin $1 IntPlus }+ | plusU { AtBuiltin $1 WordPlus }+ | minus { AtBuiltin $1 IntMinus }+ | times { AtBuiltin $1 IntTimes }+ | timesU { AtBuiltin $1 WordTimes }+ | div { AtBuiltin $1 IntDiv }+ | percent { AtBuiltin $1 IntMod }+ | eq { AtBuiltin $1 IntEq }+ | neq { AtBuiltin $1 IntNeq }+ | leq { AtBuiltin $1 IntLeq }+ | lt { AtBuiltin $1 IntLt }+ | geq { AtBuiltin $1 IntGeq }+ | gt { AtBuiltin $1 IntGt }+ | and { AtBuiltin $1 And }+ | or { AtBuiltin $1 Or }+ | neg { AtBuiltin $1 IntNeg }+ | shiftl { AtBuiltin $1 IntShiftL }+ | shiftr { AtBuiltin $1 IntShiftR }+ | shiftlU { AtBuiltin $1 WordShiftL }+ | shiftrU { AtBuiltin $1 WordShiftR }+ | intXor { AtBuiltin $1 IntXor }+ | wordXor { AtBuiltin $1 WordXor }+ | boolXor { AtBuiltin $1 Xor }+ | popcount { AtBuiltin $1 Popcount }++CaseLeaf :: { (Pattern AlexPosn AlexPosn, [Atom AlexPosn AlexPosn]) }+ : vbar Pattern caseArr many(Atom) { ($2, reverse $4) }++Pattern :: { Pattern AlexPosn AlexPosn }+ : tyName { PatternCons (Name.loc $1) $1 }+ | underscore { PatternWildcard $1 }+ | intLit { PatternInt (loc $1) (int $1) }+ | boolLit { PatternBool (loc $1) (bool $ builtin $1) }++TyLeaf :: { (Name AlexPosn, [KempeTy AlexPosn]) }+ : tyName many(Type) { ($1, reverse $2) }++{++parseError :: Token AlexPosn -> Parse a+parseError = throwError . Unexpected++data ParseError a = Unexpected (Token a)+ | LexErr String+ | NoImpl (Name a)+ deriving (Generic, NFData)++instance Pretty a => Pretty (ParseError a) where+ pretty (Unexpected tok) = pretty (loc tok) <+> "Unexpected" <+> pretty tok+ pretty (LexErr str) = pretty (T.pack str)+ pretty (NoImpl n) = pretty (Name.loc n) <+> "Signature for" <+> pretty n <+> "is not accompanied by an implementation"++instance Pretty a => Show (ParseError a) where+ show = show . pretty++instance (Pretty a, Typeable a) => Exception (ParseError a)++type Parse = ExceptT (ParseError AlexPosn) Alex++parse :: BSL.ByteString -> Either (ParseError AlexPosn) (Module AlexPosn AlexPosn AlexPosn)+parse = fmap snd . parseWithMax++parseWithMax :: BSL.ByteString -> Either (ParseError AlexPosn) (Int, Module AlexPosn AlexPosn AlexPosn)+parseWithMax = fmap (first fst3) . runParse parseModule++runParse :: Parse a -> BSL.ByteString -> Either (ParseError AlexPosn) (AlexUserState, a)+runParse parser str = liftErr $ runAlexSt str (runExceptT parser)++liftErr :: Either String (b, Either (ParseError a) c) -> Either (ParseError a) (b, c)+liftErr (Left err) = Left (LexErr err)+liftErr (Right (_, Left err)) = Left err+liftErr (Right (i, Right x)) = Right (i, x)++uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f ~(x, y, z, w) = f x y z w++fst3 :: (a, b, c) -> a+fst3 ~(x,_,_) = x++}
+ src/Kempe/Pipeline.hs view
@@ -0,0 +1,29 @@+module Kempe.Pipeline ( irGen+ , x86Parsed+ , x86Alloc+ ) where++import Control.Composition ((.*))+import Control.Exception (throw)+import Data.Bifunctor (first)+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.IR+import Kempe.IR.Opt+import Kempe.Shuttle++irGen :: Int -- ^ Thread uniques through+ -> Module 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+ adjEnv (x, y) = (x, y, env)++x86Parsed :: Int -> Module 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 = allocRegs . reconstruct . mkControlFlow .* x86Parsed
+ src/Kempe/Proc/Nasm.hs view
@@ -0,0 +1,21 @@+module Kempe.Proc.Nasm ( writeO+ ) where++import Data.Functor (void)+import Prettyprinter (Doc, defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderIO)+import System.IO (hFlush)+import System.IO.Temp (withSystemTempFile)+import System.Process (CreateProcess (..), StdStream (Inherit), proc, readCreateProcess)++-- | Assemble using @nasm@, output in some file.+writeO :: Doc ann+ -> FilePath+ -> Bool -- ^ Debug symbols?+ -> IO ()+writeO p fpO dbg = withSystemTempFile "kmp.S" $ \fp h -> do+ renderIO h (layoutPretty defaultLayoutOptions p)+ hFlush h+ let debugFlag = if dbg then ("-g":) else id+ -- -O1 is signed byte optimization but no multi-passes+ void $ readCreateProcess ((proc "nasm" (debugFlag [fp, "-f", "elf64", "-O1", "-o", fpO])) { std_err = Inherit }) ""
+ src/Kempe/Shuttle.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TupleSections #-}++module Kempe.Shuttle ( monomorphize+ ) where++import Data.Functor (void)+import Kempe.AST+import Kempe.Error+import Kempe.Inline+import Kempe.Monomorphize+import Kempe.TyAssign++inlineAssignFlatten :: Int+ -> Module a c b+ -> Either (Error ()) (Module () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv))+inlineAssignFlatten ctx m = do+ -- check before inlining otherwise users would get weird errors+ void $ runTypeM ctx (checkModule m)+ (mTy, i) <- runTypeM ctx (assignModule $ inline m)+ runMonoM i (flattenModule mTy)++monomorphize :: Int+ -> Module a c b+ -> Either (Error ()) (Module () (ConsAnn MonoStackType) MonoStackType, SizeEnv)+monomorphize ctx m = do+ (flat, (_, env)) <- inlineAssignFlatten ctx m+ let flatFn' = filter (not . isTyDecl) flat+ (, env) <$> traverse (traverse tryMono) flatFn'++isTyDecl :: KempeDecl a c b -> Bool+isTyDecl TyDecl{} = True+isTyDecl _ = False
+ src/Kempe/TyAssign.hs view
@@ -0,0 +1,552 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- | Constraint-based typing from the presentation in Pierce's book.+module Kempe.TyAssign ( TypeM+ , runTypeM+ , checkModule+ , assignModule+ ) where++import Control.Composition (thread, (.$))+import Control.Monad (foldM, replicateM, unless, when, zipWithM_)+import Control.Monad.Except (throwError)+import Control.Monad.State.Strict (StateT, get, gets, modify, put, runStateT)+import Data.Bifunctor (bimap, second)+import Data.Foldable (traverse_)+import Data.Functor (void, ($>))+import qualified Data.IntMap as IM+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Set as S+import qualified Data.Text as T+import Kempe.AST+import Kempe.Error+import Kempe.Name+import Kempe.Unique+import Lens.Micro (Lens', over)+import Lens.Micro.Mtl (modifying, (.=))+import Prettyprinter (Doc, Pretty (pretty), hardline, indent, vsep, (<+>))+import Prettyprinter.Ext++type TyEnv a = IM.IntMap (StackType a)++data TyState a = TyState { maxU :: Int -- ^ For renamer+ , tyEnv :: TyEnv a+ , kindEnv :: IM.IntMap Kind+ , renames :: IM.IntMap Int+ , constructorTypes :: IM.IntMap (StackType a)+ , constraints :: S.Set (KempeTy a, KempeTy a) -- Just need equality between simple types? (do have tyapp but yeah)+ }++(<#*>) :: Doc a -> Doc a -> Doc a+(<#*>) x y = x <> hardline <> indent 2 y++instance Pretty (TyState a) where+ pretty (TyState _ te _ r _ cs) =+ "type environment:" <#> vsep (prettyBound <$> IM.toList te)+ <#> "renames:" <#*> prettyDumpBinds r+ <#> "constraints:" <#> prettyConstraints cs++prettyConstraints :: S.Set (KempeTy a, KempeTy a) -> Doc ann+prettyConstraints cs = vsep (prettyEq <$> S.toList cs)++prettyBound :: (Int, StackType a) -> Doc b+prettyBound (i, e) = pretty i <+> "←" <#*> pretty e++prettyEq :: (KempeTy a, KempeTy a) -> Doc ann+prettyEq (ty, ty') = pretty ty <+> "≡" <+> pretty ty'++prettyDumpBinds :: Pretty b => IM.IntMap b -> Doc a+prettyDumpBinds b = vsep (prettyBind <$> IM.toList b)++prettyBind :: Pretty b => (Int, b) -> Doc a+prettyBind (i, j) = pretty i <+> "→" <+> pretty j++emptyStackType :: StackType a+emptyStackType = StackType mempty [] []++maxULens :: Lens' (TyState a) Int+maxULens f s = fmap (\x -> s { maxU = x }) (f (maxU s))++constructorTypesLens :: Lens' (TyState a) (IM.IntMap (StackType a))+constructorTypesLens f s = fmap (\x -> s { constructorTypes = x }) (f (constructorTypes s))++tyEnvLens :: Lens' (TyState a) (TyEnv a)+tyEnvLens f s = fmap (\x -> s { tyEnv = x }) (f (tyEnv s))++kindEnvLens :: Lens' (TyState a) (IM.IntMap Kind)+kindEnvLens f s = fmap (\x -> s { kindEnv = x }) (f (kindEnv s))++renamesLens :: Lens' (TyState a) (IM.IntMap Int)+renamesLens f s = fmap (\x -> s { renames = x }) (f (renames s))++constraintsLens :: Lens' (TyState a) (S.Set (KempeTy a, KempeTy a))+constraintsLens f s = fmap (\x -> s { constraints = x }) (f (constraints s))++dummyName :: T.Text -> TypeM () (Name ())+dummyName n = do+ pSt <- gets maxU+ Name n (Unique $ pSt + 1) ()+ <$ modifying maxULens (+1)++data Kind = Star+ | TyCons Kind Kind+ deriving (Eq)++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++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++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+ | 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'))++unifyM :: S.Set (KempeTy a, KempeTy a) -> TypeM () (IM.IntMap (KempeTy ()))+unifyM s =+ case {-# SCC "unify" #-} unify (S.toList s) of+ Right x -> pure x+ Left err -> throwError err++-- TODO: take constructor types as an argument?..+runTypeM :: Int -- ^ For renamer+ -> TypeM a x -> Either (Error a) (x, Int)+runTypeM maxInt = fmap (second maxU) .+ flip runStateT (TyState maxInt mempty mempty mempty mempty S.empty)++typeOfBuiltin :: BuiltinFn -> TypeM () (StackType ())+typeOfBuiltin Drop = do+ aN <- dummyName "a"+ pure $ StackType (S.singleton aN) [TyVar () aN] []+typeOfBuiltin Swap = do+ aN <- dummyName "a"+ bN <- dummyName "b"+ pure $ StackType (S.fromList [aN, bN]) [TyVar () aN, TyVar () bN] [TyVar () bN, TyVar () aN]+typeOfBuiltin Dup = do+ aN <- dummyName "a"+ pure $ StackType (S.singleton aN) [TyVar () aN] [TyVar () aN, TyVar () aN]+typeOfBuiltin IntEq = pure intRel+typeOfBuiltin IntLeq = pure intRel+typeOfBuiltin IntLt = pure intRel+typeOfBuiltin IntMod = pure intBinOp+typeOfBuiltin IntDiv = pure intBinOp+typeOfBuiltin IntPlus = pure intBinOp+typeOfBuiltin IntTimes = pure intBinOp+typeOfBuiltin IntMinus = pure intBinOp+typeOfBuiltin IntShiftR = pure intShift+typeOfBuiltin IntShiftL = pure intBinOp+typeOfBuiltin IntXor = pure intBinOp+typeOfBuiltin WordXor = pure wordBinOp+typeOfBuiltin WordPlus = pure wordBinOp+typeOfBuiltin WordTimes = pure wordBinOp+typeOfBuiltin WordShiftR = pure wordShift+typeOfBuiltin WordShiftL = pure wordShift+typeOfBuiltin IntGeq = pure intBinOp+typeOfBuiltin IntNeq = pure intBinOp+typeOfBuiltin IntGt = pure intBinOp+typeOfBuiltin WordMinus = pure wordBinOp+typeOfBuiltin WordDiv = pure wordBinOp+typeOfBuiltin WordMod = pure wordBinOp+typeOfBuiltin And = pure boolOp+typeOfBuiltin Or = pure boolOp+typeOfBuiltin Xor = pure boolOp+typeOfBuiltin IntNeg = pure $ StackType S.empty [TyBuiltin () TyInt] [TyBuiltin () TyInt]+typeOfBuiltin Popcount = pure $ StackType S.empty [TyBuiltin () TyWord] [TyBuiltin () TyInt]++boolOp :: StackType ()+boolOp = StackType S.empty [TyBuiltin () TyBool, TyBuiltin () TyBool] [TyBuiltin () TyBool]++intRel :: StackType ()+intRel = StackType S.empty [TyBuiltin () TyInt, TyBuiltin () TyInt] [TyBuiltin () TyBool]++intBinOp :: StackType ()+intBinOp = StackType S.empty [TyBuiltin () TyInt, TyBuiltin () TyInt] [TyBuiltin () TyInt]++intShift :: StackType ()+intShift = StackType S.empty [TyBuiltin () TyInt, TyBuiltin () TyInt8] [TyBuiltin () TyInt]++wordBinOp :: StackType ()+wordBinOp = StackType S.empty [TyBuiltin () TyWord, TyBuiltin () TyWord] [TyBuiltin () TyWord]++wordShift :: StackType ()+wordShift = StackType S.empty [TyBuiltin () TyWord, TyBuiltin () TyInt8] [TyBuiltin () TyWord]++tyLookup :: Name a -> TypeM a (StackType a)+tyLookup n@(Name _ (Unique i) l) = do+ st <- gets tyEnv+ case IM.lookup i st of+ Just ty -> pure ty+ Nothing -> throwError $ PoorScope l n++consLookup :: TyName a -> TypeM a (StackType a)+consLookup tn@(Name _ (Unique i) l) = do+ st <- gets constructorTypes+ case IM.lookup i st of+ Just ty -> pure ty+ Nothing -> throwError $ PoorScope l tn++-- expandType 1+dipify :: StackType () -> TypeM () (StackType ())+dipify (StackType fvrs is os) = do+ n <- dummyName "a"+ pure $ StackType (S.insert n fvrs) (is ++ [TyVar () n]) (os ++ [TyVar () n])++tyLeaf :: (Pattern b a, [Atom b a]) -> TypeM () (StackType ())+tyLeaf (p, as) = do+ tyP <- tyPattern p+ tyA <- tyAtoms as+ catTypes tyP tyA++assignCase :: (Pattern b a, [Atom b a]) -> TypeM () (StackType (), Pattern (StackType ()) (StackType ()), [Atom (StackType ()) (StackType ())])+assignCase (p, as) = do+ (tyP, p') <- assignPattern p+ (as', tyA) <- assignAtoms as+ (,,) <$> catTypes tyP tyA <*> pure p' <*> pure as'++tyAtom :: Atom b a -> TypeM () (StackType ())+tyAtom (AtBuiltin _ b) = typeOfBuiltin b+tyAtom BoolLit{} = pure $ StackType mempty [] [TyBuiltin () TyBool]+tyAtom IntLit{} = pure $ StackType mempty [] [TyBuiltin () TyInt]+tyAtom Int8Lit{} = pure $ StackType mempty [] [TyBuiltin () TyInt8 ]+tyAtom WordLit{} = pure $ StackType mempty [] [TyBuiltin () TyWord]+tyAtom (AtName _ n) = renameStack =<< tyLookup (void n)+tyAtom (Dip _ as) = dipify =<< tyAtoms as+tyAtom (AtCons _ tn) = renameStack =<< consLookup (void tn)+tyAtom (If _ as as') = do+ tys <- tyAtoms as+ tys' <- tyAtoms as'+ (StackType vars ins out) <- mergeStackTypes tys tys'+ pure $ StackType vars (ins ++ [TyBuiltin () TyBool]) out+tyAtom (Case _ ls) = do+ tyLs <- traverse tyLeaf ls+ -- TODO: one-pass fold?+ mergeMany tyLs++assignAtom :: Atom b a -> TypeM () (StackType (), Atom (StackType ()) (StackType ()))+assignAtom (AtBuiltin _ b) = do { ty <- typeOfBuiltin b ; pure (ty, AtBuiltin ty b) }+assignAtom (BoolLit _ b) =+ let sTy = StackType mempty [] [TyBuiltin () TyBool]+ in pure (sTy, BoolLit sTy b)+assignAtom (IntLit _ i) =+ let sTy = StackType mempty [] [TyBuiltin () TyInt]+ in pure (sTy, IntLit sTy i)+assignAtom (Int8Lit _ i) =+ let sTy = StackType mempty [] [TyBuiltin () TyInt8]+ in pure (sTy, Int8Lit sTy i)+assignAtom (WordLit _ u) =+ let sTy = StackType mempty [] [TyBuiltin () TyWord]+ in pure (sTy, WordLit sTy u)+assignAtom (AtName _ n) = do+ sTy <- renameStack =<< tyLookup (void n)+ pure (sTy, AtName sTy (n $> sTy))+assignAtom (AtCons _ tn) = do+ sTy <- renameStack =<< consLookup (void tn)+ pure (sTy, AtCons sTy (tn $> sTy))+assignAtom (Dip _ as) = do { (as', ty) <- assignAtoms as ; tyDipped <- dipify ty ; pure (tyDipped, Dip tyDipped as') }+assignAtom (If _ as0 as1) = do+ (as0', tys) <- assignAtoms as0+ (as1', tys') <- assignAtoms as1+ (StackType vars ins out) <- mergeStackTypes tys tys'+ let resType = StackType vars (ins ++ [TyBuiltin () TyBool]) out+ pure (resType, If resType as0' as1')+assignAtom (Case _ ls) = do+ lRes <- traverse assignCase ls+ resType <- mergeMany (fst3 <$> lRes)+ let newLeaves = fmap dropFst lRes+ pure (resType, Case resType newLeaves)+ where dropFst (_, y, z) = (y, z)+ fst3 ~(x, _, _) = x++assignAtoms :: [Atom b a] -> TypeM () ([Atom (StackType ()) (StackType ())], StackType ())+assignAtoms = foldM+ (\seed a -> do { (ty, r) <- assignAtom a ; (fst seed ++ [r] ,) <$> catTypes (snd seed) ty })+ ([], emptyStackType)++tyAtoms :: [Atom b a] -> TypeM () (StackType ())+tyAtoms = foldM+ (\seed a -> do { tys' <- tyAtom a ; catTypes seed tys' })+ emptyStackType++-- from size,+mkHKT :: Int -> Kind+mkHKT 0 = Star+mkHKT i = TyCons (mkHKT i) Star++tyInsertLeaf :: Name b -- ^ type being declared+ -> S.Set (Name b) -> (TyName a, [KempeTy b]) -> TypeM () ()+tyInsertLeaf n@(Name _ (Unique k) _) vars (Name _ (Unique i) _, ins) | S.null vars =+ modifying constructorTypesLens (IM.insert i (voidStackType $ StackType vars ins [TyNamed undefined n])) *>+ modifying kindEnvLens (IM.insert k Star)+ | otherwise =+ modifying constructorTypesLens (IM.insert i (voidStackType $ StackType vars ins [app (TyNamed undefined n) (S.toList vars)])) *>+ modifying kindEnvLens (IM.insert k (mkHKT $ S.size vars))++assignTyLeaf :: Name b+ -> S.Set (Name b)+ -> (TyName a, [KempeTy b])+ -> TypeM () (TyName (StackType ()), [KempeTy ()])+assignTyLeaf n@(Name _ (Unique k) _) vars (tn@(Name _ (Unique i) _), ins) | S.null vars =+ let ty = voidStackType $ StackType vars ins [TyNamed undefined n] in+ modifying constructorTypesLens (IM.insert i ty) *>+ modifying kindEnvLens (IM.insert k Star) $>+ (tn $> ty, fmap void ins)+ | otherwise =+ let ty = voidStackType $ StackType vars ins [app (TyNamed undefined n) (S.toList vars)] in+ modifying constructorTypesLens (IM.insert i ty) *>+ modifying kindEnvLens (IM.insert k (mkHKT $ S.size vars)) $>+ (tn $> ty, fmap void ins)++app :: KempeTy a -> [Name a] -> KempeTy a+app = foldr (\n ty -> TyApp undefined ty (TyVar undefined n))++kindLookup :: TyName a -> TypeM a Kind+kindLookup n@(Name _ (Unique i) l) = do+ st <- gets kindEnv+ case IM.lookup i st of+ Just k -> pure k+ Nothing -> throwError $ PoorScope l n++kindOf :: KempeTy a -> TypeM a Kind+kindOf TyBuiltin{} = pure Star+kindOf (TyNamed _ tn) = kindLookup tn+kindOf TyVar{} = pure Star+kindOf tyErr@(TyApp l ty ty') = do+ k <- kindOf ty+ k' <- kindOf ty'+ case k of+ TyCons k'' k''' -> unless (k' == k''') (throwError (IllKinded l tyErr)) $> k''+ _ -> throwError (IllKinded l tyErr)++assignDecl :: KempeDecl a c b -> TypeM () (KempeDecl () (StackType ()) (StackType ()))+assignDecl (TyDecl _ tn ns ls) = TyDecl () (void tn) (void <$> ns) <$> traverse (assignTyLeaf tn (S.fromList ns)) ls+assignDecl (FunDecl _ n ins os a) = do+ traverse_ kindOf (void <$> ins ++ os)+ sig <- renameStack $ voidStackType $ StackType (freeVars (ins ++ os)) ins os+ (as, inferred) <- assignAtoms a+ reconcile <- mergeStackTypes sig inferred+ -- assign comes after tyInsert+ pure $ FunDecl reconcile (n $> reconcile) (void <$> ins) (void <$> os) as+assignDecl (ExtFnDecl _ n ins os cn) = do+ traverse_ kindOf (void <$> ins ++ os)+ unless (length os <= 1) $+ throwError $ InvalidCImport () (void n)+ let sig = voidStackType $ StackType S.empty ins os+ -- assign always comes after tyInsert+ pure $ ExtFnDecl sig (n $> sig) (void <$> ins) (void <$> os) cn+assignDecl (Export _ abi n) = do+ ty@(StackType _ _ os) <- tyLookup (void n)+ unless (abi == Kabi || length os <= 1) $+ throwError $ InvalidCExport () (void n)+ Export ty abi <$> assignName n++-- don't need to rename cuz it's only for exports (in theory)+assignName :: Name a -> TypeM () (Name (StackType ()))+assignName n = do { ty <- tyLookup (void n) ; pure (n $> ty) }++tyHeader :: KempeDecl a c b -> TypeM () ()+tyHeader Export{} = pure ()+tyHeader (FunDecl _ (Name _ (Unique i) _) ins out _) = do+ let sig = voidStackType $ StackType (freeVars (ins ++ out)) ins out+ modifying tyEnvLens (IM.insert i sig)+tyHeader (ExtFnDecl _ n@(Name _ (Unique i) _) ins os _) = do+ unless (length os <= 1) $+ throwError $ InvalidCImport () (void n)+ unless (null $ freeVars (ins ++ os)) $+ throwError $ TyVarExt () (void n)+ let sig = voidStackType $ StackType S.empty ins os -- no free variables allowed in c functions+ modifying tyEnvLens (IM.insert i sig)+tyHeader TyDecl{} = pure ()++lessGeneral :: StackType a -> StackType a -> Bool+lessGeneral (StackType _ is os) (StackType _ is' os') = lessGenerals (is ++ os) (is' ++ os')+ where lessGeneralAtom :: KempeTy a -> KempeTy a -> Bool+ lessGeneralAtom TyBuiltin{} TyVar{} = True+ lessGeneralAtom TyApp{} TyVar{} = True+ lessGeneralAtom (TyApp _ ty ty') (TyApp _ ty'' ty''') = lessGeneralAtom ty ty'' || lessGeneralAtom ty' ty''' -- lazy pattern match?+ lessGeneralAtom _ _ = False+ lessGenerals :: [KempeTy a] -> [KempeTy a] -> Bool+ lessGenerals [] [] = False+ lessGenerals (ty:tys) (ty':tys') = lessGeneralAtom ty ty' || lessGenerals tys tys'+ lessGenerals _ [] = False -- shouldn't happen; will be caught later+ lessGenerals [] _ = False++tyInsert :: KempeDecl a c b -> TypeM () ()+tyInsert (TyDecl _ tn ns ls) = traverse_ (tyInsertLeaf tn (S.fromList ns)) ls+tyInsert (FunDecl _ _ ins out as) = do+ traverse_ kindOf (void <$> ins ++ out) -- FIXME: this gives sketchy results?+ sig <- renameStack $ voidStackType $ StackType (freeVars (ins ++ out)) ins out+ inferred <- tyAtoms as+ _ <- mergeStackTypes sig inferred -- FIXME: need to verify the merged type is as general as the signature?+ when (inferred `lessGeneral` sig) $+ throwError $ LessGeneral () sig inferred+tyInsert ExtFnDecl{} = pure () -- TODO: kind-check+tyInsert Export{} = pure ()++tyModule :: Module a c b -> TypeM () ()+tyModule m = traverse_ tyHeader m *> traverse_ tyInsert m++checkModule :: Module a c b -> TypeM () ()+checkModule m = tyModule m <* (unifyM =<< gets constraints)++assignModule :: Module a c b -> TypeM () (Module () (StackType ()) (StackType ()))+assignModule m = {-# SCC "assignModule" #-} do+ traverse_ tyHeader m+ m' <- traverse assignDecl m+ backNames <- unifyM =<< gets constraints+ pure (fmap (bimap .$ substConstraintsStack backNames) m')++-- Make sure you don't have cycles in the renames map!+replaceUnique :: Unique -> TypeM a Unique+replaceUnique u@(Unique i) = do+ rSt <- gets renames+ case IM.lookup i rSt of+ Nothing -> pure u+ Just j -> replaceUnique (Unique j)++renameIn :: KempeTy a -> TypeM a (KempeTy a)+renameIn b@TyBuiltin{} = pure b+renameIn n@TyNamed{} = pure n+renameIn (TyApp l ty ty') = TyApp l <$> renameIn ty <*> renameIn ty'+renameIn (TyVar l (Name t u l')) = do+ u' <- replaceUnique u+ pure $ TyVar l (Name t u' l')++-- has to use the max-iest maximum so we can't use withState+withTyState :: (TyState a -> TyState a) -> TypeM a x -> TypeM a x+withTyState modSt act = do+ preSt <- get+ modify modSt+ res <- act+ postMax <- gets maxU+ put preSt+ maxULens .= postMax+ pure res++withName :: Name a -> TypeM a (Name a, TyState a -> TyState a)+withName (Name t (Unique i) l) = do+ m <- gets maxU+ let newUniq = m+1+ maxULens .= newUniq+ pure (Name t (Unique newUniq) l, over renamesLens (IM.insert i (m+1)))++-- freshen the names in a stack so there aren't overlaps in quanitified variables+renameStack :: StackType a -> TypeM a (StackType a)+renameStack (StackType qs ins outs) = do+ newQs <- traverse withName (S.toList qs)+ let (newNames, localRenames) = unzip newQs+ newBinds = thread localRenames+ withTyState newBinds $+ StackType (S.fromList newNames) <$> traverse renameIn ins <*> traverse renameIn outs++mergeStackTypes :: StackType () -> StackType () -> TypeM () (StackType ())+mergeStackTypes st0@(StackType _ i0 o0) st1@(StackType _ i1 o1) = do+ let li0 = length i0+ li1 = length i1+ toExpand = max (abs (li0 - li1)) (abs (length o0 - length o1))++ (StackType q ins os) <- (if li0 < li1 then expandType toExpand else pure) st0+ (StackType q' ins' os') <- (if li1 < li0 then expandType toExpand else pure) st1++ when ((length ins /= length ins') || (length os /= length os')) $+ throwError $ MismatchedLengths () st0 st1++ zipWithM_ pushConstraint ins ins'+ zipWithM_ pushConstraint os os'++ pure $ StackType (q <> q') ins os++tyPattern :: Pattern b a -> TypeM () (StackType ())+tyPattern PatternWildcard{} = do+ aN <- dummyName "a"+ pure $ StackType (S.singleton aN) [TyVar () aN] []+tyPattern PatternInt{} = pure $ StackType S.empty [TyBuiltin () TyInt] []+tyPattern PatternBool{} = pure $ StackType S.empty [TyBuiltin () TyBool] []+tyPattern (PatternCons _ tn) = renameStack =<< (flipStackType <$> consLookup (void tn))++assignPattern :: Pattern b a -> TypeM () (StackType (), Pattern (StackType ()) (StackType ()))+assignPattern (PatternInt _ i) =+ let sTy = StackType S.empty [TyBuiltin () TyInt] []+ in pure (sTy, PatternInt sTy i)+assignPattern (PatternBool _ i) =+ let sTy = StackType S.empty [TyBuiltin () TyBool] []+ in pure (sTy, PatternBool sTy i)+assignPattern (PatternCons _ tn) = do { ty <- renameStack =<< (flipStackType <$> consLookup (void tn)) ; pure (ty, PatternCons ty (tn $> ty)) }+assignPattern PatternWildcard{} = do+ aN <- dummyName "a"+ let resType = StackType (S.singleton aN) [TyVar () aN] []+ pure (resType, PatternWildcard resType)++mergeMany :: NonEmpty (StackType ()) -> TypeM () (StackType ())+mergeMany (t :| ts) = foldM mergeStackTypes t ts++-- assumes they have been renamed...+pushConstraint :: Ord a => KempeTy a -> KempeTy a -> TypeM a ()+pushConstraint ty ty' =+ modifying constraintsLens (S.insert (ty, ty'))++expandType :: Int -> StackType () -> TypeM () (StackType ())+expandType n (StackType q i o) = do+ newVars <- replicateM n (dummyName "a")+ let newTy = TyVar () <$> newVars+ pure $ StackType (q <> S.fromList newVars) (newTy ++ i) (newTy ++ o)++substConstraints :: IM.IntMap (KempeTy a) -> KempeTy a -> KempeTy a+substConstraints _ ty@TyNamed{} = ty+substConstraints _ ty@TyBuiltin{} = ty+substConstraints tys ty@(TyVar _ (Name _ (Unique k) _)) =+ case IM.lookup k tys of+ Just ty'@TyVar{} -> substConstraints (IM.delete k tys) ty' -- TODO: this is to prevent cyclic lookups: is it right?+ Just ty' -> ty'+ Nothing -> ty+substConstraints tys (TyApp l ty ty') =+ TyApp l (substConstraints tys ty) (substConstraints tys ty')++substConstraintsStack :: IM.IntMap (KempeTy a) -> StackType a -> StackType a+substConstraintsStack tys (StackType _ is os) = {-# SCC "substConstraintsStack" #-}+ let is' = substConstraints tys <$> is+ os' = substConstraints tys <$> os+ in StackType (freeVars (is' ++ os')) is' os'++-- do renaming before this+-- | Given @x@ and @y@, return the 'StackType' of @x y@+catTypes :: StackType () -- ^ @x@+ -> StackType () -- ^ @y@+ -> TypeM () (StackType ())+catTypes st0@(StackType _ _ osX) (StackType q1 insY osY) = do+ let lY = length insY+ lDiff = lY - length osX++ -- all of the "ins" of y have to come from x, so we expand x as needed+ (StackType q0 insX osX') <- if lDiff > 0+ then expandType lDiff st0+ else pure st0++ -- zip the last (length insY) of osX' with insY+ zipWithM_ pushConstraint (drop (length osX' - lY) osX') insY -- TODO splitAt++ pure $ StackType (q0 <> q1) insX (take (length osX' - lY) osX' ++ osY)
+ src/Kempe/Unique.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Kempe.Unique ( Unique (..)+ ) where++import Prettyprinter (Pretty)++newtype Unique = Unique { unUnique :: Int }+ deriving (Eq, Ord, Pretty)
+ src/Prettyprinter/Ext.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}++module Prettyprinter.Ext ( (<#>)+ , prettyHex+ ) where++import Numeric (showHex)+import Prettyprinter++infixr 6 <#>++(<#>) :: Doc a -> Doc a -> Doc a+(<#>) x y = x <> hardline <> y++prettyHex :: (Integral a, Show a) => a -> Doc ann+prettyHex x = "0x" <> pretty (showHex x mempty)
+ test/Backend.hs view
@@ -0,0 +1,101 @@+module Backend ( backendTests+ ) where++import Control.DeepSeq (deepseq)+import Kempe.Asm.X86.ControlFlow+import Kempe.Asm.X86.Liveness+import Kempe.File+import Kempe.Inline+import Kempe.Monomorphize+import Kempe.Pipeline+import Kempe.Shuttle+import Prettyprinter (pretty)+import Test.Tasty+import Test.Tasty.HUnit+import Type++backendTests :: TestTree+backendTests =+ testGroup "Backend-ish"+ [ monoTest "test/data/ty.kmp"+ , inlineTest "lib/numbertheory.kmp"+ , inlineTest "examples/factorial.kmp"+ , pipelineWorks "test/data/ty.kmp"+ , pipelineWorks "examples/splitmix.kmp"+ , pipelineWorks "examples/factorial.kmp"+ , pipelineWorks "test/data/mutual.kmp"+ , irNoYeet "test/data/export.kmp"+ , irNoYeet "examples/splitmix.kmp"+ , irNoYeet "examples/factorial.kmp"+ , irNoYeet "test/data/maybeC.kmp"+ , x86NoYeet "examples/factorial.kmp"+ , x86NoYeet "examples/splitmix.kmp"+ , controlFlowGraph "examples/factorial.kmp"+ , controlFlowGraph "examples/splitmix.kmp"+ , liveness "examples/factorial.kmp"+ , liveness "examples/splitmix.kmp"+ , codegen "examples/factorial.kmp"+ , codegen "examples/splitmix.kmp"+ , codegen "lib/numbertheory.kmp"+ , codegen "test/examples/bool.kmp"+ , codegen "lib/gaussian.kmp"+ , codegen "test/data/ccall.kmp"+ , codegen "test/data/mutual.kmp"+ ]++codegen :: FilePath -> TestTree+codegen fp = testCase ("Generates code without throwing an exception (" ++ fp ++ ")") $ do+ parsed <- parsedFp 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+ 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+ 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+ 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+ let (res, _, _) = irGen i m+ assertBool "Worked without failure" (res `deepseq` True)++inlineTest :: FilePath -> TestTree+inlineTest fp = testCase ("Inlines " ++ fp ++ " without error") $ inlineFile fp++inlineFile :: FilePath -> Assertion+inlineFile fp = do+ (_, m) <- parsedFp fp+ let res = inline m+ assertBool "Doesn't bottom when inlining" (res `deepseq` True)++monoTest :: FilePath -> TestTree+monoTest fp = testCase ("Monomorphizes " ++ fp ++ " without error") $ monoFile fp++monoFile :: FilePath -> Assertion+monoFile fp = do+ (tyM, i) <- assignTypes fp+ let res = runMonoM i (flattenModule tyM)+ assertBool "Doesn't throw any exceptions" (res `deepseq` True)++pipelineWorks :: FilePath -> TestTree+pipelineWorks fp = testCase ("Functions in " ++ fp ++ " can be specialized") $ do+ (maxU, m) <- parsedFp fp+ let res = monomorphize maxU m+ case res of+ Left err -> assertFailure (show $ pretty err)+ Right{} -> assertBool "Doesn't fail type-checking" True
+ test/Golden.hs view
@@ -0,0 +1,14 @@+module Main (main) where++import Harness+import Test.Tasty++main :: IO ()+main = defaultMain $+ testGroup "Golden output tests"+ [ goldenOutput "examples/factorial.kmp" "test/harness/factorial.c" "test/golden/factorial.out"+ , goldenOutput "test/examples/splitmix.kmp" "test/harness/splitmix.c" "test/golden/splitmix.out"+ , goldenOutput "lib/numbertheory.kmp" "test/harness/numbertheory.c" "test/golden/numbertheory.out"+ , goldenOutput "test/examples/hamming.kmp" "test/harness/hamming.c" "test/golden/hamming.out"+ , goldenOutput "test/examples/bool.kmp" "test/harness/bool.c" "test/golden/bool.out"+ ]
+ test/Harness.hs view
@@ -0,0 +1,38 @@+module Harness ( goldenOutput+ ) where++import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as ASCII+import Data.Functor (void)+import Kempe.File+import System.FilePath ((</>))+import System.IO.Temp+import System.Process (CreateProcess (std_err), StdStream (Inherit), proc, readCreateProcess)+import Test.Tasty+import Test.Tasty.Golden (goldenVsString)++-- | Assemble using @nasm@, output in some file.+runGcc :: [FilePath]+ -> FilePath+ -> IO ()+runGcc fps o =+ void $ readCreateProcess ((proc "cc" (fps ++ ["-o", o])) { std_err = Inherit }) ""++compileOutput :: FilePath+ -> FilePath+ -> IO BSL.ByteString+compileOutput fp harness =+ withSystemTempDirectory "kmp" $ \dir -> do+ let oFile = dir </> "kempe.o"+ exe = dir </> "kempe"+ compile fp oFile False+ runGcc [oFile, harness] exe+ readExe exe+ where readExe fp' = ASCII.pack <$> readCreateProcess ((proc fp' []) { std_err = Inherit }) ""++goldenOutput :: FilePath -- ^ Kempe file+ -> FilePath -- ^ C test harness+ -> FilePath -- ^ Golden file path+ -> TestTree+goldenOutput kFp cFp golden =+ goldenVsString kFp golden (compileOutput kFp cFp)
+ test/Parser.hs view
@@ -0,0 +1,33 @@+module Parser ( parserTests+ ) where++import qualified Data.ByteString.Lazy as BSL+import Kempe.Lexer+import Kempe.Parser+import Prettyprinter (pretty)+import Test.Tasty+import Test.Tasty.HUnit++lexNoError :: FilePath -> TestTree+lexNoError fp = testCase ("Lexing doesn't fail (" ++ fp ++ ")") $ do+ contents <- BSL.readFile fp+ case lexKempe contents of+ Left err -> assertFailure err+ Right{} -> assertBool "Doesn't fail lexing" True++parseNoError :: FilePath -> TestTree+parseNoError fp = testCase ("Parsing doesn't fail (" ++ fp ++ ")") $ do+ contents <- BSL.readFile fp+ case parse contents of+ Left err -> assertFailure (show $ pretty err)+ Right{} -> assertBool "Doesn't fail parsing" True+++parserTests :: TestTree+parserTests =+ testGroup "Parser golden tests"+ [ lexNoError "test/data/lex.kmp"+ , lexNoError "examples/splitmix.kmp"+ , parseNoError "test/data/lex.kmp"+ , parseNoError "examples/splitmix.kmp"+ ]
+ test/Spec.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Backend+import Parser+import Test.Tasty+import Type++main :: IO ()+main = defaultMain $+ testGroup "Kempe compiler tests"+ [ parserTests+ , typeTests+ , backendTests+ ]
+ test/Type.hs view
@@ -0,0 +1,60 @@+module Type ( typeTests+ , assignTypes+ , yeetIO+ ) where++import Control.DeepSeq (deepseq)+import Control.Exception (Exception, throwIO)+import Kempe.AST+import Kempe.File+import Kempe.TyAssign+import Prettyprinter (pretty)+import Test.Tasty+import Test.Tasty.HUnit++typeTests :: TestTree+typeTests =+ testGroup "Type assignment"+ [ tyInfer "test/data/ty.kmp"+ , tyInfer "prelude/fn.kmp"+ , tyInfer "lib/maybe.kmp"+ , tyInfer "lib/either.kmp"+ , tyInfer "test/data/mutual.kmp"+ , tyInfer "examples/factorial.kmp"+ , tyInfer "lib/bool.kmp"+ , tyInfer "examples/hamming.kmp"+ , tyInfer "lib/gaussian.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."+ , testAssignment "test/data/ty.kmp"+ , testAssignment "lib/either.kmp"+ , testAssignment "prelude/fn.kmp"+ , testAssignment "test/data/mutual.kmp"+ ]++yeetIO :: Exception e => Either e a -> IO a+yeetIO = either throwIO pure++assignTypes :: FilePath -> IO (Module () (StackType ()) (StackType ()), Int)+assignTypes fp = do+ (maxU, m) <- parsedFp fp+ yeetIO $ runTypeM maxU (assignModule m)++testAssignment :: FilePath -> TestTree+testAssignment fp = testCase ("Annotates " ++ fp ++ " with types") $ do+ (m, i) <- assignTypes fp+ assertBool "Does not throw an exception" (m `deepseq` i `seq` True)++tyInfer :: FilePath -> TestTree+tyInfer fp = testCase ("Checks types (" ++ fp ++ ")") $ do+ res <- tcFile fp+ case res of+ Left err -> assertFailure (show $ pretty err)+ Right{} -> assertBool "Doesn't fail type-checking" True++badType :: FilePath -> String -> TestTree+badType fp msg = testCase ("Detects error (" ++ fp ++ ")") $ do+ res <- tcFile fp+ case res of+ Left err -> show (pretty err) @?= msg+ Right{} -> assertFailure "No error detected!"
+ test/data/ccall.kmp view
@@ -0,0 +1,7 @@+rand : -- Int+ =: $cfun"rand"++randTwice : -- Int Int+ =: [ rand rand ]++%foreign kabi randTwice
+ test/data/export.kmp view
@@ -0,0 +1,11 @@+even : Int -- Bool+ =: [ 2 % 0 = ]++rand : -- Int+ =: $cfun"rand"++randBool : -- Bool+ =: [ rand even ]++%foreign cabi even+%foreign cabi randBool
+ test/data/lex.kmp view
@@ -0,0 +1,63 @@+; this is a comment++type Void {}++type Maybe a { Just a | Nothing }++type OS { Macos | Linux | Windows | Freebsd }++; just has type a -- Maybe a+; nothing has type -- Maybe a++isUnix : OS -- Bool+ =: [+ { case+ | Windows -> False+ | _ -> True+ }+]++osNum : OS -- Int+ =: [+ { case+ | Macos -> 1+ | Linux -> 2+ | Windows -> 3+ | Freebsd -> 4+ }+]++not : Bool -- Bool+ =: [+ { case+ | True -> False+ | False -> True+ }+]++rand : -- Int+ =: $cfun"rand"++; all types are sized (monomorphized)+drop2 : a b --+ =: [ drop drop ]++drop3 : a b c --+ =: [ drop drop drop ]++trip : a -- a a a+ =: [ dup dup ]++push3 : -- OS OS OS+ =: [ Linux dup dup ]++aInt : a -- Int a+ =: [ dip(3) ]++randTwice : -- Int Int+ =: [ rand rand ]++odd : Int -- Bool+ =: [ 2 % 0 = ]++%foreign kabi randTwice
+ test/data/maybeC.kmp view
@@ -0,0 +1,7 @@+type Maybe a { Just a | Nothing }++noInt : -- (Maybe Int)+ =: [ Nothing ]++; FIXME: maybe this doesn't work because (Maybe Int) is too big?+%foreign cabi noInt
+ test/data/mutual.kmp view
@@ -0,0 +1,22 @@+; TODO: not# builtin+not : Bool -- Bool+ =: [+ { case+ | True -> False+ | _ -> True+ }+]++odd : Int -- Bool+ =: [ dup 0 =+ if( drop False+ , - 1 even )+ ]++even : Int -- Bool+ =: [ dup 0 =+ if( drop True+ , - 1 odd )+ ]++%foreign cabi even
+ test/data/ty.kmp view
@@ -0,0 +1,46 @@+type Void {}++type Maybe a { Just a | Nothing }++type OS { Macos | Linux | Windows | Freebsd }++; just has type a -- Maybe a+; nothing has type -- Maybe a++rand : -- Int+ =: $cfun"rand"++; all types are sized (monomorphized)+drop2 : a b --+ =: [ drop drop ]++drop3 : a b c --+ =: [ drop drop drop ]++trip : a -- a a a+ =: [ dup dup ]++trint : -- Int Int Int+ =: [ 0 trip ]++even : Int -- Bool+ =: [ 2 % 0 = ]++randBool : -- Bool+ =: [ rand even ]++maybeEven : -- (Maybe Int)+ =: [ rand dup even+ if( drop Nothing+ , Just+ )+ ]++push3 : -- OS OS OS+ =: [ Linux trip ]++doNothing : Int Int -- Int Int+ =: [ ]++%foreign cabi randBool+%foreign cabi maybeEven