kempe 0.1.1.0 → 0.1.1.1

raw patch · 31 files changed

+572/−394 lines, 31 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +1/−1
• bench/Bench.hs +7/−2
• docs/manual.pdf binary
• kempe.cabal +17/−3
• lib/numbertheory.kmp +3/−0
• lib/order.kmp +11/−0
• lib/rational.kmp +24/−0
• prelude/arith.kmp +17/−0
• src/Kempe/AST.hs +7/−88
• src/Kempe/AST/Size.hs +104/−0
• src/Kempe/Asm/X86.hs +2/−2
• src/Kempe/Asm/X86/ControlFlow.hs +79/−64
• src/Kempe/Asm/X86/Linear.hs +49/−47
• src/Kempe/Asm/X86/Liveness.hs +4/−4
• src/Kempe/Asm/X86/Type.hs +6/−7
• src/Kempe/Check/Lint.hs +20/−0
• src/Kempe/Check/TopLevel.hs +1/−16
• src/Kempe/Error.hs +1/−1
• src/Kempe/Error/Warning.hs +23/−0
• src/Kempe/File.hs +3/−1
• src/Kempe/IR.hs +5/−148
• src/Kempe/IR/Opt.hs +12/−2
• src/Kempe/IR/Type.hs +154/−0
• src/Kempe/Lexer.x +0/−2
• src/Kempe/Module.hs +9/−5
• src/Kempe/Monomorphize.hs +1/−0
• src/Kempe/Pipeline.hs +2/−0
• src/Kempe/Shuttle.hs +3/−0
• src/Kempe/TyAssign.hs +1/−1
• test/Backend.hs +1/−0

@@ -1,5 +1,10 @@ # kempe +## 0.1.1.1++  * Performance improvements under the hood (use `IntSet`s for liveness+    analysis)+ ## 0.1.1.0    * Fix internal pretty-printer (exposed as hidden `fmt` subcommand)

@@ -13,7 +13,7 @@ Installation is via [cabal-install](https://www.haskell.org/cabal/):  ```-cabal install kempe+cabal install kempe --constraint='kempe -no-par' ```  For shell completions put the following in your `~/.bashrc` or

@@ -75,11 +75,12 @@                         [ bench "X86 (examples/factorial.kmp)" $ nf mkControlFlow f                         , bench "X86 (examples/splitmix.kmp)" $ nf mkControlFlow s                         ]-                  , env cfEnv $ \ ~(s, f, n) ->+                  , env cfEnv $ \ ~(s, f, n, r) ->                       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+                        , bench "X86 (lib/rational.kmp)" $ nf reconstruct r                         ]                   , env absX86 $ \ ~(s, f, n) ->                       bgroup "Register allocation"@@ -94,6 +95,7 @@                         , 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 "Generate assembly (lib/rational.kmp)" $ nfIO (writeAsm "lib/rational.kmp")                         , bench "Object file (examples/factorial.kmp)" $ nfIO (compile "examples/factorial.kmp" "/tmp/factorial.o" False)                         , bench "Object file (lib/numbertheory.kmp)" $ nfIO (compile "lib/numbertheory.kmp" "/tmp/numbertheory.o" False)                         , bench "Object file (examples/splitmix.kmp)" $ nfIO (compile "examples/splitmix.kmp" "/tmp/splitmix.o" False)@@ -103,6 +105,7 @@           splitmix = parseProcess "examples/splitmix.kmp"           fac = parseProcess "examples/factorial.kmp"           num = parseProcess "lib/numbertheory.kmp"+          rat = parseProcess "lib/rational.kmp"           eitherMod = snd <$> parseProcess "lib/either.kmp"           parsedInteresting = (,) <$> fac <*> num           prelude = parseProcess "prelude/fn.kmp"@@ -125,10 +128,12 @@           splitmixX86 = genX86 <$> splitmixMono           x86Env = (,) <$> splitmixX86 <*> facX86           numX86 = uncurry x86Parsed <$> num+          ratX86 = uncurry x86Parsed <$> rat           facX86Cf = mkControlFlow <$> facX86           splitmixX86Cf = mkControlFlow <$> splitmixX86           numX86Cf = mkControlFlow <$> numX86-          cfEnv = (,,) <$> splitmixX86Cf <*> facX86Cf <*> numX86Cf+          ratX86Cf = mkControlFlow <$> ratX86+          cfEnv = (,,,) <$> splitmixX86Cf <*> facX86Cf <*> numX86Cf <*> ratX86Cf           facAbsX86 = reconstruct <$> facX86Cf           splitmixAbsX86 = reconstruct <$> splitmixX86Cf           numAbsX86 = reconstruct <$> numX86Cf

binary file changed (213705 → 214027 bytes)

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            kempe-version:         0.1.1.0+version:         0.1.1.1 license:         BSD-3-Clause license-file:    LICENSE copyright:       Copyright: (c) 2020 Vanessa McHale@@ -30,6 +30,10 @@     type:     git     location: https://github.com/vmchale/kempe +flag no-par+    description: Disable concurrent build+    manual:      True+ flag cross     description: Enable to ease cross-compiling     default:     False@@ -37,11 +41,11 @@  library kempe-modules     exposed-modules:+        Kempe.File         Kempe.Lexer         Kempe.Parser         Kempe.AST         Kempe.TyAssign-        Kempe.File         Kempe.Monomorphize         Kempe.Pipeline         Kempe.Shuttle@@ -59,10 +63,14 @@     other-modules:         Kempe.Check.Restrict         Kempe.Check.TopLevel+        Kempe.Check.Lint         Kempe.Unique         Kempe.Name         Kempe.Error+        Kempe.Error.Warning+        Kempe.AST.Size         Kempe.Asm.X86.Type+        Kempe.IR.Type         Kempe.Proc.Nasm         Prettyprinter.Ext         Data.Foldable.Ext@@ -91,6 +99,9 @@         process >=1.2.3.0,         temporary -any +    if !flag(no-par)+        ghc-options: -j +RTS -A32m -RTS+     if !flag(cross)         build-tool-depends: alex:alex -any, happy:happy -any @@ -160,6 +171,9 @@         text -any,         composition-prelude -any +    if !flag(no-par)+        ghc-options: -j +RTS -A32m -RTS+     if impl(ghc >=8.0)         ghc-options:             -Wincomplete-uni-patterns -Wincomplete-record-updates@@ -210,7 +224,7 @@     main-is:          Bench.hs     hs-source-dirs:   bench     default-language: Haskell2010-    ghc-options:      -O3 -Wall+    ghc-options:      -Wall     build-depends:         base -any,         kempe-modules -any,

@@ -7,6 +7,9 @@            , dup dip(%) swap gcd )        ] +lcm : Int Int -- Int+    =: [ dup2 dip(dip(*)) gcd / ]+ square : Int -- Int        =: [ dup * ] 

@@ -0,0 +1,11 @@+import "prelude/fn.kmp"++type Order { LT | EQ | GT }++; from Mirth+cmpInt : Int Int -- Order+       =: [ dup2 =+            if( drop2 EQ+              , < if ( LT, GT )+              )+          ]

@@ -0,0 +1,24 @@+import"prelude/fn.kmp"+import"lib/numbertheory.kmp"++; Slightly suspect rational based on 'Int' type+type Rational { Rational Int Int }++unRational : Rational -- Int Int+           =: [ { case | Rational -> } ]++multRat : Rational Rational -- Rational+        =: [ dip(unRational) unRational dip(swap *) * Rational ]++reduce : Rational -- Rational+       =: [ unRational dup2 gcd dup dip(swap dip(/)) / Rational ]++addRat : Rational Rational -- Rational+       =: [ dip(unRational) unRational dip(swap)+            dup2 * dip(swap dip(swap) * dip(*) +)+            Rational reduce+          ]++%foreign kabi multRat+%foreign kabi addRat+%foreign kabi reduce

@@ -0,0 +1,17 @@+import "prelude/fn.kmp"++succInt : Int -- Int+        =: [ 1 + ]++predInt : Int -- Int+        =: [ 1 - ]++isZeroInt : Int -- Bool+          =: [ 0 = ]++; More from Mirth+maxInt : Int Int -- Int+       =: [ dup2 < if(nip, drop) ]++minInt : Int Int -- Int+       =: [ dup2 < if(drop, nip) ]

@@ -6,26 +6,20 @@ {-# LANGUAGE OverloadedStrings #-}  -- | Frontend AST-module Kempe.AST ( BuiltinTy (..)-                 , KempeTy (..)-                 , StackType (..)-                 , ConsAnn (..)+module Kempe.AST ( ConsAnn (..)                  , Atom (..)                  , BuiltinFn (..)                  , KempeDecl (..)                  , Pattern (..)-                 , ABI (..)                  , Declarations                  , Module (..)-                 , freeVars+                 , ABI (..)+                 , BuiltinTy (..)+                 , KempeTy (..)+                 , StackType (..)                  , MonoStackType-                 , SizeEnv-                 , Size-                 , size-                 , sizeStack-                 , size'-                 , cSize                  , prettyMonoStackType+                 , freeVars                  , prettyTyped                  , prettyTypedModule                  , prettyFancyModule@@ -41,48 +35,20 @@ import           Data.Foldable           (toList) 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           Data.Semigroup          ((<>)) import qualified Data.Set                as S import           Data.Text.Lazy.Encoding (decodeUtf8) import           Data.Word               (Word8) import           GHC.Generics            (Generic)+import           Kempe.AST.Size import           Kempe.Name-import           Kempe.Unique import           Numeric.Natural import           Prettyprinter           (Doc, Pretty (pretty), align, braces, brackets, colon, concatWith, dquotes, fillSep, hsep, parens, pipe, sep, vsep, (<+>)) import           Prettyprinter.Ext -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 }@@ -91,21 +57,9 @@ 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 { patternKind :: c, patternName :: TyName c } -- a constructed pattern                  | PatternWildcard b@@ -250,14 +204,6 @@     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 <+> align (":" <+> sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os) <#> "=:" <+> brackets (align (fillSep (atomizer <$> as)))) prettyKempeDecl _ (Export _ abi n)              = "%foreign" <+> pretty abi <+> pretty n@@ -317,33 +263,6 @@  freeVars :: [KempeTy a] -> S.Set (Name a) freeVars tys = S.fromList (concatMap extrVars tys)---- machinery for assigning a constructor to a function of its concrete types--- (and then curry forward...)--type Size = [Int64] -> Int64-type SizeEnv = IM.IntMap Size---- the kempe sizing system is kind of fucked (it mostly works tho)---- | Don't call this on ill-kinded types; it won't throw any error.-size :: SizeEnv -> KempeTy a -> Size-size _ (TyBuiltin _ TyInt)                 = const 8-size _ (TyBuiltin _ TyBool)                = const 1-size _ (TyBuiltin _ TyInt8)                = const 1-size _ (TyBuiltin _ TyWord)                = const 8-size _ TyVar{}                             = error "Internal error: type variables should not be present at this stage."-size env (TyNamed _ (Name _ (Unique k) _)) = IM.findWithDefault (error "Size not in map!") k env-size env (TyApp _ ty ty')                  = \tys -> size env ty (size env ty' [] : tys)--cSize :: Size -> Int64-cSize = ($ [])--size' :: SizeEnv -> KempeTy a -> Int64-size' env = cSize . size env--sizeStack :: SizeEnv -> [KempeTy a] -> Int64-sizeStack env = getSum . foldMap (Sum . size' env)  -- | Used in "Kempe.Monomorphize" for patterns flipStackType :: StackType () -> StackType ()

@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Frontend AST+-- | This module is split out so that the bakend/IR need not depend on+-- everything in 'AST'.+module Kempe.AST.Size ( KempeTy (..)+                      , StackType (..)+                      , MonoStackType+                      , BuiltinTy (..)+                      , ABI (..)+                      , prettyMonoStackType+                      -- * Sizing bits+                      , SizeEnv+                      , Size+                      , cSize+                      , size+                      , size'+                      , sizeStack+                      ) where++import           Control.DeepSeq (NFData)+import           Data.Int        (Int64)+import qualified Data.IntMap     as IM+import           Data.Monoid     (Sum (..))+import qualified Data.Set        as S+import           GHC.Generics    (Generic)+import           Kempe.Name+import           Kempe.Unique+import           Prettyprinter   (Doc, Pretty (pretty), parens, sep, (<+>))++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 ()])++prettyMonoStackType :: MonoStackType -> Doc a+prettyMonoStackType (is, os) = sep (fmap pretty is) <+> "--" <+> sep (fmap pretty os)++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"++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')++instance Pretty (StackType a) where+    pretty (StackType _ ins outs) = sep (fmap pretty ins) <+> "--" <+> sep (fmap pretty outs)++data ABI = Cabi+         | Kabi+         deriving (Eq, Ord, Generic, NFData)++instance Pretty ABI where+    pretty Cabi = "cabi"+    pretty Kabi = "kabi"++-- machinery for assigning a constructor to a function of its concrete types+-- (and then curry forward...)++type Size = [Int64] -> Int64+type SizeEnv = IM.IntMap Size++-- the kempe sizing system is kind of fucked (it mostly works tho)++-- | Don't call this on ill-kinded types; it won't throw any error.+size :: SizeEnv -> KempeTy a -> Size+size _ (TyBuiltin _ TyInt)                 = const 8+size _ (TyBuiltin _ TyBool)                = const 1+size _ (TyBuiltin _ TyInt8)                = const 1+size _ (TyBuiltin _ TyWord)                = const 8+size _ TyVar{}                             = error "Internal error: type variables should not be present at this stage."+size env (TyNamed _ (Name _ (Unique k) _)) = IM.findWithDefault (error "Size not in map!") k env+size env (TyApp _ ty ty')                  = \tys -> size env ty (size env ty' [] : tys)++cSize :: Size -> Int64+cSize = ($ [])++size' :: SizeEnv -> KempeTy a -> Int64+size' env = cSize . size env++sizeStack :: SizeEnv -> [KempeTy a] -> Int64+sizeStack env = getSum . foldMap (Sum . size' env)

@@ -9,9 +9,9 @@ import           Data.Foldable.Ext import           Data.List                  (scanl') import           Data.Word                  (Word8)-import           Kempe.AST+import           Kempe.AST.Size import           Kempe.Asm.X86.Type-import qualified Kempe.IR                   as IR+import qualified Kempe.IR.Type              as IR  toAbsReg :: IR.Temp -> AbsReg toAbsReg (IR.Temp8 i)   = AllocReg8 i

@@ -6,9 +6,9 @@ import           Control.Monad.State.Strict (State, evalState, gets, modify) import           Data.Bifunctor             (first, second) import           Data.Functor               (($>))+import qualified Data.IntSet                as IS import qualified Data.Map                   as M import           Data.Semigroup             ((<>))-import qualified Data.Set                   as S import           Kempe.Asm.X86.Type  -- map of labels by node@@ -29,13 +29,28 @@ 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']+singleton :: AbsReg -> IS.IntSet+singleton = maybe IS.empty IS.singleton . toInt +-- | Make sure 8-bit and 64-bit registers have no overlap.+--+-- Also can't be called on abstract registers i.e. 'DataPointer' or 'CArg1'.+-- This is kinda sus but it allows us to use an 'IntSet' for liveness analysis.+toInt :: AbsReg -> Maybe Int+toInt (AllocReg64 i) = Just i+toInt (AllocReg8 i)  = Just i+toInt _              = Nothing++fromList :: [AbsReg] -> IS.IntSet+fromList = foldMap singleton++addrRegs :: Addr AbsReg -> IS.IntSet+addrRegs (Reg r)              = singleton r+addrRegs (AddrRRPlus r r')    = fromList [r, r']+addrRegs (AddrRCPlus r _)     = singleton r+addrRegs (AddrRCMinus r _)    = singleton r+addrRegs (AddrRRScale r r' _) = fromList [r, r']+ -- | Annotate instructions with a unique node name and a list of all possible -- destinations. addControlFlow :: [X86 AbsReg ()] -> FreshM [X86 AbsReg ControlAnn]@@ -43,60 +58,60 @@ addControlFlow ((Label _ l):asms) = do     { i <- lookupLabel l     ; (f, asms') <- next asms-    ; pure (Label (ControlAnn i (f []) S.empty S.empty) l : asms')+    ; pure (Label (ControlAnn i (f []) IS.empty IS.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')+    ; pure (Je (ControlAnn i (f [l_i]) IS.empty IS.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')+    ; pure (Jl (ControlAnn i (f [l_i]) IS.empty IS.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')+    ; pure (Jle (ControlAnn i (f [l_i]) IS.empty IS.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')+    ; pure (Jne (ControlAnn i (f [l_i]) IS.empty IS.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')+    ; pure (Jge (ControlAnn i (f [l_i]) IS.empty IS.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')+    ; pure (Jg (ControlAnn i (f [l_i]) IS.empty IS.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)+    ; pure (Jump (ControlAnn i [l_i] IS.empty IS.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)+    ; pure (Call (ControlAnn i [l_i] IS.empty IS.empty) l : nextAsms)     } addControlFlow (Ret{}:asms) = do     { i <- getFresh     ; nextAsms <- addControlFlow asms-    ; pure (Ret (ControlAnn i [] S.empty S.empty) : nextAsms)+    ; pure (Ret (ControlAnn i [] IS.empty IS.empty) : nextAsms)     } addControlFlow (asm:asms) = do     { i <- getFresh@@ -104,64 +119,64 @@     ; 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 :: X86 AbsReg ann -> IS.IntSet+uses (PushReg _ r)       = 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 (MovAR _ a r)       = singleton r <> addrRegs a+uses (MovRR _ _ r)       = singleton r+uses (AddRR _ r r')      = fromList [r, r']+uses (SubRR _ r r')      = fromList [r, r']+uses (ImulRR _ r r')     = fromList [r, r']+uses (AddRC _ r _)       = singleton r+uses (SubRC _ r _)       = 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 (XorRR _ r r')      = fromList [r, r']+uses (CmpAddrReg _ a r)  = singleton r <> addrRegs a+uses (CmpRegReg _ r r')  = fromList [r, r']+uses (CmpRegBool _ r _)  = 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 (ShiftLRR _ r r')   = fromList [r, r']+uses (ShiftRRR _ r r')   = fromList [r, r']+uses (MovRCi8 _ r _)     = 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+uses (IdivR _ r)         = singleton r+uses (DivR _ r)          = singleton r+uses Cqo{}               = IS.empty -- TODO?+uses (AndRR _ r r')      = fromList [r, r']+uses (OrRR _ r r')       = fromList [r, r']+uses (PopcountRR _ _ r') = singleton r'+uses (NegR _ r)          = singleton r+uses _                   = IS.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 :: X86 AbsReg ann -> IS.IntSet+defs (MovRA _ r _)      = singleton r+defs (MovRR _ r _)      = singleton r+defs (MovRC _ r _)      = singleton r+defs (MovRCBool _ r _)  = singleton r+defs (MovRCi8 _ r _)    = singleton r+defs (MovRWord _ r _)   = singleton r+defs (AddRR _ r _)      = singleton r+defs (SubRR _ r _)      = singleton r+defs (ImulRR _ r _)     = singleton r+defs (AddRC _ r _)      = singleton r+defs (SubRC _ r _)      = singleton r+defs (XorRR _ r _)      = singleton r+defs (MovRL _ r _)      = singleton r+defs (ShiftRRR _ r _)   = singleton r+defs (PopReg _ r)       = singleton r+defs (ShiftLRR _ r _)   = singleton r+defs (AndRR _ r _)      = singleton r+defs (OrRR _ r _)       = singleton r+defs (PopcountRR _ r _) = singleton r+defs (NegR _ r)         = singleton r+defs (MovRCTag _ r _)   = singleton r -- defs for IdivR &c.?-defs _                  = S.empty+defs _                  = IS.empty  next :: [X86 AbsReg ()] -> FreshM ([Int] -> [Int], [X86 AbsReg ControlAnn]) next asms = do

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}  -- | Linear scan register allocator@@ -9,7 +10,8 @@  import           Control.Monad.State.Strict (State, evalState, gets) import           Data.Foldable              (traverse_)-import qualified Data.Map                   as M+import qualified Data.IntMap                as IM+import qualified Data.IntSet                as IS import           Data.Maybe                 (fromMaybe) import           Data.Semigroup             ((<>)) import qualified Data.Set                   as S@@ -29,12 +31,12 @@ -- 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+data AllocSt = AllocSt { allocs :: IM.IntMap X86Reg -- ^ Already allocated registers                        , free64 :: S.Set X86Reg -- TODO: IntSet here?                        , free8  :: S.Set X86Reg                        } -allocsLens :: Lens' AllocSt (M.Map AbsReg X86Reg)+allocsLens :: Lens' AllocSt (IM.IntMap X86Reg) allocsLens f s = fmap (\x -> s { allocs = x }) (f (allocs s))  free64Lens :: Lens' AllocSt (S.Set X86Reg)@@ -92,46 +94,48 @@ allocRegs :: [X86 AbsReg Liveness] -> [X86 X86Reg ()] allocRegs = runAllocM . traverse allocReg -new :: Liveness -> S.Set AbsReg-new (Liveness i o) = o S.\\ i+new :: Liveness -> IS.IntSet+new (Liveness i o) = o IS.\\ i -done :: Liveness -> S.Set AbsReg-done (Liveness i o) = i S.\\ o+done :: Liveness -> IS.IntSet+done (Liveness i o) = i IS.\\ o  freeDone :: Liveness -> AllocM ()-freeDone l = traverse_ freeAbsReg absRs+freeDone l = traverse_ freeReg (IS.toList 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+freeReg :: Int -> AllocM ()+freeReg i = do+    xR <- findReg i+    modifying allocsLens (IM.delete i)+    case xR of+        R8   -> free64Bit xR+        R9   -> free64Bit xR+        R10  -> free64Bit xR+        R11  -> free64Bit xR+        R12  -> free64Bit xR+        R13  -> free64Bit xR+        R14  -> free64Bit xR+        R15  -> free64Bit xR+        R8b  -> free8Bit xR+        R9b  -> free8Bit xR+        R10b -> free8Bit xR+        R11b -> free8Bit xR+        R12b -> free8Bit xR+        R13b -> free8Bit xR+        R14b -> free8Bit xR+        R15b -> free8Bit xR -assignReg64 :: Int -> X86Reg -> AllocM ()-assignReg64 i xr =-    modifying allocsLens (M.insert (AllocReg64 i) xr)+    where free64Bit xR = do+            modifying free64Lens (S.insert xR)+            modifying free8Lens (<> assoc xR)+          free8Bit xR = do+            modifying free8Lens (S.insert xR)+            modifying free64Lens (<> assoc xR) -assignReg8 :: Int -> X86Reg -> AllocM ()-assignReg8 i xr =-    modifying allocsLens (M.insert (AllocReg8 i) xr)+assignReg :: Int -> X86Reg -> AllocM ()+assignReg i xr =+    modifying allocsLens (IM.insert i xr)  newReg64 :: AllocM X86Reg newReg64 = do@@ -157,23 +161,21 @@      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)+findReg :: Int -> AllocM X86Reg+findReg i = gets+    (IM.findWithDefault (error "Internal error in register allocator: unfound register") i . 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+    if i `IS.member` new l+        then do { res <- newReg64 ; assignReg i res ; pure res }+        else findReg 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+    if i `IS.member` new l+        then do { res <- newReg8 ; assignReg i res ; pure res }+        else findReg i  useAddr :: Liveness -> Addr AbsReg -> AllocM (Addr X86Reg) useAddr l (Reg r)               = Reg <$> useReg l r

@@ -8,12 +8,12 @@ import           Control.Composition (thread) -- this seems to be faster import qualified Data.IntMap.Lazy    as IM+import qualified Data.IntSet         as IS import           Data.Semigroup      ((<>))-import qualified Data.Set            as S import           Kempe.Asm.X86.Type  emptyLiveness :: Liveness-emptyLiveness = Liveness S.empty S.empty+emptyLiveness = Liveness IS.empty IS.empty  -- need: succ for a node @@ -62,5 +62,5 @@ 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))+          ins' = usesNode c <> (out l IS.\\ defsNode c)+          out' = IS.unions (fmap ins (succNode c ns))

@@ -17,10 +17,9 @@ 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.IntSet             as IS import           Data.Semigroup          ((<>))-import qualified Data.Set                as S import           Data.Text.Encoding      (decodeUtf8) import qualified Data.Text.Lazy.Encoding as TL import           Data.Word               (Word8)@@ -30,17 +29,17 @@  type Label = Word -data Liveness = Liveness { ins :: !(S.Set AbsReg), out :: !(S.Set AbsReg) } -- strictness annotations make it perform better+data Liveness = Liveness { ins :: !IS.IntSet, out :: !IS.IntSet } -- 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+        where pp = mconcat . punctuate "," . fmap pretty . IS.toList  data ControlAnn = ControlAnn { node     :: !Int                              , conn     :: [Int]-                             , usesNode :: S.Set AbsReg-                             , defsNode :: S.Set AbsReg+                             , usesNode :: IS.IntSet+                             , defsNode :: IS.IntSet                              } deriving (Generic, NFData)  -- currently just has 64-bit and 8-bit registers@@ -270,7 +269,7 @@     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 (MovACTag _ a t)     = i4 ("mov byte" <+> 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)

@@ -0,0 +1,20 @@+module Kempe.Check.Lint ( lint+                        ) where++import           Data.Foldable.Ext+import           Kempe.AST+import           Kempe.Error.Warning++lint :: Declarations a b b -> Maybe (Warning b)+lint = foldMapAlternative lintDecl++lintDecl :: KempeDecl a b b -> Maybe (Warning b)+lintDecl Export{}             = Nothing+lintDecl TyDecl{}             = Nothing+lintDecl ExtFnDecl{}          = Nothing+lintDecl (FunDecl _ _ _ _ as) = lintAtoms as++lintAtoms :: [Atom b b] -> Maybe (Warning b)+lintAtoms []                       = Nothing+lintAtoms (a@(Dip l _):a'@Dip{}:_) = Just (DoubleDip l a a')+lintAtoms (_:as)                   = lintAtoms as

@@ -1,26 +1,16 @@-{-# LANGUAGE OverloadedStrings #-}- module Kempe.Check.TopLevel ( topLevelCheck                             , Warning                             ) where  import           Control.Applicative ((<|>))-import           Control.Exception   (Exception) import           Data.Foldable       (toList) import           Data.Foldable.Ext import           Data.List           (group, sort) import           Data.Maybe          (mapMaybe)-import           Data.Semigroup      ((<>))-import           Data.Typeable       (Typeable) import           Kempe.AST+import           Kempe.Error.Warning import           Kempe.Name-import           Prettyprinter       (Pretty (pretty)) -data Warning a = NameClash a (Name a)--instance Pretty a => Pretty (Warning a) where-    pretty (NameClash l x) = pretty l <> " '" <> pretty x <> "' is defined more than once."- topLevelCheck :: Declarations a c a -> Maybe (Warning a) topLevelCheck ds =         checkNames (collectNames ds)@@ -43,8 +33,3 @@ checkNames ns = foldMapAlternative announce (group $ sort ns) -- maybe could be better idk     where announce (_:y:_) = Just $ NameClash (loc y) y           announce _       = Nothing--instance (Pretty a) => Show (Warning a) where-    show = show . pretty--instance (Pretty a, Typeable a) => Exception (Warning a)

@@ -11,7 +11,7 @@ import           Data.Semigroup    ((<>)) import           Data.Typeable     (Typeable) import           GHC.Generics      (Generic)-import           Kempe.AST+import           Kempe.AST.Size import           Kempe.Name import           Prettyprinter     (Pretty (pretty), comma, squotes, (<+>)) 

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Error.Warning ( Warning (..)+                           ) where++import           Control.Exception (Exception)+import           Data.Semigroup    ((<>))+import           Data.Typeable     (Typeable)+import           Kempe.AST+import           Kempe.Name+import           Prettyprinter     (Pretty (pretty), (<+>))++data Warning a = NameClash a (Name a)+               | DoubleDip a (Atom a a) (Atom a a)++instance Pretty a => Pretty (Warning a) where+    pretty (NameClash l x)    = pretty l <> " '" <> pretty x <> "' is defined more than once."+    pretty (DoubleDip l a a') = pretty l <+> pretty a <+> pretty a' <+> "could be written as a single dip()"++instance (Pretty a) => Show (Warning a) where+    show = show . pretty++instance (Pretty a, Typeable a) => Exception (Warning a)

@@ -10,6 +10,7 @@                   ) where  -- common b/w test suite and exec, repl utils+import           Control.Applicative       ((<|>)) import           Control.Composition       ((.*)) import           Control.Exception         (Exception, throwIO) import           Data.Bifunctor            (bimap)@@ -20,6 +21,7 @@ import           Data.Typeable             (Typeable) import           Kempe.AST import           Kempe.Asm.X86.Type+import           Kempe.Check.Lint import           Kempe.Check.Pattern import           Kempe.Check.TopLevel import           Kempe.Error@@ -43,7 +45,7 @@ warnFile :: FilePath -> IO (Maybe (Warning AlexPosn)) warnFile fp = do     (_, m) <- parseProcess fp-    pure $ topLevelCheck m+    pure (topLevelCheck m <|> lint m)  yeetIO :: Exception e => Either e a -> IO a yeetIO = either throwIO pure

@@ -1,16 +1,4 @@-{-# 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@@ -18,46 +6,26 @@                 , 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           Data.Int                   (Int64) import qualified Data.IntMap                as IM-import           Data.Semigroup             ((<>))-import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)-import           Data.Word                  (Word8)-import           GHC.Generics               (Generic)+import           Data.Text.Encoding         (encodeUtf8) import           Kempe.AST+import           Kempe.AST.Size+import           Kempe.IR.Type import           Kempe.Name import           Kempe.Unique import           Lens.Micro                 (Lens') import           Lens.Micro.Mtl             (modifying)-import           Prettyprinter              (Doc, Pretty (pretty), braces, brackets, colon, hardline, parens, (<+>))+import           Prettyprinter              (Doc, Pretty (pretty)) 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@@ -105,117 +73,6 @@  prettyIR :: [Stmt] -> Doc ann prettyIR = prettyLines . 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 (Eq, Generic, NFData)-           -- TODO: one for data, one for C ABI--data BoolBinOp = BoolAnd-               | BoolOr-               | BoolXor-               deriving (Eq, Generic, NFData)--instance Pretty BoolBinOp where-    pretty BoolAnd = "&"-    pretty BoolOr  = "||"-    pretty BoolXor = "xor"--data RelBinOp = IntEqIR-              | IntNeqIR-              | IntLtIR-              | IntGtIR-              | IntLeqIR-              | IntGeqIR-              deriving (Eq, 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 (Eq, 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 -> Declarations () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt] writeModule env m = traverse_ assignName m *> foldMapA (writeDecl env) m

@@ -1,10 +1,10 @@ module Kempe.IR.Opt ( optimize                     ) where -import           Kempe.IR+import           Kempe.IR.Type  optimize :: [Stmt] -> [Stmt]-optimize = sameTarget . successiveBumps . removeNop+optimize = sameTarget . successiveBumps . successiveBumps . removeNop  -- | Often IR generation will leave us with something like --@@ -39,6 +39,16 @@         :(MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i')))         :ss) =             MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt $ i+i')) : successiveBumps ss+successiveBumps+    ((MovTemp DataPointer (ExprIntBinOp IntPlusIR (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+    ((MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt i)))+        :(MovTemp DataPointer (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt i')))+        :ss) =+            MovTemp DataPointer (ExprIntBinOp IntMinusIR (Reg DataPointer) (ConstInt $ i'-i)) : successiveBumps ss successiveBumps     (st@(MovMem e0 k (Mem 8 e1))         :(MovMem e0' k' (Mem 8 e1'))

@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}++-- | IR loosely based on Appel book.+module Kempe.IR.Type ( Stmt (..)+                     , Exp (..)+                     , RelBinOp (..)+                     , IntBinOp (..)+                     , BoolBinOp (..)+                     , Label+                     , Temp (..)+                     , WriteSt (..)+                     ) where++import           Control.DeepSeq      (NFData)+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BSL+import           Data.Int             (Int64, Int8)+import           Data.Semigroup       ((<>))+import           Data.Text.Encoding   (decodeUtf8)+import           Data.Word            (Word8)+import           GHC.Generics         (Generic)+import           Kempe.AST.Size+import           Prettyprinter        (Doc, Pretty (pretty), braces, brackets, colon, hardline, parens, (<+>))+import           Prettyprinter.Ext++data WriteSt = WriteSt { wlabels :: [Label]+                       , temps   :: [Int]+                       }++type Label = Word++prettyLabel :: Label -> Doc ann+prettyLabel l = "kmp" <> pretty l++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"++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 (Eq, Generic, NFData)+           -- TODO: one for data, one for C ABI++data BoolBinOp = BoolAnd+               | BoolOr+               | BoolXor+               deriving (Eq, Generic, NFData)++instance Pretty BoolBinOp where+    pretty BoolAnd = "&"+    pretty BoolOr  = "||"+    pretty BoolXor = "xor"++data RelBinOp = IntEqIR+              | IntNeqIR+              | IntLtIR+              | IntGtIR+              | IntLeqIR+              | IntGeqIR+              deriving (Eq, 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 (Eq, 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    = "/~"+

@@ -78,8 +78,6 @@         ","                      { mkSym Comma }         \_                       { mkSym Underscore } -        -- ¬ ∧ ∨ ⇨ ⊻-         -- symbols/operators         "%"                      { mkSym Percent }         "*"                      { mkSym Times }

@@ -16,17 +16,21 @@  parseProcess :: FilePath -> IO (Int, Declarations AlexPosn AlexPosn AlexPosn) parseProcess fp = do-    (st, [], ds) <- loopFps [fp] alexInitUserState+    (st, [], ds) <- loopFps True [fp] alexInitUserState     pure (fst3 st, {-# SCC "dedup" #-} dedup ds)  yeetIO :: Exception e => Either e a -> IO a yeetIO = either throwIO pure -loopFps :: [FilePath] -> AlexUserState -> IO (AlexUserState, [FilePath], Declarations AlexPosn AlexPosn AlexPosn)-loopFps [] st = pure (st, [], [])-loopFps (fp:fps) st = do+-- TODO: if module is imported, discard its exports+loopFps :: Bool -> [FilePath] -> AlexUserState -> IO (AlexUserState, [FilePath], Declarations AlexPosn AlexPosn AlexPosn)+loopFps _ [] st = pure (st, [], [])+loopFps isInit (fp:fps) st = do     (st', Module is ds) <- parseStep fp st-    third3 (++ ds) <$> loopFps (fmap ASCII.unpack (reverse is) ++ fps) st'+    let discardDs = if isInit then id else filter (not . isExport)+    third3 (++ discardDs ds) <$> loopFps False (fmap ASCII.unpack (reverse is) ++ fps) st'+    where isExport Export{} = True+          isExport _        = False  parseStep :: FilePath -> AlexUserState -> IO (AlexUserState, Module AlexPosn AlexPosn AlexPosn) parseStep fp st = do

@@ -34,6 +34,7 @@ import           Data.Tuple                 (swap) import           Data.Tuple.Extra           (fst3, snd3, thd3) import           Kempe.AST+import           Kempe.AST.Size import           Kempe.Error import           Kempe.Name import           Kempe.Unique

@@ -8,6 +8,7 @@ import           Data.Bifunctor            (first) import           Data.Typeable             (Typeable) import           Kempe.AST+import           Kempe.AST.Size import           Kempe.Asm.X86 import           Kempe.Asm.X86.ControlFlow import           Kempe.Asm.X86.Linear@@ -16,6 +17,7 @@ import           Kempe.Check.Restrict import           Kempe.IR import           Kempe.IR.Opt+import           Kempe.IR.Type import           Kempe.Shuttle  irGen :: Typeable a

@@ -5,6 +5,7 @@  import           Data.Functor        (void) import           Kempe.AST+import           Kempe.AST.Size import           Kempe.Check.Pattern import           Kempe.Error import           Kempe.Inline@@ -16,6 +17,8 @@                     -> Either (Error ()) (Declarations () (ConsAnn MonoStackType) (StackType ()), (Int, SizeEnv)) inlineAssignFlatten ctx m = do     -- check before inlining otherwise users would get weird errors+    -- TODO: make this more efficient now that liveness anal. is not dominating+    -- all performance     void $ do         void $ runTypeM ctx (checkModule m)         mErr $ checkModuleExhaustive (void <$> m)

@@ -432,7 +432,7 @@  assignModule :: Declarations a c b -> TypeM () (Declarations () (StackType ()) (StackType ())) assignModule m = {-# SCC "assignModule" #-} do-    traverse_ tyHeader m+    {-# SCC "tyHeader" #-} traverse_ tyHeader m     m' <- traverse assignDecl m     backNames <- unifyM =<< gets constraints     pure (fmap (bimap .$ substConstraintsStack backNames) m')

@@ -42,6 +42,7 @@         , codegen "lib/gaussian.kmp"         , codegen "test/data/ccall.kmp"         , codegen "test/data/mutual.kmp"+        , codegen "lib/rational.kmp"         ]  codegen :: FilePath -> TestTree