diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # kempe +## 0.1.1.2 + + * Case statements with a single branch are plain and efficient. + * Add `safeDiv` and `safeMod` to `prelude/arith.kmp` + ## 0.1.1.1 * Performance improvements under the hood (use `IntSet`s for liveness diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -36,3 +36,9 @@ This is less of an impediment than it sounds like. * Cyclic module imports are not detected * Modules (imports) are kind of defective + +### Comparison + +You may wish to use [Mirth](https://github.com/mirth-lang/mirth/) or +[Factor](https://factorcode.org/) instead. Mirth is statically typed (similar to +Kempe) but less mature. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -5,10 +5,10 @@ import Data.Bifunctor (Bifunctor, bimap) import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T +import Kempe.Asm.Liveness import Kempe.Asm.X86 import Kempe.Asm.X86.ControlFlow import Kempe.Asm.X86.Linear -import Kempe.Asm.X86.Liveness import Kempe.Check.Pattern import Kempe.File import Kempe.IR @@ -99,6 +99,7 @@ , 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) + , bench "Object file (lib/rational.kmp)" $ nfIO (compile "lib/rational.kmp" "/tmp/rational.o" False) ] ] where parsedM = parseProcess "test/data/ty.kmp" diff --git a/docs/manual.pdf b/docs/manual.pdf Binary files a/docs/manual.pdf and b/docs/manual.pdf differ 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.1.1.1 +version: 0.1.1.2 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2020 Vanessa McHale @@ -56,7 +56,7 @@ Kempe.IR.Opt Kempe.Asm.X86 Kempe.Asm.X86.ControlFlow - Kempe.Asm.X86.Liveness + Kempe.Asm.Liveness Kempe.Asm.X86.Linear hs-source-dirs: src @@ -70,10 +70,12 @@ Kempe.Error.Warning Kempe.AST.Size Kempe.Asm.X86.Type + Kempe.Asm.Type Kempe.IR.Type Kempe.Proc.Nasm Prettyprinter.Ext Data.Foldable.Ext + Data.Copointed default-language: Haskell2010 other-extensions: diff --git a/lib/rational.kmp b/lib/rational.kmp --- a/lib/rational.kmp +++ b/lib/rational.kmp @@ -8,7 +8,7 @@ =: [ { case | Rational -> } ] multRat : Rational Rational -- Rational - =: [ dip(unRational) unRational dip(swap *) * Rational ] + =: [ dip(unRational) unRational dip(swap *) * Rational reduce ] reduce : Rational -- Rational =: [ unRational dup2 gcd dup dip(swap dip(/)) / Rational ] diff --git a/prelude/arith.kmp b/prelude/arith.kmp --- a/prelude/arith.kmp +++ b/prelude/arith.kmp @@ -1,4 +1,5 @@ import "prelude/fn.kmp" +import "lib/maybe.kmp" succInt : Int -- Int =: [ 1 + ] @@ -15,3 +16,18 @@ minInt : Int Int -- Int =: [ dup2 < if(drop, nip) ] + +; checks for division by zero +safeDiv : Int Int -- (Maybe Int) + =: [ dup isZeroInt + if( drop2 Nothing + , / Just + ) + ] + +safeMod : Int Int -- (Maybe Int) + =: [ dup isZeroInt + if( drop2 Nothing + , % Just + ) + ] diff --git a/src/Data/Copointed.hs b/src/Data/Copointed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Copointed.hs @@ -0,0 +1,5 @@ +module Data.Copointed ( Copointed (..) + ) where + +class Copointed p where + copoint :: p a -> a diff --git a/src/Kempe/Asm/Liveness.hs b/src/Kempe/Asm/Liveness.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Liveness.hs @@ -0,0 +1,67 @@ +-- FIXME: this module is slow + +-- | Based on the Appel book. +module Kempe.Asm.Liveness ( Liveness + , reconstruct + ) where + +import Control.Composition (thread) +import Data.Copointed +-- this seems to be faster +import qualified Data.IntMap.Lazy as IM +import qualified Data.IntSet as IS +import Data.Semigroup ((<>)) +import Kempe.Asm.Type + +emptyLiveness :: Liveness +emptyLiveness = Liveness IS.empty IS.empty + +-- need: succ for a node + +initLiveness :: Copointed p => [p ControlAnn] -> LivenessMap +initLiveness = IM.fromList . fmap (\asm -> let x = copoint asm in (node x, (x, emptyLiveness))) + +type LivenessMap = IM.IntMap (ControlAnn, Liveness) + +-- | All program points accessible from some node. +succNode :: ControlAnn -- ^ 'ControlAnn' associated w/ node @n@ + -> LivenessMap + -> [Liveness] -- ^ 'Liveness' associated with 'succNode' @n@ +succNode x ns = + let conns = conn x + in fmap (snd . flip lookupNode ns) conns + +lookupNode :: Int -> LivenessMap -> (ControlAnn, Liveness) +lookupNode = IM.findWithDefault (error "Internal error: failed to look up instruction") + +done :: LivenessMap -> LivenessMap -> Bool +done n0 n1 = {-# SCC "done" #-} and $ zipWith (\(_, l) (_, l') -> l == l') (IM.elems n0) (IM.elems n1) -- should be safe b/c n0, n1 must have same length + +-- order in which to inspect nodes during liveness analysis +inspectOrder :: Copointed p => [p ControlAnn] -> [Int] +inspectOrder = fmap (node . copoint) -- don't need to reverse because thread goes in opposite order + +reconstruct :: (Copointed p, Functor p) => [p ControlAnn] -> [p Liveness] +reconstruct asms = {-# SCC "reconstructL" #-} fmap (fmap lookupL) asms + where l = {-# SCC "mkLiveness" #-} mkLiveness asms + lookupL x = snd $ lookupNode (node x) l + +mkLiveness :: Copointed p => [p ControlAnn] -> LivenessMap +mkLiveness asms = liveness is (initLiveness asms) + where is = inspectOrder asms + +liveness :: [Int] -> LivenessMap -> LivenessMap +liveness is nSt = + if done nSt nSt' + then nSt + else liveness is nSt' + where nSt' = {-# SCC "iterNodes" #-} iterNodes is nSt + +iterNodes :: [Int] -> LivenessMap -> LivenessMap +iterNodes is = thread (fmap stepNode is) + +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 IS.\\ defsNode c) + out' = IS.unions (fmap ins (succNode c ns)) diff --git a/src/Kempe/Asm/Type.hs b/src/Kempe/Asm/Type.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Type.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Kempe.Asm.Type ( ControlAnn (..) + , Liveness (..) + ) where + +import Control.DeepSeq (NFData) +import qualified Data.IntSet as IS +import Data.Semigroup ((<>)) +import GHC.Generics (Generic) +import Prettyprinter (Pretty (pretty), braces, punctuate, (<+>)) + +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 . IS.toList + +-- | Control-flow annotations +data ControlAnn = ControlAnn { node :: !Int + , conn :: [Int] + , usesNode :: IS.IntSet + , defsNode :: IS.IntSet + } deriving (Generic, NFData) diff --git a/src/Kempe/Asm/X86/ControlFlow.hs b/src/Kempe/Asm/X86/ControlFlow.hs --- a/src/Kempe/Asm/X86/ControlFlow.hs +++ b/src/Kempe/Asm/X86/ControlFlow.hs @@ -9,6 +9,7 @@ import qualified Data.IntSet as IS import qualified Data.Map as M import Data.Semigroup ((<>)) +import Kempe.Asm.Type import Kempe.Asm.X86.Type -- map of labels by node diff --git a/src/Kempe/Asm/X86/Linear.hs b/src/Kempe/Asm/X86/Linear.hs --- a/src/Kempe/Asm/X86/Linear.hs +++ b/src/Kempe/Asm/X86/Linear.hs @@ -15,6 +15,7 @@ import Data.Maybe (fromMaybe) import Data.Semigroup ((<>)) import qualified Data.Set as S +import Kempe.Asm.Type import Kempe.Asm.X86.Type import Lens.Micro (Lens') import Lens.Micro.Mtl (modifying, (.=)) diff --git a/src/Kempe/Asm/X86/Liveness.hs b/src/Kempe/Asm/X86/Liveness.hs deleted file mode 100644 --- a/src/Kempe/Asm/X86/Liveness.hs +++ /dev/null @@ -1,66 +0,0 @@ --- FIXME: this module is slow - --- | Based on the Appel book. -module Kempe.Asm.X86.Liveness ( Liveness - , reconstruct - ) where - -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 Kempe.Asm.X86.Type - -emptyLiveness :: Liveness -emptyLiveness = Liveness IS.empty IS.empty - --- need: succ for a node - -initLiveness :: [X86 reg ControlAnn] -> LivenessMap -initLiveness = IM.fromList . fmap (\asm -> let x = ann asm in (node x, (x, emptyLiveness))) - -type LivenessMap = IM.IntMap (ControlAnn, Liveness) - --- | All program points accessible from some node. -succNode :: ControlAnn -- ^ 'ControlAnn' associated w/ node @n@ - -> LivenessMap - -> [Liveness] -- ^ 'Liveness' associated with 'succNode' @n@ -succNode x ns = - let conns = conn x - in fmap (snd . flip lookupNode ns) conns - -lookupNode :: Int -> LivenessMap -> (ControlAnn, Liveness) -lookupNode = IM.findWithDefault (error "Internal error: failed to look up instruction") - -done :: LivenessMap -> LivenessMap -> Bool -done n0 n1 = {-# SCC "done" #-} and $ zipWith (\(_, l) (_, l') -> l == l') (IM.elems n0) (IM.elems n1) -- should be safe b/c n0, n1 must have same length - --- order in which to inspect nodes during liveness analysis -inspectOrder :: [X86 reg ControlAnn] -> [Int] -inspectOrder = fmap (node . ann) -- don't need to reverse because thread goes in opposite order - -reconstruct :: [X86 reg ControlAnn] -> [X86 reg Liveness] -reconstruct asms = {-# SCC "reconstructL" #-} fmap (fmap lookupL) asms - where l = {-# SCC "mkLiveness" #-} mkLiveness asms - lookupL x = snd $ lookupNode (node x) l - -mkLiveness :: [X86 reg ControlAnn] -> LivenessMap -mkLiveness asms = liveness is (initLiveness asms) - where is = inspectOrder asms - -liveness :: [Int] -> LivenessMap -> LivenessMap -liveness is nSt = - if done nSt nSt' - then nSt - else liveness is nSt' - where nSt' = {-# SCC "iterNodes" #-} iterNodes is nSt - -iterNodes :: [Int] -> LivenessMap -> LivenessMap -iterNodes is = thread (fmap stepNode is) - -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 IS.\\ defsNode c) - out' = IS.unions (fmap ins (succNode c ns)) diff --git a/src/Kempe/Asm/X86/Type.hs b/src/Kempe/Asm/X86/Type.hs --- a/src/Kempe/Asm/X86/Type.hs +++ b/src/Kempe/Asm/X86/Type.hs @@ -7,8 +7,6 @@ , Addr (..) , AbsReg (..) , X86Reg (..) - , ControlAnn (..) - , Liveness (..) , Label , prettyAsm , prettyDebugAsm @@ -17,31 +15,19 @@ import Control.DeepSeq (NFData) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import Data.Copointed import Data.Int (Int64, Int8) -import qualified Data.IntSet as IS import Data.Semigroup ((<>)) import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.Lazy.Encoding as TL import Data.Word (Word8) import GHC.Generics (Generic) -import Prettyprinter (Doc, Pretty (pretty), braces, brackets, colon, concatWith, hardline, indent, punctuate, (<+>)) +import Kempe.Asm.Type +import Prettyprinter (Doc, Pretty (pretty), brackets, colon, concatWith, hardline, indent, (<+>)) import Prettyprinter.Ext type Label = Word -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 . IS.toList - -data ControlAnn = ControlAnn { node :: !Int - , conn :: [Int] - , usesNode :: IS.IntSet - , defsNode :: IS.IntSet - } deriving (Generic, NFData) - -- currently just has 64-bit and 8-bit registers data X86Reg = R8 | R9 @@ -211,6 +197,9 @@ | NegR { ann :: a, rSrc :: reg } | NasmMacro0 { ann :: a, macroName :: BS.ByteString } deriving (Generic, NFData, Functor) + +instance Copointed (X86 reg) where + copoint = ann i4 :: Doc ann -> Doc ann i4 = indent 4 diff --git a/src/Kempe/IR.hs b/src/Kempe/IR.hs --- a/src/Kempe/IR.hs +++ b/src/Kempe/IR.hs @@ -7,7 +7,7 @@ ) where import Data.Foldable (toList, traverse_) -import Data.List.NonEmpty (NonEmpty) +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) @@ -241,6 +241,12 @@ writeAtom env _ (AtCons ann@(ConsAnn _ tag' _) _) = pure $ dataPointerInc (padBytes env ann) : push 1 (ConstTag tag') writeAtom _ _ (Case ([], _) _) = error "Internal error: Ill-typed case statement?!" +-- single-case leaf +writeAtom env l (Case (is, _) ((_, as) :| [])) = + let decSz = size' env (last is) + in do + nextAs <- writeAtoms env l as + pure $ dataPointerDec decSz : nextAs writeAtom env l (Case (is, _) ls) = let (ps, ass) = NE.unzip ls decSz = size' env (last is) diff --git a/src/Kempe/Pipeline.hs b/src/Kempe/Pipeline.hs --- a/src/Kempe/Pipeline.hs +++ b/src/Kempe/Pipeline.hs @@ -9,10 +9,10 @@ import Data.Typeable (Typeable) import Kempe.AST import Kempe.AST.Size +import Kempe.Asm.Liveness import Kempe.Asm.X86 import Kempe.Asm.X86.ControlFlow import Kempe.Asm.X86.Linear -import Kempe.Asm.X86.Liveness import Kempe.Asm.X86.Type import Kempe.Check.Restrict import Kempe.IR diff --git a/test/Backend.hs b/test/Backend.hs --- a/test/Backend.hs +++ b/test/Backend.hs @@ -2,8 +2,8 @@ ) where import Control.DeepSeq (deepseq) +import Kempe.Asm.Liveness import Kempe.Asm.X86.ControlFlow -import Kempe.Asm.X86.Liveness import Kempe.Inline import Kempe.Module import Kempe.Monomorphize diff --git a/test/golden/gaussian.ir b/test/golden/gaussian.ir --- a/test/golden/gaussian.ir +++ b/test/golden/gaussian.ir @@ -1,12 +1,6 @@ kmp1: (movtemp datapointer (- (reg datapointer) (int 17))) -(mjump (=b (mem [1] (+ (reg datapointer) (int 0))) (tag 0x0)) kmp4) - -kmp4: -(j kmp5) - -kmp5: (ret) kmp2: @@ -29,12 +23,6 @@ (movmem (+ (reg datapointer) (int 14)) (mem [1] (+ (reg datapointer) (int 31)))) (movmem (+ (reg datapointer) (int 15)) (mem [1] (+ (reg datapointer) (int 32)))) (movmem (+ (reg datapointer) (int 16)) (mem [1] (+ (reg datapointer) (int 33)))) -(mjump (=b (mem [1] (+ (reg datapointer) (int 0))) (tag 0x0)) kmp6) - -kmp6: -(j kmp7) - -kmp7: (movmem (- (reg datapointer) (int 0)) (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)))) @@ -56,14 +44,7 @@ (ret) kmp3: -(movtemp datapointer (- (reg datapointer) (int 17))) -(mjump (=b (mem [1] (+ (reg datapointer) (int 0))) (tag 0x0)) kmp8) - -kmp8: -(j kmp9) - -kmp9: -(movtemp datapointer (- (reg datapointer) (int 8))) +(movtemp datapointer (- (reg datapointer) (int 25))) (movtemp t_5 (mem [8] (reg datapointer))) (movmem (reg datapointer) (~ (reg t_5))) (movtemp datapointer (+ (reg datapointer) (int 8)))