packages feed

kempe 0.2.0.3 → 0.2.0.4

raw patch · 12 files changed

+82/−82 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Kempe.AST: prettyTypedDecl :: (Pretty a, Pretty b) => KempeDecl c a b -> Doc ann
- Kempe.AST: prettyFancyModule :: Declarations () (ConsAnn (StackType ())) (StackType ()) -> Doc ann
+ Kempe.AST: prettyFancyModule :: (Pretty a, Pretty b) => Declarations c (ConsAnn a) b -> Doc ann
- Kempe.AST: prettyTyped :: Atom (StackType ()) (StackType ()) -> Doc ann
+ Kempe.AST: prettyTyped :: (Pretty a, Pretty b) => Atom a b -> Doc ann
- Kempe.AST: prettyTypedModule :: Declarations () (StackType ()) (StackType ()) -> Doc ann
+ Kempe.AST: prettyTypedModule :: (Pretty a, Pretty b) => Declarations c a b -> Doc ann

Files

CHANGELOG.md view
@@ -1,5 +1,11 @@ # kempe +## 0.2.0.4++  * Kind-check external function declarations+  * Fix bug in inliner where functions within `dip(...)`s were not inlined+  * Fix unification bug where solved constraints were not back-substituted correctly.+ ## 0.2.0.3    * GHC 8.0.2 and 8.2.2
README.md view
@@ -6,7 +6,9 @@ Inspiration is primarily from [Mirth](https://github.com/mirth-lang/mirth).  See manual-[here](http://hackage.haskell.org/package/kempe/src/docs/manual.pdf).+[here](http://hackage.haskell.org/package/kempe/src/docs/manual.pdf). There is+also a tour of the compiler available+[here](http://vmchale.com/static/original/compiler.pdf).  ## Installation
bench/Bench.hs view
@@ -2,7 +2,6 @@  import           Control.Exception         (throw) import           Criterion.Main-import           Data.Bifunctor            (Bifunctor, bimap) import qualified Data.ByteString.Lazy      as BSL import qualified Data.Text                 as T import qualified Data.Text.Lazy.IO         as TLIO@@ -27,9 +26,6 @@ import           System.IO                 (hFlush) import           System.IO.Temp            (withSystemTempFile) -bivoid :: Bifunctor p => p a b -> p () ()-bivoid = bimap (const ()) (const ())- main :: IO () main =     defaultMain [ env (BSL.readFile "test/data/lex.kmp") $ \contents ->@@ -46,7 +42,6 @@                       , 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 eitherMod $ \ e ->                     bgroup "Pattern match exhaustiveness checker"
kempe.cabal view
@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            kempe-version:         0.2.0.3+version:         0.2.0.4 license:         BSD-3-Clause license-file:    LICENSE copyright:       Copyright: (c) 2020-2021 Vanessa McHale
lib/rational.kmp view
@@ -2,18 +2,18 @@ import"lib/numbertheory.kmp"  ; Slightly suspect rational based on 'Int' type-type Rational { Rational Int Int }+type Rational a { Rational a a } -unRational : Rational -- Int Int+unRational : (Rational a) -- a a            =: [ { case | Rational -> } ] -multRat : Rational Rational -- Rational+multRat : (Rational Int) (Rational Int) -- (Rational Int)         =: [ dip(unRational) unRational dip(swap *) * Rational reduce ] -reduce : Rational -- Rational+reduce : (Rational Int) -- (Rational Int)        =: [ unRational dup2 gcd dup dip(swap dip(/)) / Rational ] -addRat : Rational Rational -- Rational+addRat : (Rational Int) (Rational Int) -- (Rational Int)        =: [ dip(unRational) unRational dip(swap)             dup2 * dip(swap dip(swap) * dip(*) +)             Rational reduce
src/Kempe/AST.hs view
@@ -25,6 +25,7 @@                  , prettyFancyModule                  , prettyModule                  , flipStackType+                 , prettyTypedDecl                  -- * I resent this...                  , voidStackType                  ) where@@ -79,7 +80,7 @@     pretty PatternWildcard{}  = "_"     pretty (PatternCons _ tn) = pretty tn -prettyTypedPattern :: Pattern (StackType ()) (StackType ()) -> Doc ann+prettyTypedPattern :: (Pretty a) => Pattern a b -> Doc ann prettyTypedPattern (PatternCons ty tn) = parens (pretty tn <+> ":" <+> pretty ty) prettyTypedPattern p                   = pretty p @@ -98,10 +99,10 @@ prettyLeaf :: Pattern c a -> [Atom c a] -> Doc ann prettyLeaf p as = pipe <+> pretty p <+> "->" <+> align (fillSep (fmap pretty as)) -prettyTypedLeaf :: Pattern (StackType ()) (StackType ()) -> [Atom (StackType ()) (StackType ())] -> Doc ann+prettyTypedLeaf :: (Pretty a, Pretty b) => Pattern a b -> [Atom a b] -> Doc ann prettyTypedLeaf p as = pipe <+> prettyTypedPattern p <+> "->" <+> align (fillSep (fmap prettyTyped as)) -prettyTyped :: Atom (StackType ()) (StackType ()) -> Doc ann+prettyTyped :: (Pretty a, Pretty b) => Atom a b -> 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)@@ -243,10 +244,13 @@ prettyDecls :: Declarations a c b -> Doc ann prettyDecls = prettyDeclarationsGeneral pretty -prettyFancyModule :: Declarations () (ConsAnn (StackType ())) (StackType ()) -> Doc ann+prettyFancyModule :: (Pretty a, Pretty b) => Declarations c (ConsAnn a) b -> Doc ann prettyFancyModule = prettyTypedModule . fmap (first consTy) -prettyTypedModule :: Declarations () (StackType ()) (StackType ()) -> Doc ann+prettyTypedDecl :: (Pretty a, Pretty b) => KempeDecl c a b -> Doc ann+prettyTypedDecl = prettyKempeDecl prettyTyped++prettyTypedModule :: (Pretty a, Pretty b) => Declarations c a b -> Doc ann prettyTypedModule = prettyDeclarationsGeneral prettyTyped  prettyModule :: Module a c b -> Doc ann
src/Kempe/AST/Size.hs view
@@ -15,7 +15,6 @@                       -- * Sizing bits                       , SizeEnv                       , Size-                      , cSize                       , size                       , size'                       , sizeStack@@ -82,7 +81,7 @@ type Size = [Int64] -> Int64 type SizeEnv = IM.IntMap Size --- the kempe sizing system is kind of fucked (it mostly works tho)+-- 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 -> Size@@ -94,11 +93,8 @@ 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+size' env = ($ []) . size env  sizeStack :: SizeEnv -> [KempeTy a] -> Int64 sizeStack env = getSum . foldMap (Sum . size' env)
src/Kempe/IR.hs view
@@ -97,8 +97,6 @@ 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
src/Kempe/Inline.hs view
@@ -29,6 +29,8 @@                 else foldMap (inlineAtom declName) $ findDecl a n           inlineAtom declName (If l as as') =             [If l (inlineAtoms declName as) (inlineAtoms declName as')]+          inlineAtom declName (Dip l as) =+            [Dip l (inlineAtoms declName as)]           inlineAtom declName (Case l ls) =             let (ps, ass) = NE.unzip ls                 in [Case l (NE.zip ps $ fmap (inlineAtoms declName) ass)]
src/Kempe/Module.hs view
@@ -22,7 +22,6 @@ yeetIO :: Exception e => Either e a -> IO a yeetIO = either throwIO pure --- 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
src/Kempe/TyAssign.hs view
@@ -28,7 +28,7 @@ import           Kempe.Unique import           Lens.Micro                 (Lens', over) import           Lens.Micro.Mtl             (modifying, (.=))-import           Prettyprinter              (Doc, Pretty (pretty), hardline, indent, vsep, (<+>))+import           Prettyprinter              (Doc, Pretty (pretty), vsep, (<+>)) import           Prettyprinter.Debug import           Prettyprinter.Ext @@ -113,11 +113,11 @@     in unifyMatch um $ (ty'', ty'''):tys  unifyMatch :: UnifyMap -> [(KempeTy (), KempeTy ())] -> Either (Error ()) (IM.IntMap (KempeTy ()))-unifyMatch _ []                                                             = Right mempty+unifyMatch _ []                                                              = Right mempty unifyMatch um ((ty@(TyBuiltin _ b0), ty'@(TyBuiltin _ b1)):tys) | b0 == b1   = unifyPrep um tys                                                                 | otherwise  = Left (UnificationFailed () ty ty') unifyMatch um ((ty@(TyNamed _ n0), ty'@(TyNamed _ n1)):tys) | n0 == n1       = unifyPrep um tys-                                                    | otherwise      = Left (UnificationFailed () (void ty) (void ty'))+                                                            | otherwise      = Left (UnificationFailed () (void ty) (void ty')) unifyMatch um ((ty@(TyNamed _ _), TyVar  _ (Name _ (Unique k) _)):tys)       = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@(TyNamed _ _)):tys)        = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unifyMatch um ((ty@TyBuiltin{}, TyVar  _ (Name _ (Unique k) _)):tys)         = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys@@ -130,7 +130,7 @@ unifyMatch _ ((ty@TyApp{}, ty'@TyBuiltin{}):_)                               = Left (UnificationFailed () ty ty') unifyMatch um ((TyVar _ (Name _ (Unique k) _), ty@TyApp{}):tys)              = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys unifyMatch um ((ty@TyApp{}, TyVar  _ (Name _ (Unique k) _)):tys)             = IM.insert k ty <$> unifyPrep (IM.insert k ty um) tys-unifyMatch um ((TyApp _ ty ty', TyApp _ ty'' ty'''):tys)                     = unifyMatch um ((ty, ty'') : (ty', ty''') : tys) -- TODO: I think this is right?+unifyMatch um ((TyApp _ ty ty', TyApp _ ty'' ty'''):tys)                     = unifyMatch um ((ty, ty'') : (ty', ty''') : tys) unifyMatch _ ((ty@TyApp{}, ty'@TyNamed{}):_)                                 = Left (UnificationFailed () (void ty) (void ty'))  unify :: [(KempeTy (), KempeTy ())] -> Either (Error ()) (IM.IntMap (KempeTy ()))@@ -410,10 +410,10 @@     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?+    _ <- mergeStackTypes sig inferred     when (inferred `lessGeneral` sig) $         throwError $ LessGeneral () sig inferred-tyInsert ExtFnDecl{} = pure () -- TODO: kind-check+tyInsert (ExtFnDecl _ _ ins outs _) = traverse_ kindOf (void <$> ins ++ outs) tyInsert Export{} = pure ()  tyModule :: Declarations a c b -> TypeM () ()@@ -529,9 +529,10 @@ 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+        Just ty'@TyVar{}       -> substConstraints (IM.delete k tys) ty' -- TODO: this is to prevent cyclic lookups: is it right?+        Just (TyApp l ty0 ty1) -> TyApp l (substConstraints tys ty0) (substConstraints tys ty1)+        Just ty'               -> ty'+        Nothing                -> ty substConstraints tys (TyApp l ty ty')                   =     TyApp l (substConstraints tys ty) (substConstraints tys ty')
test/golden/gaussian.ir view
@@ -1,11 +1,6 @@  kmp1:-(movtemp datapointer (- (reg datapointer) (int 17)))-(ret)--kmp2:-(movtemp datapointer (- (reg datapointer) (int 17)))-(call kmp1)+(movtemp datapointer (- (reg datapointer) (int 34))) (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 25)))) (movmem (+ (reg datapointer) (int 16)) (mem [1] (+ (reg datapointer) (int 33))))@@ -29,35 +24,7 @@ (movtemp datapointer (+ (reg datapointer) (int 1))) (ret) -kmp3:-(movtemp datapointer (- (reg datapointer) (int 17)))-(call kmp1)-(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 17))))-(movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 25))))-(movmem (+ (reg datapointer) (int 16)) (mem [1] (+ (reg datapointer) (int 33))))-(movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 24))))-(movmem (- (reg datapointer) (int 24)) (mem [8] (- (reg datapointer) (int 16))))-(movmem (- (reg datapointer) (int 16)) (mem [8] (- (reg datapointer) (int 0))))-(movtemp datapointer (- (reg datapointer) (int 8)))-(movtemp t_5 (mem [8] (reg datapointer)))-(movtemp datapointer (- (reg datapointer) (int 8)))-(movtemp t_6 (mem [8] (reg datapointer)))-(movmem (reg datapointer) (* (reg t_6) (reg t_5)))-(movtemp datapointer (- (reg datapointer) (int 8)))-(movtemp t_7 (mem [8] (reg datapointer)))-(movtemp datapointer (- (reg datapointer) (int 8)))-(movtemp t_8 (mem [8] (reg datapointer)))-(movmem (reg datapointer) (* (reg t_8) (reg t_7)))-(movtemp datapointer (+ (reg datapointer) (int 8)))-(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8))))-(movtemp t_9 (mem [8] (reg datapointer)))-(movtemp datapointer (- (reg datapointer) (int 8)))-(movtemp t_10 (mem [8] (reg datapointer)))-(movmem (reg datapointer) (- (reg t_10) (reg t_9)))-(movtemp datapointer (+ (reg datapointer) (int 8)))-(ret)--kmp4:+kmp2: (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 9)))) (movmem (+ (reg datapointer) (int 16)) (mem [1] (- (reg datapointer) (int 1))))@@ -92,16 +59,15 @@ (movmem (- (reg datapointer) (int 17)) (mem [8] (- (reg datapointer) (int 0)))) (movmem (- (reg datapointer) (int 9)) (mem [8] (+ (reg datapointer) (int 8)))) (movmem (- (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 16))))-(movtemp datapointer (- (reg datapointer) (int 17)))-(call kmp1)+(movtemp datapointer (- (reg datapointer) (int 34))) (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 25)))) (movmem (+ (reg datapointer) (int 16)) (mem [1] (+ (reg datapointer) (int 33)))) (movtemp datapointer (- (reg datapointer) (int 16)))-(movtemp t_11 (mem [8] (reg datapointer)))+(movtemp t_5 (mem [8] (reg datapointer))) (movtemp datapointer (- (reg datapointer) (int 8)))-(movtemp t_12 (mem [8] (reg datapointer)))-(movmem (reg datapointer) (* (reg t_12) (reg t_11)))+(movtemp t_6 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (* (reg t_6) (reg t_5))) (movtemp datapointer (+ (reg datapointer) (int 8))) (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) (movtemp datapointer (+ (reg datapointer) (int 8)))@@ -109,24 +75,55 @@ (movmem (- (reg datapointer) (int 16)) (mem [8] (- (reg datapointer) (int 8)))) (movmem (- (reg datapointer) (int 8)) (mem [8] (- (reg datapointer) (int 0)))) (movtemp datapointer (- (reg datapointer) (int 16)))+(movtemp t_7 (mem [8] (reg datapointer)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_8 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (* (reg t_8) (reg t_7)))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8))))+(movtemp t_9 (mem [8] (reg datapointer)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_10 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (+ (reg t_10) (reg t_9)))+(movtemp datapointer (- (reg datapointer) (int 0)))+(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 25))))+(movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 33))))+(movmem (+ (reg datapointer) (int 16)) (mem [8] (+ (reg datapointer) (int 41))))+(movmem (+ (reg datapointer) (int 24)) (mem [1] (+ (reg datapointer) (int 49))))+(movtemp datapointer (- (reg datapointer) (int 34)))+(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8))))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 32))))+(movmem (- (reg datapointer) (int 32)) (mem [8] (- (reg datapointer) (int 24))))+(movmem (- (reg datapointer) (int 24)) (mem [8] (- (reg datapointer) (int 0))))+(movtemp datapointer (- (reg datapointer) (int 16)))+(movtemp t_11 (mem [8] (reg datapointer)))+(movtemp datapointer (- (reg datapointer) (int 8)))+(movtemp t_12 (mem [8] (reg datapointer)))+(movmem (reg datapointer) (* (reg t_12) (reg t_11)))+(movtemp datapointer (+ (reg datapointer) (int 8)))+(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8))))+(movtemp datapointer (- (reg datapointer) (int 0))) (movtemp t_13 (mem [8] (reg datapointer))) (movtemp datapointer (- (reg datapointer) (int 8))) (movtemp t_14 (mem [8] (reg datapointer))) (movmem (reg datapointer) (* (reg t_14) (reg t_13))) (movtemp datapointer (+ (reg datapointer) (int 8)))-(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8))))+(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 16))))+(movmem (+ (reg datapointer) (int 8)) (mem [8] (+ (reg datapointer) (int 24))))+(movtemp datapointer (- (reg datapointer) (int 16))) (movtemp t_15 (mem [8] (reg datapointer))) (movtemp datapointer (- (reg datapointer) (int 8))) (movtemp t_16 (mem [8] (reg datapointer)))-(movmem (reg datapointer) (+ (reg t_16) (reg t_15)))-(call kmp3)+(movmem (reg datapointer) (- (reg t_16) (reg t_15)))+(movtemp datapointer (+ (reg datapointer) (int 8))) (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) (movtemp datapointer (+ (reg datapointer) (int 8))) (movmem (reg datapointer) (tag 0x0)) (movtemp datapointer (+ (reg datapointer) (int 1))) (ret) -kmp5:+kmp3: (movtemp datapointer (- (reg datapointer) (int 25))) (movtemp t_17 (mem [8] (reg datapointer))) (movmem (reg datapointer) (~ (reg t_17)))@@ -135,8 +132,8 @@ (movtemp datapointer (+ (reg datapointer) (int 1))) (ret) -export add {Gaussian_1 Gaussian_1 -- Gaussian_1} kmp2+export add {Gaussian_1 Gaussian_1 -- Gaussian_1} kmp1 -export conjugate {Gaussian_1 -- Gaussian_1} kmp5+export conjugate {Gaussian_1 -- Gaussian_1} kmp3 -export mult {Gaussian_1 Gaussian_1 -- Gaussian_1} kmp4+export mult {Gaussian_1 Gaussian_1 -- Gaussian_1} kmp2