diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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" diff --git a/kempe.cabal b/kempe.cabal --- a/kempe.cabal +++ b/kempe.cabal @@ -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 diff --git a/lib/rational.kmp b/lib/rational.kmp --- a/lib/rational.kmp +++ b/lib/rational.kmp @@ -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 diff --git a/src/Kempe/AST.hs b/src/Kempe/AST.hs --- a/src/Kempe/AST.hs +++ b/src/Kempe/AST.hs @@ -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 diff --git a/src/Kempe/AST/Size.hs b/src/Kempe/AST/Size.hs --- a/src/Kempe/AST/Size.hs +++ b/src/Kempe/AST/Size.hs @@ -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) diff --git a/src/Kempe/IR.hs b/src/Kempe/IR.hs --- a/src/Kempe/IR.hs +++ b/src/Kempe/IR.hs @@ -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 diff --git a/src/Kempe/Inline.hs b/src/Kempe/Inline.hs --- a/src/Kempe/Inline.hs +++ b/src/Kempe/Inline.hs @@ -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)] diff --git a/src/Kempe/Module.hs b/src/Kempe/Module.hs --- a/src/Kempe/Module.hs +++ b/src/Kempe/Module.hs @@ -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 diff --git a/src/Kempe/TyAssign.hs b/src/Kempe/TyAssign.hs --- a/src/Kempe/TyAssign.hs +++ b/src/Kempe/TyAssign.hs @@ -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') diff --git a/test/golden/gaussian.ir b/test/golden/gaussian.ir --- a/test/golden/gaussian.ir +++ b/test/golden/gaussian.ir @@ -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