diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # kempe +## 0.2.0.8 + + * More efficient IR generation; don't copy bytes from a source to the same + destination + * Fix bugs in `case` IR generation + ## 0.2.0.7 * Fix bug in unification 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.7 +version: 0.2.0.8 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2020-2021 Vanessa McHale @@ -84,6 +84,7 @@ Prettyprinter.Debug Data.Foldable.Ext Data.Copointed + Data.Tuple.Ext default-language: Haskell2010 other-extensions: @@ -102,7 +103,6 @@ mtl, microlens, transformers, - extra >=1.7.4, prettyprinter >=1.7.0, composition-prelude >=2.0.2.0, microlens-mtl, diff --git a/lib/gaussian.kmp b/lib/gaussian.kmp --- a/lib/gaussian.kmp +++ b/lib/gaussian.kmp @@ -4,11 +4,7 @@ type Gaussian { Gaussian Int Int } unGaussian : Gaussian -- Int Int - =: [ - { case - | Gaussian -> - } -] + =: [ {case | Gaussian ->} ] grp : a b c -- b a c =: [ dip(swap) ] diff --git a/prelude/arith.kmp b/prelude/arith.kmp --- a/prelude/arith.kmp +++ b/prelude/arith.kmp @@ -8,13 +8,26 @@ =: [ dup2 dup2 0 < dip(0 >) & dip(0 > dip(0 <) &) - || + || dip(dup dip(%)) + ; FIXME: hits the second branch when 2, -3 if( dip(dip(dup) 0 !=) swap if(+, nip) , drop ) ] +divInt : Int Int -- Int + =: [ dup2 + 0 < dip(0 >) & + if( dip(1 -) / 1 - + , dup2 + 0 < dip(0 >) & + if( dip(1 +) / 1 - + ; FIXME: hits second branch when 2, -3 + , / + ) + ) + ] succInt : Int -- Int =: [ 1 + ] @@ -38,14 +51,14 @@ =: [ dup2 < if(drop, nip) ] ; checks for division by zero -safeDiv : Int Int -- (Maybe Int) - =: [ dup isZeroInt - if( drop2 Nothing - , / Just - ) - ] +safeQuot : Int Int -- (Maybe Int) + =: [ dup isZeroInt + if( drop2 Nothing + , / Just + ) + ] -safeMod : Int Int -- (Maybe Int) +safeRem : Int Int -- (Maybe Int) =: [ dup isZeroInt if( drop2 Nothing , % Just diff --git a/src/Data/Tuple/Ext.hs b/src/Data/Tuple/Ext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tuple/Ext.hs @@ -0,0 +1,16 @@ +module Data.Tuple.Ext ( fst3 + , snd3 + , thd3 + , third3 + ) where + +fst3 :: (a, b, c) -> a +fst3 (x, _, _) = x + +snd3 :: (a, b, c) -> b +snd3 (_, x, _) = x + +thd3 :: (a, b, c) -> c +thd3 (_, _, x) = x + +third3 f (x, y, z) = (x, y, f z) diff --git a/src/Kempe/File.hs b/src/Kempe/File.hs --- a/src/Kempe/File.hs +++ b/src/Kempe/File.hs @@ -20,7 +20,7 @@ import Data.Functor (void) import Data.Semigroup ((<>)) import qualified Data.Set as S -import Data.Tuple.Extra (fst3) +import Data.Tuple.Ext (fst3) import Data.Typeable (Typeable) import Kempe.AST import qualified Kempe.Asm.Arm.Type as Arm diff --git a/src/Kempe/IR.hs b/src/Kempe/IR.hs --- a/src/Kempe/IR.hs +++ b/src/Kempe/IR.hs @@ -240,49 +240,53 @@ 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 +-- single-case leaf (we still have the tag but we don't need to check cases etc. +writeAtom env l (Case _ ((_, as) :| [])) = + (dataPointerDec 1:) <$> writeAtoms env l as writeAtom env l (Case (is, _) ls) = let (ps, ass) = NE.unzip ls - decSz = size' env (last is) + decSz = case last is of + TyBuiltin _ TyInt -> 8 + TyBuiltin _ TyWord -> 8 + -- one for constructor tags, etc. + _ -> 1 in do 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?? + pure $ dataPointerDec decSz : switches ++ concat meat' ++ [Labeled ret] -mkLeaf :: SizeEnv -> Bool -> Pattern (ConsAnn MonoStackType) MonoStackType -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM ([Stmt], [Stmt]) +mkLeaf :: SizeEnv -> Bool -> Pattern (ConsAnn MonoStackType) MonoStackType -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM (Stmt, [Stmt]) mkLeaf env l p as = do l' <- newLabel as' <- writeAtoms env l as - let s = patternSwitch env p l' - pure (s, Labeled l' : as') + let (s, mAfter) = patternSwitch env p l' + modAs = case mAfter of + Just dec -> (dec:) + Nothing -> id + pure (s, Labeled l' : modAs as') -patternSwitch :: SizeEnv -> Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt] -patternSwitch _ (PatternBool _ True) l = [MJump (Mem 1 (Reg DataPointer)) l] -patternSwitch _ (PatternBool _ False) l = [MJump (EqByte (Mem 1 (Reg DataPointer)) (ConstTag 0)) l] -patternSwitch _ (PatternWildcard _) l = [Jump l] -- FIXME: what about padding? when standing in for a constructor... -patternSwitch _ (PatternInt _ i) l = [MJump (ExprIntRel IntEqIR (Mem 8 (Reg DataPointer)) (ConstInt $ fromInteger i)) l] +patternSwitch :: SizeEnv -> Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> (Stmt, Maybe Stmt) +patternSwitch _ (PatternBool _ True) l = (MJump (Mem 1 (Reg DataPointer)) l, Nothing) +patternSwitch _ (PatternBool _ False) l = (MJump (EqByte (Mem 1 (Reg DataPointer)) (ConstTag 0)) l, Nothing) +patternSwitch _ (PatternWildcard _) l = (Jump l, Nothing) -- TODO: padding? +patternSwitch _ (PatternInt _ i) l = (MJump (ExprIntRel IntEqIR (Mem 8 (Reg DataPointer)) (ConstInt $ fromInteger i)) l, Nothing) patternSwitch env (PatternCons ann@(ConsAnn _ tag' _) _) l = - let padAt = padBytes env ann + 1 - -- decrement by padAt bytes (to discard padding), then we need to access - -- the tag at [datapointer+padAt] when we check - in [ dataPointerDec padAt, MJump (EqByte (Mem 1 (ExprIntBinOp IntPlusIR (Reg DataPointer) (ConstInt padAt))) (ConstTag tag')) l] - -- FIXME: do we need dataPointerInc padAt at the end? not all - -- constructors will have the same padding, it will fall through... + let padAt = padBytesCons env ann + in (MJump (EqByte (Mem 1 (Reg DataPointer)) (ConstTag tag')) l, Just $ dataPointerDec padAt) + -- FIXME: in addition to flushing padding, we should copy bytes too... -- | Constructors may need to be padded, this computes the number of bytes of -- padding padBytes :: SizeEnv -> ConsAnn MonoStackType -> Int64 padBytes env (ConsAnn sz _ (is, _)) = sz - sizeStack env is - 1 +-- | Patterns for constructors are annotated differently +padBytesCons :: SizeEnv -> ConsAnn MonoStackType -> Int64 +padBytesCons env (ConsAnn sz _ (_, os)) = sz - sizeStack env os - 1 + dipify :: SizeEnv -> Int64 -> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt] dipify _ _ (AtBuiltin ([], _) Drop) = error "Internal error: Ill-typed drop!" dipify env sz (AtBuiltin (is, _) Drop) = @@ -374,12 +378,21 @@ ++ copyBytes (-dipSz) 0 dipSz -- copy bytes back (now from 0 of stack; data pointer has been set) ++ [shiftBack] -dipPush :: Int64 -> Int64 -> Exp -> [Stmt] -dipPush sz sz' e = - -- FIXME: is this right? +dipPush :: Int64 + -> Int64 -- ^ Size of thing being pushed + -> Exp + -> [Stmt] +dipPush sz sz' e | sz > sz' = copyBytes 0 (-sz) sz - ++ push sz' e - ++ copyBytes (-sz) 0 sz -- copy bytes back (data pointer has been incremented already by push) + ++ dataPointerDec sz + : push sz' e + ++ copyBytes (sz'-sz) 0 sz -- copy bytes back (data pointer has been incremented by push) + ++ [dataPointerInc sz] + | otherwise = + copyBytes (sz'-sz) (-sz) sz + ++ dataPointerDec sz + : push sz' e + ++ [dataPointerInc sz] -- for e.g. negation where the stack size stays the same plainShift :: Int64 -> [Stmt] -> [Stmt] @@ -415,10 +428,10 @@ -> Int64 -- ^ src offset -> Int64 -- ^ Number of bytes to copy -> [Stmt] -copyBytes off1 off2 b = +copyBytes off1 off2 b | off1 == off2 = [] + | otherwise = let (b8, b1) = b `quotRem` 8 in copyBytes8 off1 off2 b8 ++ copyBytes1 (off1 + b8 * 8) (off2 + b8 * 8) b1 - -- copyBytesPlain -- | Copy bytes 8 at a time. Note that @b@ must be divisible by 8. copyBytes8 :: Int64 diff --git a/src/Kempe/Inline.hs b/src/Kempe/Inline.hs --- a/src/Kempe/Inline.hs +++ b/src/Kempe/Inline.hs @@ -9,7 +9,7 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe, mapMaybe) import Data.Semigroup ((<>)) -import Data.Tuple.Extra (third3) +import Data.Tuple.Ext (third3) import Kempe.AST import Kempe.Name import Kempe.Unique diff --git a/src/Kempe/Module.hs b/src/Kempe/Module.hs --- a/src/Kempe/Module.hs +++ b/src/Kempe/Module.hs @@ -8,7 +8,7 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as ASCII import qualified Data.Set as S -import Data.Tuple.Extra (fst3, third3) +import Data.Tuple.Ext (fst3, third3) import Kempe.AST import Kempe.Lexer import Kempe.Parser diff --git a/src/Kempe/Monomorphize.hs b/src/Kempe/Monomorphize.hs --- a/src/Kempe/Monomorphize.hs +++ b/src/Kempe/Monomorphize.hs @@ -32,7 +32,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Data.Tuple (swap) -import Data.Tuple.Extra (fst3, snd3, thd3) +import Data.Tuple.Ext (fst3, snd3, thd3) import Kempe.AST import Kempe.AST.Size import Kempe.Error diff --git a/src/Kempe/Parser.y b/src/Kempe/Parser.y --- a/src/Kempe/Parser.y +++ b/src/Kempe/Parser.y @@ -19,7 +19,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.Tuple.Ext (fst3) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Kempe.AST diff --git a/src/Kempe/TyAssign.hs b/src/Kempe/TyAssign.hs --- a/src/Kempe/TyAssign.hs +++ b/src/Kempe/TyAssign.hs @@ -21,7 +21,7 @@ import Data.Semigroup ((<>)) import qualified Data.Set as S import qualified Data.Text as T -import Data.Tuple.Extra (fst3) +import Data.Tuple.Ext (fst3) import Kempe.AST import Kempe.Error import Kempe.Name diff --git a/test/Backend.hs b/test/Backend.hs --- a/test/Backend.hs +++ b/test/Backend.hs @@ -49,11 +49,13 @@ , codegen "test/data/ccall.kmp" , codegen "test/data/mutual.kmp" , codegen "lib/rational.kmp" + , codegen "test/data/regAlloc.kmp" , armCodegen "examples/factorial.kmp" , armCodegen "lib/numbertheory.kmp" , armCodegen "lib/gaussian.kmp" , armCodegen "lib/rational.kmp" , armCodegen "examples/splitmix.kmp" + , armCodegen "test/data/regAlloc.kmp" ] codegen :: FilePath -> TestTree diff --git a/test/data/badCodegen.kmp b/test/data/badCodegen.kmp --- a/test/data/badCodegen.kmp +++ b/test/data/badCodegen.kmp @@ -5,11 +5,15 @@ id1 : Int -- Int =: [ Just {case | Nothing -> 0 | Just ->} ] + ; works with new fallthrough id2 : Int -- Int =: [ Just 0 swap {case | Just -> dip(drop) | Nothing ->} ] - ; Just 0 swap drop swap works +id3 : Int -- Int + =: [ Just 0 swap drop swap ] + %foreign cabi id0 %foreign cabi id1 %foreign cabi id2 +%foreign cabi id3 diff --git a/test/data/mod.kmp b/test/data/mod.kmp --- a/test/data/mod.kmp +++ b/test/data/mod.kmp @@ -3,4 +3,8 @@ mod_kmp : Int Int -- Int =: [ modInt ] +div_kmp : Int Int -- Int + =: [ divInt ] + %foreign cabi mod_kmp +%foreign cabi div_kmp diff --git a/test/data/regAlloc.kmp b/test/data/regAlloc.kmp new file mode 100644 --- /dev/null +++ b/test/data/regAlloc.kmp @@ -0,0 +1,7 @@ +import "prelude/fn.kmp" +import "lib/maybe.kmp" + +constTrue : Bool Bool -- Bool + =: [ & drop True ] + +%foreign kabi constTrue diff --git a/test/golden/gaussian.ir b/test/golden/gaussian.ir --- a/test/golden/gaussian.ir +++ b/test/golden/gaussian.ir @@ -1,9 +1,10 @@ kmp1: -(movtemp datapointer (- (reg datapointer) (int 34))) +(movtemp datapointer (- (reg datapointer) (int 18))) (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))) (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))) @@ -57,11 +58,10 @@ (movmem (- (reg datapointer) (int 17)) (mem [8] (reg datapointer))) (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 34))) +(movtemp datapointer (- (reg datapointer) (int 18))) (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_5 (mem [8] (reg datapointer))) (movtemp datapointer (- (reg datapointer) (int 8))) (movtemp t_6 (mem [8] (reg datapointer))) @@ -83,11 +83,12 @@ (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 -34))) +(movtemp datapointer (+ (reg datapointer) (int -18))) (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 16))) (movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) (movtemp datapointer (+ (reg datapointer) (int 8))) (movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 32)))) @@ -120,7 +121,7 @@ (ret) kmp3: -(movtemp datapointer (- (reg datapointer) (int 25))) +(movtemp datapointer (- (reg datapointer) (int 9))) (movtemp t_17 (mem [8] (reg datapointer))) (movmem (reg datapointer) (~ (reg t_17))) (movtemp datapointer (+ (reg datapointer) (int 8))) diff --git a/test/harness/bool.c b/test/harness/bool.c --- a/test/harness/bool.c +++ b/test/harness/bool.c @@ -9,4 +9,3 @@ printf("%d\n", not(false)); printf("%d", eq(true, false)); } - diff --git a/test/harness/id.c b/test/harness/id.c --- a/test/harness/id.c +++ b/test/harness/id.c @@ -3,9 +3,11 @@ extern int id0(int); extern int id1(int); extern int id2(int); +extern int id3(int); int main(int argc, char *argv[]) { printf("%d\n", id0(4)); printf("%d\n", id1(4)); - printf("%d", id2(4)); + printf("%d\n", id2(4)); + printf("%d", id3(4)); } diff --git a/test/harness/mod.c b/test/harness/mod.c --- a/test/harness/mod.c +++ b/test/harness/mod.c @@ -1,7 +1,10 @@ #include extern int mod_kmp(int, int); +extern int div_kmp(int, int); int main(int argc, char *argv[]) { printf("%d\n", mod_kmp(2, -3)); + printf("%d\n", div_kmp(2, -3)); + printf("%d\n", div_kmp(-2, 3)); }