kempe 0.1.0.1 → 0.1.0.2

raw patch · 14 files changed

+87/−24 lines, 14 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−1
• docs/manual.pdf binary
• kempe.cabal +3/−2
• run/Main.hs +20/−4
• src/Kempe/AST.hs +2/−2
• src/Kempe/Asm/X86.hs +2/−0
• src/Kempe/IR.hs +4/−4
• src/Kempe/IR/Opt.hs +31/−1
• src/Kempe/Monomorphize.hs +2/−2
• src/Kempe/Parser.y +1/−3
• src/Kempe/TyAssign.hs +6/−4
• test/Backend.hs +1/−0
• test/data/multiConstruct.kmp +8/−0
• test/data/mutual.kmp +0/−1

@@ -1,9 +1,15 @@ # kempe +## 0.1.0.2++  * Add optimizations (simplify code so that liveness analysis is quicker)+  * Fix major bug in kind-checker+  * Fix bug in type assignment+ ## 0.1.0.1    * Better debug pretty-printer-  * Pattern match exchaustiveness checker so that pattern matches don't do+  * Pattern match exhaustiveness checker so that pattern matches don't do     something heinous at runtime  ## 0.1.0.0

binary file changed (211830 → 212387 bytes)

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            kempe-version:         0.1.0.1+version:         0.1.0.2 license:         BSD-3-Clause license-file:    LICENSE copyright:       Copyright: (c) 2020 Vanessa McHale@@ -110,7 +110,8 @@     build-depends:         base -any,         optparse-applicative -any,-        kempe-modules -any+        kempe-modules -any,+        prettyprinter >=1.7.0      if impl(ghc >=8.0)         ghc-options:

@@ -1,21 +1,33 @@ module Main (main) where -import           Control.Exception   (throwIO)-import qualified Data.Version        as V+import           Control.Exception         (throwIO)+import           Control.Monad             ((<=<))+import qualified Data.Version              as V+import           Kempe.AST import           Kempe.File import           Options.Applicative-import qualified Paths_kempe         as P-import           System.Exit         (ExitCode (ExitFailure), exitWith)+import qualified Paths_kempe               as P+import           Prettyprinter             (LayoutOptions (LayoutOptions), PageWidth (AvailablePerLine), hardline, layoutSmart)+import           Prettyprinter.Render.Text (renderIO)+import           System.Exit               (ExitCode (ExitFailure), exitWith)+import           System.IO                 (stdout)  data Command = TypeCheck !FilePath              | Compile !FilePath !(Maybe FilePath) !Bool !Bool !Bool -- TODO: take arch on cli+             | Format !FilePath +fmt :: FilePath -> IO ()+fmt = renderIO stdout <=< fmap (render . (<> hardline) . prettyModule . snd) . parsedFp+    where render = layoutSmart settings+          settings = LayoutOptions $ AvailablePerLine 80 0.5+ 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 (Format fp)                           = fmt fp run _                                     = putStrLn "Invalid combination of CLI options. Try kc --help" *> exitWith (ExitFailure 1)  kmpFile :: Parser FilePath@@ -24,6 +36,9 @@     <> help "Source file"     <> kmpCompletions) +fmtP :: Parser Command+fmtP = Format <$> kmpFile+ debugSwitch :: Parser Bool debugSwitch = switch     (long "debug"@@ -51,6 +66,7 @@ commandP :: Parser Command commandP = hsubparser     (command "typecheck" (info tcP (progDesc "Type-check module contents")))+    <|> hsubparser (command "fmt" (info fmtP (progDesc "Pretty-print a Kempe file")) <> internal)     <|> compileP     where         tcP = TypeCheck <$> kmpFile

@@ -147,12 +147,12 @@ 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 (If _ as as')    = "if(" <> fillSep (prettyTyped <$> as) <> ", " <> 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"-prettyTyped (Case _ ls)      = "case" <+> braces (align (vsep (toList $ fmap (uncurry prettyTypedLeaf) ls)))+prettyTyped (Case _ ls)      = "case" <+> braces (vsep (toList $ fmap (uncurry prettyTypedLeaf) ls))  data Atom c b = AtName b (Name b)               | Case b (NonEmpty (Pattern c b, [Atom c b]))

@@ -50,6 +50,8 @@ runWriteM :: IR.WriteSt -> WriteM a -> a runWriteM = flip evalState +-- | This should handle 'MovMem's of divers sizes but for now it just does+-- 1 byte or 8 bytes at a time. irEmit :: SizeEnv -> IR.Stmt -> WriteM [X86 AbsReg ()] irEmit _ (IR.Jump l) = pure [Jump () l] irEmit _ (IR.Labeled l) = pure [Label () l]

@@ -162,13 +162,13 @@          | IntNegIR Exp          | PopcountIR Exp          | EqByte Exp Exp-         deriving (Generic, NFData)+         deriving (Eq, Generic, NFData)            -- TODO: one for data, one for C ABI  data BoolBinOp = BoolAnd                | BoolOr                | BoolXor-               deriving (Generic, NFData)+               deriving (Eq, Generic, NFData)  instance Pretty BoolBinOp where     pretty BoolAnd = "&"@@ -181,7 +181,7 @@               | IntGtIR               | IntLeqIR               | IntGeqIR-              deriving (Generic, NFData)+              deriving (Eq, Generic, NFData)  instance Pretty RelBinOp where     pretty IntEqIR  = "="@@ -202,7 +202,7 @@               -- int/word mod are different, see: https://stackoverflow.com/questions/8231882/how-to-implement-the-mod-operator-in-assembly               | WordModIR               | WordDivIR-              deriving (Generic, NFData)+              deriving (Eq, Generic, NFData)  instance Pretty IntBinOp where     pretty IntPlusIR    = "+"

@@ -4,7 +4,7 @@ import           Kempe.IR  optimize :: [Stmt] -> [Stmt]-optimize = successiveBumps+optimize = sameTarget . successiveBumps . removeNop  -- | Often IR generation will leave us with something like --@@ -14,6 +14,11 @@ -- i.e. push a value and immediately pop it for use. -- -- This is silly and we remove it in this pass.+--+-- Also take the opportunity to simplify stuff like+--+-- > (movmem (- (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 0))))+-- > (movmem (- (reg datapointer) (int 0)) (mem [8] (- (reg datapointer) (int 8)))) successiveBumps :: [Stmt] -> [Stmt] successiveBumps [] = [] successiveBumps@@ -34,4 +39,29 @@         :(MovTemp DataPointer (ExprIntBinOp IntMinusIR (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'))+        :ss) | k == k' && e0 == e1' && e1 == e0' = st : successiveBumps ss successiveBumps (s:ss) = s : successiveBumps ss++-- | Stuff like+--+-- > (movmem (- (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 0))))+-- > (movmem (- (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 16))))+--+-- Basically if two successive 'Stmt's write to the same location, only bother+-- with the second one.+sameTarget :: [Stmt] -> [Stmt]+sameTarget [] = []+sameTarget+    ((MovMem e0 k _)+        :st@(MovMem e0' k' _)+        :ss) | k == k' && e0 == e0' = st : sameTarget ss+sameTarget (s:ss) = s : sameTarget ss++removeNop :: [Stmt] -> [Stmt]+removeNop = filter (not . isNop)+    where+        isNop (MovMem e _ (Mem _ e')) | e == e' = True -- the Eq on Exp is kinda weird, but if the syntax trees are the same then they're certainly equivalent semantically+        isNop _ = False

@@ -2,8 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections     #-} --- | This module is kind of half-assed. I don't have any references and it fails--- under various corner cases.+-- | This module is kind of half-assed. I don't have any references and it+-- depends on the inliner. module Kempe.Monomorphize ( closedModule                           , MonoM                           , runMonoM

@@ -17,6 +17,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T+import Data.Tuple.Extra (fst3) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Kempe.AST@@ -247,8 +248,5 @@  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  }

@@ -16,9 +16,11 @@ import           Data.Foldable              (traverse_) import           Data.Functor               (void, ($>)) import qualified Data.IntMap                as IM+import           Data.List                  (foldl') import           Data.List.NonEmpty         (NonEmpty (..)) import qualified Data.Set                   as S import qualified Data.Text                  as T+import           Data.Tuple.Extra           (fst3) import           Kempe.AST import           Kempe.Error import           Kempe.Name@@ -280,7 +282,6 @@     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@@ -295,7 +296,7 @@ -- from size, mkHKT :: Int -> Kind mkHKT 0 = Star-mkHKT i = TyCons (mkHKT i) Star+mkHKT i = TyCons (mkHKT $ i - 1) Star  tyInsertLeaf :: Name b -- ^ type being declared              -> S.Set (Name b) -> (TyName a, [KempeTy b]) -> TypeM () ()@@ -303,7 +304,8 @@     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)])) *>+    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))  assignTyLeaf :: Name b@@ -322,7 +324,7 @@     (tn $> ty, fmap void ins)  app :: KempeTy a -> [Name a] -> KempeTy a-app = foldr (\n ty -> TyApp undefined ty (TyVar undefined n))+app = foldl' (\ty n -> TyApp undefined ty (TyVar undefined n))  kindLookup :: TyName a -> TypeM a Kind kindLookup n@(Name _ (Unique i) l) = do

@@ -24,6 +24,7 @@         , pipelineWorks "examples/splitmix.kmp"         , pipelineWorks "examples/factorial.kmp"         , pipelineWorks "test/data/mutual.kmp"+        , pipelineWorks "test/data/multiConstruct.kmp"         , irNoYeet "test/data/export.kmp"         , irNoYeet "examples/splitmix.kmp"         , irNoYeet "examples/factorial.kmp"

@@ -0,0 +1,8 @@+type Either a b { Left a | Right b }++type Maybe a { Just a | Nothing }++mkJustRight : Int -- ((Either Int) (Maybe Int))+            =: [ Just Right ]++%foreign kabi mkJustRight

@@ -1,4 +1,3 @@-; TODO: not# builtin not : Bool -- Bool     =: [     { case