kempe 0.2.0.7 → 0.2.0.8
raw patch · 20 files changed
+125/−59 lines, 20 filesdep ~extraPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: extra
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- kempe.cabal +2/−2
- lib/gaussian.kmp +1/−5
- prelude/arith.kmp +21/−8
- src/Data/Tuple/Ext.hs +16/−0
- src/Kempe/File.hs +1/−1
- src/Kempe/IR.hs +43/−30
- src/Kempe/Inline.hs +1/−1
- src/Kempe/Module.hs +1/−1
- src/Kempe/Monomorphize.hs +1/−1
- src/Kempe/Parser.y +1/−1
- src/Kempe/TyAssign.hs +1/−1
- test/Backend.hs +2/−0
- test/data/badCodegen.kmp +5/−1
- test/data/mod.kmp +4/−0
- test/data/regAlloc.kmp +7/−0
- test/golden/gaussian.ir +6/−5
- test/harness/bool.c +0/−1
- test/harness/id.c +3/−1
- test/harness/mod.c +3/−0
CHANGELOG.md view
@@ -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
kempe.cabal view
@@ -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,
lib/gaussian.kmp view
@@ -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) ]
prelude/arith.kmp view
@@ -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
+ src/Data/Tuple/Ext.hs view
@@ -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)
src/Kempe/File.hs view
@@ -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
src/Kempe/IR.hs view
@@ -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
src/Kempe/Inline.hs view
@@ -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
src/Kempe/Module.hs view
@@ -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
src/Kempe/Monomorphize.hs view
@@ -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
src/Kempe/Parser.y view
@@ -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
src/Kempe/TyAssign.hs view
@@ -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
test/Backend.hs view
@@ -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
test/data/badCodegen.kmp view
@@ -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
test/data/mod.kmp view
@@ -3,4 +3,8 @@ mod_kmp : Int Int -- Int =: [ modInt ] +div_kmp : Int Int -- Int+ =: [ divInt ]+ %foreign cabi mod_kmp+%foreign cabi div_kmp
+ test/data/regAlloc.kmp view
@@ -0,0 +1,7 @@+import "prelude/fn.kmp"+import "lib/maybe.kmp"++constTrue : Bool Bool -- Bool+ =: [ & drop True ]++%foreign kabi constTrue
test/golden/gaussian.ir view
@@ -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)))
test/harness/bool.c view
@@ -9,4 +9,3 @@ printf("%d\n", not(false)); printf("%d", eq(true, false)); }-
test/harness/id.c view
@@ -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)); }
test/harness/mod.c view
@@ -1,7 +1,10 @@ #include <stdio.h> 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)); }