kempe 0.2.0.6 → 0.2.0.7
raw patch · 15 files changed
+113/−29 lines, 15 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +9/−0
- golden/Golden.hs +1/−0
- kempe.cabal +1/−1
- lib/either.kmp +8/−0
- lib/maybe.kmp +8/−0
- prelude/arith.kmp +15/−0
- src/Kempe/Asm/X86/Type.hs +2/−2
- src/Kempe/Check/Lint.hs +36/−18
- src/Kempe/Error/Warning.hs +8/−0
- src/Kempe/IR.hs +4/−5
- src/Kempe/TyAssign.hs +6/−3
- test/Backend.hs +1/−0
- test/data/mod.kmp +6/−0
- test/golden/mod.out +1/−0
- test/harness/mod.c +7/−0
CHANGELOG.md view
@@ -1,5 +1,14 @@ # kempe +## 0.2.0.7++ * Fix bug in unification+ * Fix bug so that `and` and `or` instructions print correctly for x86 assembler+ * Add lints for `dip(+) +` to `+ +`, (associative dip) `dup and` to `id`, etc.+ * Add lints for `swap swap` and `1 drop` etc.+ * Add `join` for `Maybe` and `Either`+ * Last branch of case statement always falls through (more efficient code)+ ## 0.2.0.6 * Add `absInt` and `chocie` functions to prelude.
golden/Golden.hs view
@@ -26,4 +26,5 @@ , ("test/examples/bool.kmp", "test/harness/bool.c", "test/golden/bool.out") , ("test/examples/const.kmp", "test/harness/const.c", "test/golden/const.out") , ("test/data/badCodegen.kmp", "test/harness/id.c", "test/golden/id.out")+ , ("test/data/mod.kmp", "test/harness/mod.c", "test/golden/mod.out") ]
kempe.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: kempe-version: 0.2.0.6+version: 0.2.0.7 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2020-2021 Vanessa McHale
lib/either.kmp view
@@ -11,6 +11,14 @@ } ] +join : ((Either a) ((Either a) b)) -- ((Either a) b)+ =: [+ { case+ | Left -> Left+ | Right ->+ }+]+ isLeft : ((Either a) b) -- Bool =: [ { case
lib/maybe.kmp view
@@ -8,6 +8,14 @@ } ] +join : (Maybe (Maybe a)) -- (Maybe a)+ =: [+ { case+ | Just ->+ | Nothing -> Nothing+ }+]+ isJust : (Maybe a) -- Bool =: [ { case
prelude/arith.kmp view
@@ -1,6 +1,21 @@ import "prelude/fn.kmp" import "lib/maybe.kmp" +; like haskell; % is rem and mod is... mod+;+; from here: https://hackage.haskell.org/package/ghc-prim-0.7.0/docs/src/GHC-Classes.html#modInt%23+modInt : Int Int -- Int+ =: [ dup2 dup2+ 0 < dip(0 >) &+ dip(0 > dip(0 <) &)+ || + dip(dup dip(%))+ if( dip(dip(dup) 0 !=) swap if(+, nip)+ , drop+ )+ ]++ succInt : Int -- Int =: [ 1 + ]
src/Kempe/Asm/X86/Type.hs view
@@ -279,8 +279,8 @@ pretty (DivR _ r) = i4 ("div" <+> pretty r) pretty Cqo{} = i4 "cqo" 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 (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)
src/Kempe/Check/Lint.hs view
@@ -16,22 +16,40 @@ lintDecl ExtFnDecl{} = Nothing lintDecl (FunDecl _ _ _ _ as) = lintAtoms as +-- TODO: swap drop drop -> drop drop+-- TODO: dup - -> 0++-- a bunch of this is from http://joy-lang.org/papers-on-joy/the-algebra-of-joy/ lintAtoms :: [Atom b b] -> Maybe (Warning b)-lintAtoms [] = Nothing-lintAtoms (a@(Dip l _):a'@Dip{}:_) = Just (DoubleDip l a a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntEq):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntNeq):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ And):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ Or):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ Xor):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordXor):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntTimes):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntPlus):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordPlus):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordTimes):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntXor):_) = Just (SwapBinary l a' a')-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntGt):_) = Just (SwapBinary l a' (AtBuiltin l' IntLt))-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntGeq):_) = Just (SwapBinary l a' (AtBuiltin l' IntLeq))-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntLt):_) = Just (SwapBinary l a' (AtBuiltin l' IntGt))-lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntLeq):_) = Just (SwapBinary l a' (AtBuiltin l' IntGeq))-lintAtoms (_:as) = lintAtoms as+lintAtoms [] = Nothing+lintAtoms (a@(Dip l _):a'@Dip{}:_) = Just (DoubleDip l a a')+lintAtoms (a@(IntLit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a)+lintAtoms (a@(WordLit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a)+lintAtoms (a@(BoolLit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a)+lintAtoms (a@(Int8Lit l _):(AtBuiltin _ Drop):_) = Just (PushDrop l a)+lintAtoms ((Dip l [AtBuiltin _ IntPlus]):a@(AtBuiltin _ IntPlus):_) = Just (DipAssoc l a)+lintAtoms ((Dip l [AtBuiltin _ IntTimes]):a@(AtBuiltin _ IntTimes):_) = Just (DipAssoc l a)+lintAtoms ((Dip l [AtBuiltin _ WordPlus]):a@(AtBuiltin _ WordPlus):_) = Just (DipAssoc l a)+lintAtoms ((Dip l [AtBuiltin _ WordTimes]):a@(AtBuiltin _ WordTimes):_) = Just (DipAssoc l a)+lintAtoms ((Dip l [AtBuiltin _ And]):a@(AtBuiltin _ And):_) = Just (DipAssoc l a)+lintAtoms ((Dip l [AtBuiltin _ Or]):a@(AtBuiltin _ Or):_) = Just (DipAssoc l a)+lintAtoms ((Dip l [AtBuiltin _ IntEq]):a@(AtBuiltin _ IntEq):_) = Just (DipAssoc l a)+lintAtoms ((AtBuiltin l Swap):(AtBuiltin _ Swap):_) = Just (DoubleSwap l)+lintAtoms ((AtBuiltin l Dup):a@(AtBuiltin _ And):_) = Just (Identity l a)+lintAtoms ((AtBuiltin l Dup):a@(AtBuiltin _ Or):_) = Just (Identity l a)+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntEq):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntNeq):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ And):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ Or):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ Xor):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordXor):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntTimes):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntPlus):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordPlus):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ WordTimes):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin _ IntXor):_) = Just (SwapBinary l a' a')+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntGt):_) = Just (SwapBinary l a' (AtBuiltin l' IntLt))+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntGeq):_) = Just (SwapBinary l a' (AtBuiltin l' IntLeq))+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntLt):_) = Just (SwapBinary l a' (AtBuiltin l' IntGt))+lintAtoms ((AtBuiltin l Swap):a'@(AtBuiltin l' IntLeq):_) = Just (SwapBinary l a' (AtBuiltin l' IntGeq))+lintAtoms (_:as) = lintAtoms as
src/Kempe/Error/Warning.hs view
@@ -13,11 +13,19 @@ data Warning a = NameClash a (Name a) | DoubleDip a (Atom a a) (Atom a a) | SwapBinary a (Atom a a) (Atom a a)+ | DoubleSwap a+ | DipAssoc a (Atom a a)+ | Identity a (Atom a a)+ | PushDrop 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()" pretty (SwapBinary l a a') = pretty l <+> squotes ("swap" <+> pretty a) <+> "is" <+> pretty a'+ pretty (DoubleSwap l) = pretty l <+> "double swap"+ pretty (DipAssoc l a) = pretty l <+> "dip(" <> pretty a <> ")" <+> pretty a <+> "is equivalent to" <+> pretty a <+> pretty a <+> "by associativity"+ pretty (Identity l a) = pretty l <+> squotes ("dup" <+> pretty a) <+> "is identity"+ pretty (PushDrop l a) = pretty l <+> squotes (pretty a <+> "drop") <+> "is identity" instance (Pretty a) => Show (Warning a) where show = show . pretty
src/Kempe/IR.hs view
@@ -10,6 +10,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -- strict b/c it's faster according to benchmarks+import Control.Monad (zipWithM) import Control.Monad.State.Strict (State, gets, modify, runState) import Data.Bifunctor (second) import Data.Foldable.Ext@@ -249,15 +250,13 @@ 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+ leaves <- zipWithM (mkLeaf env l) (toList ps) (NE.init ass)+ lastLeaf <- mkLeaf env l (PatternWildcard undefined) (NE.last ass)+ let (switches, meat) = unzip (leaves ++ [lastLeaf]) ret <- newLabel let meat' = (++ [Jump ret]) . toList <$> meat pure $ dataPointerDec decSz : concatMap toList switches ++ concat meat' ++ [Labeled ret] -- TODO: why dataPointerDec decSz??--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
src/Kempe/TyAssign.hs view
@@ -96,6 +96,7 @@ inContext um ty'@(TyVar _ (Name _ (Unique i) _)) = case IM.lookup i um of Just ty@TyVar{} -> inContext (IM.delete i um) ty -- prevent cyclic lookups+ -- TODO: does this need a case for TyApp -> inContext? Just ty -> ty Nothing -> ty' inContext _ ty'@TyBuiltin{} = ty'@@ -122,7 +123,6 @@ unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@(TyNamed _ _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unifyMatch um ((ty@TyBuiltin{}, TyVar _ (Name _ (Unique k) _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@(TyBuiltin _ _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@(TyVar _ _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unifyMatch _ ((ty@TyBuiltin{}, ty'@TyNamed{}):_) = Left (UnificationFailed () ty ty') unifyMatch _ ((ty@TyNamed{}, ty'@TyBuiltin{}):_) = Left (UnificationFailed () ty ty') unifyMatch _ ((ty@TyBuiltin{}, ty'@TyApp{}):_) = Left (UnificationFailed () ty ty')@@ -130,8 +130,11 @@ unifyMatch _ ((ty@TyApp{}, ty'@TyBuiltin{}):_) = Left (UnificationFailed () ty ty') unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@TyApp{}):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unifyMatch um ((ty@TyApp{}, TyVar _ (Name _ (Unique k) _)):tys) = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((TyApp _ ty ty', TyApp _ ty'' ty'''):tys) = unifyMatch um ((ty, ty'') : (ty', ty''') : tys)+unifyMatch um ((TyApp _ ty ty', TyApp _ ty'' ty'''):tys) = unifyMatch um ((ty, ty'') : (ty', ty''') : tys) -- TODO: do we need unifyPrep here? unifyMatch _ ((ty@TyApp{}, ty'@TyNamed{}):_) = Left (UnificationFailed () (void ty) (void ty'))+unifyMatch um ((TyVar _ n@(Name _ (Unique k) _), ty@(TyVar _ n')):tys)+ | n == n' = unifyMatch um tys -- a type variable is always equal to itself, don't bother inserting this!+ | otherwise = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unify :: [(KempeTy (), KempeTy ())] -> Either (Error ()) (IM.IntMap (KempeTy ())) unify = unifyPrep IM.empty@@ -276,7 +279,7 @@ 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 (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
test/Backend.hs view
@@ -26,6 +26,7 @@ , pipelineWorks "examples/factorial.kmp" , pipelineWorks "test/data/mutual.kmp" , pipelineWorks "test/data/multiConstruct.kmp"+ , pipelineWorks "test/data/mod.kmp" , irNoYeet "test/data/export.kmp" , irNoYeet "examples/splitmix.kmp" , irNoYeet "examples/factorial.kmp"
+ test/data/mod.kmp view
@@ -0,0 +1,6 @@+import"prelude/arith.kmp"++mod_kmp : Int Int -- Int+ =: [ modInt ]++%foreign cabi mod_kmp
+ test/golden/mod.out view
@@ -0,0 +1,1 @@+-1
+ test/harness/mod.c view
@@ -0,0 +1,7 @@+#include <stdio.h>++extern int mod_kmp(int, int);++int main(int argc, char *argv[]) {+ printf("%d\n", mod_kmp(2, -3));+}