kempe 0.1.1.3 → 0.2.0.0
raw patch · 35 files changed
+1259/−157 lines, 35 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Kempe.Asm.Arm.ControlFlow: ControlAnn :: !Int -> [Int] -> IntSet -> IntSet -> ControlAnn
+ Kempe.Asm.Arm.ControlFlow: [conn] :: ControlAnn -> [Int]
+ Kempe.Asm.Arm.ControlFlow: [defsNode] :: ControlAnn -> IntSet
+ Kempe.Asm.Arm.ControlFlow: [node] :: ControlAnn -> !Int
+ Kempe.Asm.Arm.ControlFlow: [usesNode] :: ControlAnn -> IntSet
+ Kempe.Asm.Arm.ControlFlow: data ControlAnn
+ Kempe.Asm.Arm.ControlFlow: mkControlFlow :: [Arm AbsReg ()] -> [Arm AbsReg ControlAnn]
+ Kempe.Asm.Arm.Linear: allocRegs :: [Arm AbsReg Liveness] -> [Arm ArmReg ()]
+ Kempe.Asm.Arm.Trans: irToAarch64 :: SizeEnv -> WriteSt -> [Stmt] -> [Arm AbsReg ()]
+ Kempe.File: armCompile :: FilePath -> FilePath -> Bool -> IO ()
+ Kempe.File: armFile :: FilePath -> IO ()
+ Kempe.File: dumpArm :: Typeable a => Int -> Declarations a c b -> Doc ann
+ Kempe.Pipeline: armAlloc :: Typeable a => Int -> Declarations a c b -> [Arm ArmReg ()]
+ Kempe.Pipeline: armParsed :: Typeable a => Int -> Declarations a c b -> [Arm AbsReg ()]
Files
- CHANGELOG.md +5/−0
- README.md +5/−5
- bench/Bench.hs +23/−13
- docs/manual.pdf binary
- examples/splitmix.kmp +3/−3
- kempe.cabal +13/−3
- run/Main.hs +31/−11
- src/Kempe/Asm/Arm/ControlFlow.hs +160/−0
- src/Kempe/Asm/Arm/Linear.hs +139/−0
- src/Kempe/Asm/Arm/Opt.hs +10/−0
- src/Kempe/Asm/Arm/Trans.hs +177/−0
- src/Kempe/Asm/Arm/Type.hs +347/−0
- src/Kempe/Asm/Pretty.hs +14/−0
- src/Kempe/Asm/X86/ControlFlow.hs +8/−4
- src/Kempe/Asm/X86/Linear.hs +4/−2
- src/Kempe/Asm/X86/Trans.hs +22/−45
- src/Kempe/Asm/X86/Type.hs +38/−18
- src/Kempe/Debug.hs +17/−0
- src/Kempe/File.hs +25/−4
- src/Kempe/IR.hs +3/−3
- src/Kempe/IR/Monad.hs +36/−0
- src/Kempe/IR/Opt.hs +13/−3
- src/Kempe/IR/Type.hs +12/−11
- src/Kempe/Pipeline.hs +19/−6
- src/Kempe/Proc/As.hs +26/−0
- src/Kempe/TyAssign.hs +2/−2
- src/Prettyprinter/Ext.hs +7/−0
- test/Backend.hs +37/−3
- test/Golden.hs +16/−2
- test/Harness.hs +15/−1
- test/examples/const.kmp +4/−0
- test/examples/splitmix.kmp +3/−3
- test/golden/const.out +1/−0
- test/golden/gaussian.ir +17/−15
- test/harness/const.c +7/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ # kempe +## 0.2.0.0++ * Add aarch64 backend+ * Change type of shifts, they no longer take an `Int8` as the second argument.+ ## 0.1.1.3 * Tweak some RTS flags for faster performance
README.md view
@@ -1,7 +1,7 @@ # Kempe -Kempe is a stack-based language and toy compiler for x86_64. It requires the-[nasm](https://nasm.us/) assembler.+Kempe is a stack-based language and toy compiler for x86_64 and aarch64. It requires the+[nasm](https://nasm.us/) assembler when targeting x86_64. Inspiration is primarily from [Mirth](https://github.com/mirth-lang/mirth). @@ -13,7 +13,7 @@ Installation is via [cabal-install](https://www.haskell.org/cabal/): ```-cabal install kempe --constraint='kempe -no-par'+cabal install kempe ``` For shell completions put the following in your `~/.bashrc` or@@ -34,8 +34,8 @@ export large arguments (i.e. structs) passed by value. This is less of an impediment than it sounds like.- * Cyclic module imports are not detected- * Modules (imports) are kind of defective+ * Cyclic imports are not detected+ * Imports are kind of defective ### Comparison
bench/Bench.hs view
@@ -6,8 +6,8 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import Kempe.Asm.Liveness-import Kempe.Asm.X86.ControlFlow-import Kempe.Asm.X86.Linear+import qualified Kempe.Asm.X86.ControlFlow as X86+import qualified Kempe.Asm.X86.Linear as X86 import Kempe.Asm.X86.Trans import Kempe.Check.Pattern import Kempe.File@@ -21,7 +21,7 @@ import Kempe.Pipeline import Kempe.Shuttle import Kempe.TyAssign-import Prettyprinter (defaultLayoutOptions, layoutPretty)+import Prettyprinter (Doc, defaultLayoutOptions, layoutPretty) import Prettyprinter.Render.Text (renderStrict) bivoid :: Bifunctor p => p a b -> p () ()@@ -72,8 +72,8 @@ ] , env x86Env $ \ ~(s, f) -> bgroup "Control flow graph"- [ bench "X86 (examples/factorial.kmp)" $ nf mkControlFlow f- , bench "X86 (examples/splitmix.kmp)" $ nf mkControlFlow s+ [ bench "X86 (examples/factorial.kmp)" $ nf X86.mkControlFlow f+ , bench "X86 (examples/splitmix.kmp)" $ nf X86.mkControlFlow s ] , env cfEnv $ \ ~(s, f, n, r) -> bgroup "Liveness analysis"@@ -84,9 +84,9 @@ ] , env absX86 $ \ ~(s, f, n) -> bgroup "Register allocation"- [ bench "X86/linear (examples/factorial.kmp)" $ nf allocRegs f- , bench "X86/linear (examples/splitmix.kmp)" $ nf allocRegs s- , bench "X86/linear (lib/numbertheory.kmp)" $ nf allocRegs n+ [ bench "X86/linear (examples/factorial.kmp)" $ nf X86.allocRegs f+ , bench "X86/linear (examples/splitmix.kmp)" $ nf X86.allocRegs s+ , bench "X86/linear (lib/numbertheory.kmp)" $ nf X86.allocRegs n ] , bgroup "Pipeline" [ bench "Validate (examples/factorial.kmp)" $ nfIO (tcFile "examples/factorial.kmp")@@ -96,6 +96,8 @@ , bench "Generate assembly (examples/splitmix.kmp)" $ nfIO (writeAsm "examples/splitmix.kmp") , bench "Generate assembly (lib/numbertheory.kmp)" $ nfIO (writeAsm "lib/numbertheory.kmp") , bench "Generate assembly (lib/gaussian.kmp)" $ nfIO (writeAsm "lib/gaussian.kmp")+ , bench "Generate arm assembly (examples/factorial.kmp)" $ nfIO (writeArmAsm "examples/factorial.kmp")+ , bench "Generate arm assembly (lib/gaussian.kmp)" $ nfIO (writeArmAsm "lib/gaussian.kmp") -- , bench "Generate assembly (lib/rational.kmp)" $ nfIO (writeAsm "lib/rational.kmp") , 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)@@ -131,10 +133,10 @@ x86Env = (,) <$> splitmixX86 <*> facX86 numX86 = uncurry x86Parsed <$> num ratX86 = uncurry x86Parsed <$> rat- facX86Cf = mkControlFlow <$> facX86- splitmixX86Cf = mkControlFlow <$> splitmixX86- numX86Cf = mkControlFlow <$> numX86- ratX86Cf = mkControlFlow <$> ratX86+ facX86Cf = X86.mkControlFlow <$> facX86+ splitmixX86Cf = X86.mkControlFlow <$> splitmixX86+ numX86Cf = X86.mkControlFlow <$> numX86+ ratX86Cf = X86.mkControlFlow <$> ratX86 cfEnv = (,,,) <$> splitmixX86Cf <*> facX86Cf <*> numX86Cf <*> ratX86Cf facAbsX86 = reconstruct <$> facX86Cf splitmixAbsX86 = reconstruct <$> splitmixX86Cf@@ -148,4 +150,12 @@ writeAsm fp = do res <- parseProcess fp pure $ renderText $ uncurry dumpX86 res- where renderText = renderStrict . layoutPretty defaultLayoutOptions++renderText :: Doc ann -> T.Text+renderText = renderStrict . layoutPretty defaultLayoutOptions++writeArmAsm :: FilePath+ -> IO T.Text+writeArmAsm fp = do+ res <- parseProcess fp+ pure $ renderText $ uncurry dumpArm res
docs/manual.pdf view
binary file changed (214002 → 215362 bytes)
examples/splitmix.kmp view
@@ -3,9 +3,9 @@ ; given a seed, return a random value and the new seed next : Word -- Word Word =: [ 0x9e3779b97f4a7c15u +~ dup- dup 30i8 >>~ xoru 0xbf58476d1ce4e5b9u *~- dup 27i8 >>~ xoru 0x94d049bb133111ebu *~- dup 31i8 >>~ xoru+ dup 30u >>~ xoru 0xbf58476d1ce4e5b9u *~+ dup 27u >>~ xoru 0x94d049bb133111ebu *~+ dup 31u >>~ xoru ] %foreign kabi next
kempe.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: kempe-version: 0.1.1.3+version: 0.2.0.0 license: BSD-3-Clause license-file: LICENSE copyright: Copyright: (c) 2020-2021 Vanessa McHale@@ -50,10 +50,13 @@ Kempe.Check.Pattern Kempe.IR Kempe.IR.Opt+ Kempe.Asm.Liveness Kempe.Asm.X86.Trans Kempe.Asm.X86.ControlFlow- Kempe.Asm.Liveness Kempe.Asm.X86.Linear+ Kempe.Asm.Arm.Trans+ Kempe.Asm.Arm.ControlFlow+ Kempe.Asm.Arm.Linear hs-source-dirs: src other-modules:@@ -65,10 +68,16 @@ Kempe.Error Kempe.Error.Warning Kempe.AST.Size+ Kempe.Asm.Arm.Type+ Kempe.Asm.Arm.Opt Kempe.Asm.X86.Type Kempe.Asm.Type+ Kempe.Asm.Pretty Kempe.IR.Type+ Kempe.IR.Monad Kempe.Proc.Nasm+ Kempe.Proc.As+ Kempe.Debug Prettyprinter.Ext Data.Foldable.Ext Data.Copointed@@ -209,7 +218,8 @@ process, temporary, filepath,- tasty-golden+ tasty-golden,+ tasty-hunit if impl(ghc >=8.0) ghc-options:
run/Main.hs view
@@ -15,9 +15,13 @@ import Prettyprinter.Render.Text (renderIO) import System.Exit (ExitCode (ExitFailure), exitWith) import System.IO (stdout)+import System.Info (arch) +data Arch = Aarch64+ | X64+ data Command = TypeCheck !FilePath- | Compile !FilePath !(Maybe FilePath) !Bool !Bool !Bool -- TODO: take arch on cli+ | Compile !FilePath !(Maybe FilePath) !Arch !Bool !Bool !Bool | Format !FilePath | Lint !FilePath @@ -35,14 +39,16 @@ yeetIO = either throwIO pure run :: Command -> IO ()-run (TypeCheck fp) = either throwIO pure =<< tcFile fp-run (Lint fp) = maybe (pure ()) throwIO =<< warnFile fp-run (Compile _ Nothing _ False False) = putStrLn "No output file specified!"-run (Compile fp (Just o) dbg False False) = compile fp o dbg-run (Compile fp Nothing False True False) = irFile fp-run (Compile fp Nothing False False True) = x86File fp-run (Format fp) = fmt fp-run _ = putStrLn "Invalid combination of CLI options. Try kc --help" *> exitWith (ExitFailure 1)+run (TypeCheck fp) = either throwIO pure =<< tcFile fp+run (Lint fp) = maybe (pure ()) throwIO =<< warnFile fp+run (Compile _ Nothing _ _ False False) = putStrLn "No output file specified!"+run (Compile fp (Just o) X64 dbg False False) = compile fp o dbg+run (Compile fp (Just o) Aarch64 dbg False False) = armCompile fp o dbg+run (Compile fp Nothing _ False True False) = irFile fp+run (Compile fp Nothing X64 False False True) = x86File fp+run (Compile fp Nothing Aarch64 False False True) = armFile fp+run (Format fp) = fmt fp+run _ = putStrLn "Invalid combination of CLI options. Try kc --help" *> exitWith (ExitFailure 1) kmpFile :: Parser FilePath kmpFile = argument str@@ -62,6 +68,20 @@ <> short 'g' <> help "Include debug symbols") +archFlag :: Parser Arch+archFlag = fmap parseArch $ optional $ strOption+ (long "arch"+ <> metavar "ARCH"+ <> help "Target architecture (x64 or aarch64)"+ <> completer (listCompleter ["x64", "aarch64"]))+ where parseArch :: Maybe String -> Arch+ parseArch str' = case (str', arch) of+ (Nothing, "aarch64") -> Aarch64+ (Nothing, "x86_64") -> X64+ (Just "aarch64", _) -> Aarch64+ (Just "x64", _) -> X64+ _ -> error "Failed to parse architecture! Try one of x64, aarch64"+ irSwitch :: Parser Bool irSwitch = switch (long "dump-ir"@@ -88,12 +108,12 @@ <|> compileP where tcP = TypeCheck <$> kmpFile- compileP = Compile <$> kmpFile <*> exeFile <*> debugSwitch <*> irSwitch <*> asmSwitch+ compileP = Compile <$> kmpFile <*> exeFile <*> archFlag <*> debugSwitch <*> irSwitch <*> asmSwitch wrapper :: ParserInfo Command wrapper = info (helper <*> versionMod <*> commandP) (fullDesc- <> progDesc "Kempe language compiler, x86_64 backend"+ <> progDesc "Kempe language compiler for X86_64 and Aarch64" <> header "Kempe - a stack-based language") versionMod :: Parser (a -> a)
+ src/Kempe/Asm/Arm/ControlFlow.hs view
@@ -0,0 +1,160 @@+module Kempe.Asm.Arm.ControlFlow ( mkControlFlow+ , ControlAnn (..)+ ) where++import Control.Monad.State.Strict (State, evalState, gets, modify)+import Data.Bifunctor (first, second)+import Data.Functor (($>))+import qualified Data.IntSet as IS+import qualified Data.Map as M+import Data.Semigroup ((<>))+import Kempe.Asm.Arm.Type+import Kempe.Asm.Type++-- map of labels by node+type FreshM = State (Int, M.Map Label Int)++runFreshM :: FreshM a -> a+runFreshM = flip evalState (0, mempty)++mkControlFlow :: [Arm AbsReg ()] -> [Arm AbsReg ControlAnn]+mkControlFlow instrs = runFreshM (broadcasts instrs *> addControlFlow instrs)++getFresh :: FreshM Int+getFresh = gets fst <* modify (first (+1))++lookupLabel :: Label -> FreshM Int+lookupLabel l = gets (M.findWithDefault (error "Internal error in control-flow graph: node label not in map.") l . snd)++broadcast :: Int -> Label -> FreshM ()+broadcast i l = modify (second (M.insert l i))++singleton :: AbsReg -> IS.IntSet+singleton = maybe IS.empty IS.singleton . toInt++-- | Can't be called on abstract registers i.e. 'DataPointer'+-- This is kinda sus but it allows us to use an 'IntSet' for liveness analysis.+toInt :: AbsReg -> Maybe Int+toInt (AllocReg i) = Just i+toInt _ = Nothing++fromList :: [AbsReg] -> IS.IntSet+fromList = foldMap singleton++addrRegs :: Addr AbsReg -> IS.IntSet+addrRegs (Reg r) = singleton r+addrRegs (AddRRPlus r r') = fromList [r, r']+addrRegs (AddRCPlus r _) = singleton r++-- | Annotate instructions with a unique node name and a list of all possible+-- destinations.+addControlFlow :: [Arm AbsReg ()] -> FreshM [Arm AbsReg ControlAnn]+addControlFlow [] = pure []+addControlFlow ((Label _ l):asms) = do+ { i <- lookupLabel l+ ; (f, asms') <- next asms+ ; pure (Label (ControlAnn i (f []) IS.empty IS.empty) l : asms')+ }+addControlFlow ((BranchCond _ l c):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (BranchCond (ControlAnn i (f [l_i]) IS.empty IS.empty) l c : asms')+ }+addControlFlow ((BranchZero _ r l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (BranchZero (ControlAnn i (f [l_i]) (singleton r) IS.empty) r l : asms')+ }+addControlFlow ((BranchNonzero _ r l):asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; l_i <- lookupLabel l+ ; pure (BranchNonzero (ControlAnn i (f [l_i]) (singleton r) IS.empty) r l : asms')+ }+addControlFlow ((BranchLink _ l):asms) = do+ { i <- getFresh+ ; nextAsms <- addControlFlow asms+ ; l_i <- lookupLabel l+ ; pure (BranchLink (ControlAnn i [l_i] IS.empty IS.empty) l : nextAsms)+ }+addControlFlow (Ret{}:asms) = do+ { i <- getFresh+ ; nextAsms <- addControlFlow asms+ ; pure (Ret (ControlAnn i [] IS.empty IS.empty) : nextAsms)+ }+addControlFlow (asm:asms) = do+ { i <- getFresh+ ; (f, asms') <- next asms+ ; pure ((asm $> ControlAnn i (f []) (uses asm) (defs asm)) : asms')+ }++uses :: Arm AbsReg ann -> IS.IntSet+uses (MovRR _ _ r) = singleton r+uses (AddRR _ _ r r') = fromList [r, r']+uses (SubRR _ _ r r') = fromList [r, r']+uses (SubRC _ _ r _) = singleton r+uses (LShiftLRR _ _ r r') = fromList [r, r']+uses (LShiftRRR _ _ r r') = fromList [r, r']+uses (BranchZero _ r _) = singleton r+uses (MovRK _ r _ _) = singleton r -- since MovRK only affects 16 bits, it depends on the previous r to be live!+uses (BranchNonzero _ r _) = singleton r+uses (AddRC _ _ r _) = singleton r+uses (MulRR _ _ r r') = fromList [r, r']+uses (AndRR _ _ r r') = fromList [r, r']+uses (OrRR _ _ r r') = fromList [r, r']+uses (SignedDivRR _ _ r r') = fromList [r, r']+uses (UnsignedDivRR _ _ r r') = fromList [r, r']+uses (CmpRR _ r r') = fromList [r, r']+uses (CmpRC _ r _) = singleton r+uses (Load _ _ a) = addrRegs a+uses (LoadByte _ _ a) = addrRegs a+uses (Neg _ _ r) = singleton r+uses (MulSubRRR _ _ r r' r'') = fromList [r, r', r'']+uses (XorRR _ _ r r') = fromList [r, r']+uses (Store _ r a) = singleton r <> addrRegs a+uses (StoreByte _ r a) = singleton r <> addrRegs a+uses _ = mempty++defs :: Arm AbsReg ann -> IS.IntSet+defs (MovRR _ r _) = singleton r+defs (MovRC _ r _) = singleton r+defs (MovRWord _ r _) = singleton r+defs (MovRK _ r _ _) = singleton r+defs (AddRR _ r _ _) = singleton r+defs (SubRR _ r _ _) = singleton r+defs (AddRC _ r _ _) = singleton r+defs (SubRC _ r _ _) = singleton r+defs (LoadByte _ r _) = singleton r+defs (LShiftRRR _ r _ _) = singleton r+defs (MulSubRRR _ r _ _ _) = singleton r+defs (LShiftLRR _ r _ _) = singleton r+defs (AndRR _ r _ _) = singleton r+defs (OrRR _ r _ _) = singleton r+defs (MulRR _ r _ _) = singleton r+defs (Load _ r _) = singleton r+defs (SignedDivRR _ r _ _) = singleton r+defs (UnsignedDivRR _ r _ _) = singleton r+defs (LoadLabel _ r _) = singleton r+defs (CSet _ r _) = singleton r+defs (Neg _ r _) = singleton r+defs (XorRR _ r _ _) = singleton r+defs _ = mempty++next :: [Arm AbsReg ()] -> FreshM ([Int] -> [Int], [Arm AbsReg ControlAnn])+next asms = do+ nextAsms <- addControlFlow asms+ case nextAsms of+ [] -> pure (id, [])+ (asm:_) -> pure ((node (ann asm) :), nextAsms)++-- | Construct map assigning labels to their node name.+broadcasts :: [Arm reg ()] -> FreshM [Arm reg ()]+broadcasts [] = pure []+broadcasts (asm@(Label _ l):asms) = do+ { i <- getFresh+ ; broadcast i l+ ; (asm :) <$> broadcasts asms+ }+broadcasts (asm:asms) = (asm :) <$> broadcasts asms
+ src/Kempe/Asm/Arm/Linear.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Linear scan register allocator+module Kempe.Asm.Arm.Linear ( allocRegs+ ) where++import Control.Monad.State.Strict (State, evalState, gets)+import Data.Foldable (traverse_)+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import Data.Maybe (fromMaybe)+import Data.Semigroup ((<>))+import qualified Data.Set as S+import Kempe.Asm.Arm.Type+import Kempe.Asm.Type+import Lens.Micro (Lens')+import Lens.Micro.Mtl (modifying, (.=))++data AllocSt = AllocSt { allocs :: IM.IntMap ArmReg -- ^ Already allocated registers+ , free :: S.Set ArmReg -- TODO: IntSet here?+ }++allocsLens :: Lens' AllocSt (IM.IntMap ArmReg)+allocsLens f s = fmap (\x -> s { allocs = x }) (f (allocs s))++freeLens :: Lens' AllocSt (S.Set ArmReg)+freeLens f s = fmap (\x -> s { free = x }) (f (free s))++-- | Mark all registers as free (at the beginning).+allFree :: AllocSt+allFree = AllocSt mempty allReg++allReg :: S.Set ArmReg+allReg = S.fromList [X0 .. X29] S.\\ S.singleton X19 -- don't allocate to x19 (data pointer)++type AllocM = State AllocSt++runAllocM :: AllocM a -> a+runAllocM = flip evalState allFree++allocRegs :: [Arm AbsReg Liveness] -> [Arm ArmReg ()]+allocRegs = runAllocM . traverse allocReg++new :: Liveness -> IS.IntSet+new (Liveness i o) = o IS.\\ i++done :: Liveness -> IS.IntSet+done (Liveness i o) = i IS.\\ o++freeDone :: Liveness -> AllocM ()+freeDone l = traverse_ freeReg (IS.toList absRs)+ where absRs = done l++freeReg :: Int -> AllocM ()+freeReg i = do+ xR <- findReg i+ modifying allocsLens (IM.delete i)+ modifying freeLens (S.insert xR)++assignReg :: Int -> ArmReg -> AllocM ()+assignReg i xr =+ modifying allocsLens (IM.insert i xr)++newReg :: AllocM ArmReg+newReg = do+ rSt <- gets free+ let (res', newSt) = fromMaybe err $ S.minView rSt+ -- register is no longer free+ freeLens .= newSt+ pure res'++ where err = error "(internal error) No register available."++findReg :: Int -> AllocM ArmReg+findReg i = gets+ (IM.findWithDefault (error $ "Internal error in register allocator: unfound register" ++ show i) i . allocs)++useRegInt :: Liveness -> Int -> AllocM ArmReg+useRegInt l i =+ if i `IS.member` new l+ then do { res' <- newReg ; assignReg i res' ; pure res' }+ else findReg i++useAddr :: Liveness -> Addr AbsReg -> AllocM (Addr ArmReg)+useAddr l (Reg r) = Reg <$> useReg l r+useAddr l (AddRCPlus r c) = AddRCPlus <$> useReg l r <*> pure c+useAddr l (AddRRPlus r0 r1) = AddRRPlus <$> useReg l r0 <*> useReg l r1++useReg :: Liveness -> AbsReg -> AllocM ArmReg+useReg l (AllocReg i) = useRegInt l i+useReg _ DataPointer = pure X19+useReg _ LinkReg = pure X30+useReg _ CArg0 = pure X0+useReg _ CArg1 = pure X1 -- shouldn't clobber anything because it's just used in function wrapper to push onto the kempe stack+useReg _ CArg2 = pure X2+useReg _ CArg3 = pure X3+useReg _ CArg4 = pure X4+useReg _ CArg5 = pure X5+useReg _ CArg6 = pure X6+useReg _ CArg7 = pure X7+useReg _ StackPtr = pure SP++allocReg :: Arm AbsReg Liveness -> AllocM (Arm ArmReg ())+allocReg Ret{} = pure $ Ret ()+allocReg (Branch _ l) = pure $ Branch () l+allocReg (BranchLink _ l) = pure $ BranchLink () l+allocReg (BranchCond _ l c) = pure $ BranchCond () l c+allocReg (Label _ l) = pure $ Label () l+allocReg (BSLabel _ l) = pure $ BSLabel () l+allocReg (GnuMacro _ m) = pure $ GnuMacro () m+allocReg (BranchZero l r lbl) = (BranchZero () <$> useReg l r <*> pure lbl) <* freeDone l+allocReg (AddRR l r0 r1 r2) = (AddRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (SubRR l r0 r1 r2) = (SubRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (MulRR l r0 r1 r2) = (MulRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (SignedDivRR l r0 r1 r2) = (SignedDivRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (UnsignedDivRR l r0 r1 r2) = (UnsignedDivRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (LShiftLRR l r0 r1 r2) = (LShiftLRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (LShiftRRR l r0 r1 r2) = (LShiftRRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (AndRR l r0 r1 r2) = (AndRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (AddRC l r0 r1 c) = (AddRC () <$> useReg l r0 <*> useReg l r1 <*> pure c) <* freeDone l+allocReg (SubRC l r0 r1 c) = (SubRC () <$> useReg l r0 <*> useReg l r1 <*> pure c) <* freeDone l+allocReg (MovRC l r0 c) = (MovRC () <$> useReg l r0 <*> pure c) <* freeDone l+allocReg (MovRWord l r0 w) = (MovRWord () <$> useReg l r0 <*> pure w) <* freeDone l+allocReg (Load l r a) = (Load () <$> useReg l r <*> useAddr l a) <* freeDone l+allocReg (LoadLabel l r lbl) = (LoadLabel () <$> useReg l r <*> pure lbl) <* freeDone l+allocReg (MovRR l r0 r1) = (MovRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (CSet l r c) = (CSet () <$> useReg l r <*> pure c) <* freeDone l+allocReg (Store l r a) = (Store () <$> useReg l r <*> useAddr l a) <* freeDone l+allocReg (StoreByte l r a) = (StoreByte () <$> useReg l r <*> useAddr l a) <* freeDone l+allocReg (CmpRR l r0 r1) = (CmpRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (Neg l r0 r1) = (Neg () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (MulSubRRR l r0 r1 r2 r3) = (MulSubRRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2 <*> useReg l r3) <* freeDone l+allocReg (LoadByte l r a) = (LoadByte () <$> useReg l r <*> useAddr l a) <* freeDone l+allocReg (XorRR l r0 r1 r2) = (XorRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (OrRR l r0 r1 r2) = (OrRR () <$> useReg l r0 <*> useReg l r1 <*> useReg l r2) <* freeDone l+allocReg (BranchNonzero l r lbl) = (BranchNonzero () <$> useReg l r <*> pure lbl) <* freeDone l+allocReg (CmpRC l r c) = (CmpRC () <$> useReg l r <*> pure c) <* freeDone l+allocReg (MovRK l r0 c s) = (MovRK () <$> useReg l r0 <*> pure c <*> pure s) <* freeDone l
+ src/Kempe/Asm/Arm/Opt.hs view
@@ -0,0 +1,10 @@+module Kempe.Asm.Arm.Opt ( optimizeArm+ ) where++import Kempe.Asm.Arm.Type++optimizeArm :: Eq reg => [Arm reg a] -> [Arm reg a]+optimizeArm ((Store l r a):(Load _ r' a'):as) | r == r' && a == a' = optimizeArm (Store l r a : as)+optimizeArm ((StoreByte l r a):(LoadByte _ r' a'):as) | r == r' && a == a' = optimizeArm (StoreByte l r a : as)+optimizeArm (a:as) = a : optimizeArm as+optimizeArm [] = []
+ src/Kempe/Asm/Arm/Trans.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Asm.Arm.Trans ( irToAarch64+ ) where++import Data.Bits (shiftR, (.&.))+import Data.Foldable.Ext (foldMapA)+import Data.Int (Int64)+import Data.List (scanl')+import Kempe.AST.Size+import Kempe.Asm.Arm.Type+import Kempe.IR.Monad+import qualified Kempe.IR.Type as IR++irToAarch64 :: SizeEnv -> IR.WriteSt -> [IR.Stmt] -> [Arm AbsReg ()]+irToAarch64 env w = runWriteM w . foldMapA (irEmit env)++toAbsReg :: IR.Temp -> AbsReg+toAbsReg (IR.Temp8 i) = AllocReg i+toAbsReg (IR.Temp64 i) = AllocReg i+toAbsReg IR.DataPointer = DataPointer++storeSize :: Int64 -> (reg -> Addr reg -> Arm reg ())+storeSize 1 = StoreByte ()+storeSize 8 = Store ()+storeSize _ = error "Load not supported or incoherent."++loadSize :: Int64 -> (reg -> Addr reg -> Arm reg ())+loadSize 1 = LoadByte ()+loadSize 8 = Load ()+loadSize _ = error "Load not supported or incoherent."++pushLink :: [Arm AbsReg ()]+pushLink = [SubRC () StackPtr StackPtr 16, Store () LinkReg (Reg StackPtr)]++popLink :: [Arm AbsReg ()]+popLink = [Load () LinkReg (Reg StackPtr), AddRC () StackPtr StackPtr 16]++irEmit :: SizeEnv -> IR.Stmt -> WriteM [Arm AbsReg ()]+irEmit _ (IR.Jump l) = pure [Branch () l]+irEmit _ IR.Ret = pure [Ret ()]+irEmit _ (IR.KCall l) = pure (pushLink ++ BranchLink () l : popLink) -- TODO: think more?+irEmit _ (IR.Labeled l) = pure [Label () l]+irEmit _ (IR.WrapKCall Kabi (_, _) n l) = pure $ [BSLabel () n] ++ pushLink ++ [BranchLink () l] ++ popLink ++ [Ret ()]+irEmit env (IR.WrapKCall Cabi (is, [o]) n l) | all (\i -> size' env i <= 8) is && size' env o <= 8 && length is <= 8 = do+ { let sizes = fmap (size' env) is+ ; let offs = scanl' (+) 0 sizes+ ; let totalSize = sizeStack env is+ ; let argRegs = [CArg0, CArg1, CArg2, CArg3, CArg4, CArg5, CArg6, CArg7]+ ; pure $ [BSLabel () n] ++ pushLink ++ [LoadLabel () DataPointer "kempe_data", GnuMacro () "calleesave"] ++ zipWith3 (\r sz i -> storeSize sz r (AddRCPlus DataPointer i)) argRegs sizes offs ++ [AddRC () DataPointer DataPointer totalSize, BranchLink () l, loadSize (size' env o) CArg0 (AddRCPlus DataPointer (negate $ size' env o)), GnuMacro () "calleerestore"] ++ popLink ++ [Ret ()]+ }+irEmit _ (IR.MovMem (IR.Reg r) 8 (IR.Reg r')) =+ pure [Store () (toAbsReg r') (Reg $ toAbsReg r)]+irEmit _ (IR.MovMem (IR.Reg r) 8 e) = do+ { r' <- allocTemp64+ ; put <- evalE e r'+ ; pure $ put ++ [Store () (toAbsReg r') (Reg $ toAbsReg r)]+ }+irEmit _ (IR.MovMem e 8 e') = do+ { r <- allocTemp64+ ; r' <- allocTemp64+ ; eEval <- evalE e r+ ; e'Eval <- evalE e' r'+ ; pure (eEval ++ e'Eval ++ [Store () (toAbsReg r') (Reg $ toAbsReg r)])+ }+irEmit _ (IR.MovTemp r e) = evalE e r+irEmit _ (IR.MovMem (IR.Reg r) 1 e) = do+ { r' <- allocTemp64+ ; put <- evalE e r'+ ; pure $ put ++ [StoreByte () (toAbsReg r') (Reg $ toAbsReg r)]+ }+irEmit _ (IR.MovMem e 1 e') = do+ { r <- allocTemp64+ ; r' <- allocTemp64+ ; eEval <- evalE e r+ ; e'Eval <- evalE e' r'+ ; pure (eEval ++ e'Eval ++ [StoreByte () (toAbsReg r') (Reg $ toAbsReg r)])+ }+irEmit _ (IR.CJump e l0 l1) = do+ { r <- allocTemp64+ ; eEval <- evalE e r+ ; pure $ eEval ++ [BranchZero () (toAbsReg r) l1, Branch () l0]+ }+irEmit _ (IR.MJump e l) = do+ { r <- allocTemp64+ ; eEval <- evalE e r+ ; pure $ eEval ++ [BranchNonzero () (toAbsReg r) l] -- this is acceptable since in theory e is only 0 or 1+ }+-- example function call (arm) https://www.cs.princeton.edu/courses/archive/spr19/cos217/lectures/15_AssemblyFunctions.pdf+--+-- try https://thinkingeek.com/2017/05/29/exploring-aarch64-assembler-chapter-8/++-- see here:+-- https://stackoverflow.com/questions/27938768/moving-a-32-bit-constant-in-arm-arch64-register+-- and here:+-- https://developer.arm.com/documentation/dui0802/a/A64-General-Instructions/MOVK+--+-- Basically, arm only allows 16-bit immediates so when we load a 64-bit value+-- into a register we have to split it into 4 16-bit loads (shifted)+movRWord :: AbsReg -> Word -> [Arm AbsReg ()]+movRWord r w = [MovRWord () r (fromIntegral b0), MovRK () r (fromIntegral b1) 16, MovRK () r (fromIntegral b2) 32, MovRK () r (fromIntegral b3) 48]+ where b0 = w .&. 0xFFFF+ b1 = (w .&. 0xFFFF0000) `shiftR` 16+ b2 = (w .&. 0xFFFF00000000) `shiftR` 32+ b3 = (w .&. 0xFFFF000000000000) `shiftR` 48++evalE :: IR.Exp -> IR.Temp -> WriteM [Arm AbsReg ()]+evalE (IR.ConstInt i) r = pure [MovRC () (toAbsReg r) i]+evalE (IR.ConstWord w) r = pure $ movRWord (toAbsReg r) w+evalE (IR.ConstTag b) r = pure [MovRC () (toAbsReg r) (fromIntegral b)]+evalE (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.Reg r2)) r = pure [AddRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.Reg r2)) r = pure [SubRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.IntTimesIR (IR.Reg r1) (IR.Reg r2)) r = pure [MulRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.IntDivIR (IR.Reg r1) (IR.Reg r2)) r = pure [SignedDivRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.WordDivIR (IR.Reg r1) (IR.Reg r2)) r = pure [UnsignedDivRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.WordShiftRIR (IR.Reg r1) (IR.Reg r2)) r = pure [LShiftRRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.WordShiftLIR (IR.Reg r1) (IR.Reg r2)) r = pure [LShiftLRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.IntXorIR (IR.Reg r1) (IR.Reg r2)) r = pure [XorRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.BoolBinOp IR.BoolXor (IR.Reg r1) (IR.Reg r2)) r = pure [XorRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.BoolBinOp IR.BoolAnd (IR.Reg r1) (IR.Reg r2)) r = pure [AndRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.BoolBinOp IR.BoolOr (IR.Reg r1) (IR.Reg r2)) r = pure [OrRR () (toAbsReg r) (toAbsReg r1) (toAbsReg r2)]+evalE (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r1) (IR.ConstInt i)) r = pure [AddRC () (toAbsReg r) (toAbsReg r1) i]+evalE (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r1) (IR.ConstInt i)) r = pure [SubRC () (toAbsReg r) (toAbsReg r1) i]+evalE (IR.Mem 8 (IR.Reg r0)) r = pure [Load () (toAbsReg r) (Reg $ toAbsReg r0)]+evalE (IR.Mem 1 (IR.Reg r0)) r = pure [LoadByte () (toAbsReg r) (Reg $ toAbsReg r0)]+evalE (IR.Mem 8 (IR.ExprIntBinOp IR.IntPlusIR (IR.Reg r0) (IR.ConstInt i))) r = pure [Load () (toAbsReg r) (AddRCPlus (toAbsReg r0) i)]+evalE (IR.Mem 8 (IR.ExprIntBinOp IR.IntMinusIR (IR.Reg r0) (IR.ConstInt i))) r = pure [Load () (toAbsReg r) (AddRCPlus (toAbsReg r0) (negate i))]+evalE (IR.Mem 8 e) r = do+ { r' <- allocTemp64+ ; placeE <- evalE e r'+ ; pure $ placeE ++ [Load () (toAbsReg r) (Reg $ toAbsReg r')]+ }+evalE (IR.Mem 1 e) r = do+ { r' <- allocTemp64+ ; placeE <- evalE e r'+ ; pure $ placeE ++ [LoadByte () (toAbsReg r) (Reg $ toAbsReg r')]+ }+evalE (IR.Reg r) r' = pure [MovRR () (toAbsReg r') (toAbsReg r)]+evalE (IR.ExprIntRel IR.IntLtIR (IR.Reg r1) (IR.Reg r2)) r =+ pure [CmpRR () (toAbsReg r1) (toAbsReg r2), CSet () (toAbsReg r) Lt]+evalE (IR.ExprIntRel IR.IntEqIR (IR.Reg r1) (IR.Reg r2)) r =+ pure [CmpRR () (toAbsReg r1) (toAbsReg r2), CSet () (toAbsReg r) Eq]+evalE (IR.ExprIntRel IR.IntEqIR e e') r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; eEval <- evalE e r0+ ; e'Eval <- evalE e' r1+ ; pure $ eEval ++ e'Eval ++ [CmpRR () (toAbsReg r0) (toAbsReg r1), CSet () (toAbsReg r) Eq]+ }+evalE (IR.EqByte e (IR.ConstTag b)) r = do+ { r0 <- allocTemp64+ ; eEval <- evalE e r0+ ; pure $ eEval ++ [CmpRC () (toAbsReg r0) (fromIntegral b), CSet () (toAbsReg r) Eq]+ }+evalE (IR.EqByte e e') r = do+ { r0 <- allocTemp64+ ; r1 <- allocTemp64+ ; eEval <- evalE e r0+ ; e'Eval <- evalE e' r1+ ; pure $ eEval ++ e'Eval ++ [CmpRR () (toAbsReg r0) (toAbsReg r1), CSet () (toAbsReg r) Eq]+ }+evalE (IR.IntNegIR (IR.Reg r')) r = pure [Neg () (toAbsReg r) (toAbsReg r')]+evalE (IR.IntNegIR e) r = do+ { r' <- allocTemp64+ ; eEval <- evalE e r'+ ; pure $ eEval ++ [Neg () (toAbsReg r) (toAbsReg r')]+ }+evalE (IR.ExprIntBinOp IR.IntModIR (IR.Reg r1) (IR.Reg r2)) r = do+ { rTrash <- allocTemp64+ ; pure [ UnsignedDivRR () (toAbsReg rTrash) (toAbsReg r1) (toAbsReg r2), MulSubRRR () (toAbsReg r) (toAbsReg rTrash) (toAbsReg r2) (toAbsReg r1) ]+ }+evalE (IR.ConstBool b) r = pure [MovRC () (toAbsReg r) (toInt b)]++-- | Just use 64-bit integers here+toInt :: Bool -> Int64+toInt False = 0+toInt True = 1
+ src/Kempe/Asm/Arm/Type.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Asm.Arm.Type ( Label+ , ArmReg (..)+ , AbsReg (..)+ , Arm (..)+ , Cond (..)+ , Addr (..)+ , prettyAsm+ , prettyDebugAsm+ ) where++import Control.DeepSeq (NFData)+import qualified Data.ByteString as BS+import Data.Copointed+import Data.Int (Int64, Int8)+import Data.Semigroup ((<>))+import Data.Text.Encoding (decodeUtf8)+import Data.Word (Word16)+import GHC.Generics (Generic)+import Kempe.Asm.Pretty+import Kempe.Asm.Type+import Prettyprinter (Doc, Pretty (..), brackets, colon, concatWith, hardline, (<+>))+import Prettyprinter.Ext (prettyHex, prettyLines, (<#>), (<~>))++-- | Sort of silly class that prints the 32-bit equivalent of a register.+class As32 reg where+ as32b :: reg -> Doc ann++-- r0-r7 result registers++data AbsReg = DataPointer+ | AllocReg !Int+ | CArg0 -- x0+ | CArg1+ | CArg2+ | CArg3+ | CArg4+ | CArg5+ | CArg6+ | CArg7 -- x7+ | LinkReg -- so we can save before/after branch-links+ | StackPtr -- so we can save in translation phase+ deriving (Generic, NFData)++instance Pretty AbsReg where+ pretty DataPointer = "datapointer"+ pretty (AllocReg i) = "Abs" <> pretty i+ pretty CArg0 = "X0"+ pretty CArg1 = "X1"+ pretty CArg2 = "X2"+ pretty CArg3 = "X3"+ pretty CArg4 = "X4"+ pretty CArg5 = "X5"+ pretty CArg6 = "X6"+ pretty CArg7 = "X7"+ pretty LinkReg = "X30"+ pretty StackPtr = "SP"++instance As32 AbsReg where+ as32b = pretty++type Label = Word++data ArmReg = X0+ | X1+ | X2+ | X3+ | X4+ | X5+ | X6+ | X7+ | X8+ | X9+ | X10+ | X11+ | X12+ | X13+ | X14+ | X15+ | X16+ | X17+ | X18+ | X19+ | X20+ | X21+ | X22+ | X23+ | X24+ | X25+ | X26+ | X27+ | X28+ | X29+ | X30 -- ^ This is the link register?+ | SP -- ^ Don't use this+ deriving (Enum, Eq, Ord, Generic, NFData)++instance Pretty ArmReg where+ pretty X0 = "x0"+ pretty X1 = "x1"+ pretty X2 = "x2"+ pretty X3 = "x3"+ pretty X4 = "x4"+ pretty X5 = "x5"+ pretty X6 = "x6"+ pretty X7 = "x7"+ pretty X8 = "x8"+ pretty X9 = "x9"+ pretty X10 = "x10"+ pretty X11 = "x11"+ pretty X12 = "x12"+ pretty X13 = "x13"+ pretty X14 = "x14"+ pretty X15 = "x15"+ pretty X16 = "x16"+ pretty X17 = "x17"+ pretty X18 = "x18"+ pretty X19 = "x19"+ pretty X20 = "x20"+ pretty X21 = "x21"+ pretty X22 = "x22"+ pretty X23 = "x23"+ pretty X24 = "x24"+ pretty X25 = "x25"+ pretty X26 = "x26"+ pretty X27 = "x27"+ pretty X28 = "x28"+ pretty X29 = "x29"+ pretty X30 = "x30"+ pretty SP = "sp"++instance As32 ArmReg where+ as32b X0 = "w0"+ as32b X1 = "w1"+ as32b X2 = "w2"+ as32b X3 = "w3"+ as32b X4 = "w4"+ as32b X5 = "w5"+ as32b X6 = "w6"+ as32b X7 = "w7"+ as32b X8 = "w8"+ as32b X9 = "w9"+ as32b X10 = "w10"+ as32b X11 = "w11"+ as32b X12 = "w12"+ as32b X13 = "w13"+ as32b X14 = "w14"+ as32b X15 = "w15"+ as32b X16 = "w16"+ as32b X17 = "w17"+ as32b X18 = "w18"+ as32b X19 = "w19"+ as32b X20 = "w20"+ as32b X21 = "w21"+ as32b X22 = "w22"+ as32b X23 = "w23"+ as32b X24 = "w24"+ as32b X25 = "w25"+ as32b X26 = "w26"+ as32b X27 = "w27"+ as32b X28 = "w28"+ as32b X29 = "w29"+ as32b X30 = "w30"+ as32b SP = error "Internal error: as32b sp should not happen!!"++data Addr reg = Reg reg+ | AddRRPlus reg reg+ | AddRCPlus reg Int64+ deriving (Eq, Generic, NFData)++instance (Pretty reg) => Pretty (Addr reg) where+ pretty (Reg reg) = brackets (pretty reg)+ pretty (AddRRPlus r0 r1) = brackets (pretty r0 <~> pretty r1)+ pretty (AddRCPlus r i) = brackets (pretty r <~> prettyInt i)++-- | See: https://developer.arm.com/documentation/dui0068/b/arm-instruction-reference/conditional-execution?lang=en+data Cond = Eq+ | Neq+ | UnsignedLeq+ | UnsignedGeq+ | UnsignedLt+ | Geq+ | Lt+ | Gt+ | Leq+ deriving (Generic, NFData)++instance Pretty Cond where+ pretty Eq = "EQ"+ pretty Neq = "NE"+ pretty UnsignedLeq = "LS"+ pretty Geq = "GE"+ pretty Lt = "LT"+ pretty Gt = "GT"+ pretty Leq = "LE"+ pretty UnsignedLt = "LO"++-- | For reference: https://static.docs.arm.com/100898/0100/the_a64_Instruction_set_100898_0100.pdf+--+-- https://developer.arm.com/documentation/ddi0596/2020-12/Base-Instructions?lang=en+data Arm reg a = Branch { ann :: a, label :: Label } -- like jump+ | BranchLink { ann :: a, label :: Label } -- like @call@+ | BranchCond { ann :: a, label :: Label, cond :: Cond }+ | BranchZero { ann :: a, condReg :: reg, label :: Label }+ | BranchNonzero { ann :: a, condReg :: reg, label :: Label }+ | AddRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg }+ | AddRC { ann :: a, res :: reg, inp1 :: reg, int :: Int64 }+ | SubRC { ann :: a, res :: reg, inp1 :: reg, int :: Int64 }+ | SubRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg }+ | MulRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg }+ | MulSubRRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg, inp3 :: reg }+ | MovRC { ann :: a, dest :: reg, iSrc :: Int64 } -- TODO: change this to a Word16+ | SignedDivRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg }+ | UnsignedDivRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg }+ | MovRWord { ann :: a, dest :: reg, wSrc :: Word16 }+ | MovRK { ann :: a, dest :: reg, wSrc :: Word16, lShift :: Int8 }+ | MovRR { ann :: a, dest :: reg, src :: reg }+ | AndRR { ann :: a, dest :: reg, inp1 :: reg, inp2 :: reg }+ | OrRR { ann :: a, dest :: reg, inp1 :: reg, inp2 :: reg }+ | XorRR { ann :: a, dest :: reg, inp1 :: reg, inp2 :: reg }+ | Load { ann :: a, dest :: reg, addrSrc :: Addr reg }+ | LoadByte { ann :: a, dest :: reg, addrSrc :: Addr reg }+ | LoadLabel { ann :: a, dest :: reg, srcLabel :: BS.ByteString }+ | Store { ann :: a, src :: reg, addrDest :: Addr reg }+ | StoreByte { ann :: a, src :: reg, addrDest :: Addr reg } -- ^ @strb@ in Aarch64 assembly, "store byte"+ | CmpRR { ann :: a, inp1 :: reg, inp2 :: reg }+ | CmpRC { ann :: a, inp1 :: reg, int :: Int64 }+ | CSet { ann :: a, dest :: reg, cond :: Cond }+ | Ret { ann :: a }+ | Label { ann :: a, label :: Label }+ | BSLabel { ann :: a, bsLabel :: BS.ByteString }+ | LShiftLRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg } -- LShift - logical shift+ | LShiftRRR { ann :: a, res :: reg, inp1 :: reg, inp2 :: reg }+ | GnuMacro { ann :: a, macroName :: BS.ByteString }+ | Neg { ann :: a, dest :: reg, src :: reg }+ deriving (Functor, Generic, NFData)++-- | Don't call this on a negative number!+prettyUInt :: (Integral a, Show a) => a -> Doc b+prettyUInt i = "#" <> prettyHex i++prettyInt :: (Pretty a) => a -> Doc b+prettyInt = ("#" <>) . pretty++instance (Pretty reg, As32 reg) => Pretty (Arm reg a) where+ pretty (Branch _ l) = i4 ("b" <+> prettyLabel l)+ pretty (BranchLink _ l) = i4 ("bl" <+> prettyLabel l)+ pretty (BranchCond _ l c) = i4 ("b." <> pretty c <+> prettyLabel l)+ pretty (BranchZero _ r l) = i4 ("cbz" <+> pretty r <~> prettyLabel l)+ pretty (BranchNonzero _ r l) = i4 ("cbnz" <+> pretty r <~> prettyLabel l)+ pretty Ret{} = i4 "ret"+ pretty (BSLabel _ b) = let pl = pretty (decodeUtf8 b) in ".globl" <+> pl <> hardline <> pl <> colon+ pretty (MovRWord _ r c) = i4 ("mov" <+> pretty r <~> prettyUInt c)+ pretty (MovRK _ r c l) = i4 ("movk" <+> pretty r <~> prettyUInt c <~> "lsl" <+> pretty l)+ pretty (LShiftLRR _ r r0 r1) = i4 ("lsl" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (LShiftRRR _ r r0 r1) = i4 ("lsr" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (AddRR _ r r0 r1) = i4 ("add" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (SubRR _ r r0 r1) = i4 ("sub" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (MulRR _ r r0 r1) = i4 ("mul" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (MulSubRRR _ r r0 r1 r2) = i4 ("msub" <+> pretty r <~> pretty r0 <~> pretty r1 <~> pretty r2)+ pretty (SignedDivRR _ r r0 r1) = i4 ("sdiv" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (UnsignedDivRR _ r r0 r1) = i4 ("udiv" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (Load _ r a) = i4 ("ldr" <+> pretty r <~> pretty a)+ pretty (LoadByte _ r a) = i4 ("ldrb" <+> as32b r <~> pretty a)+ pretty (LoadLabel _ r l) = i4 ("ldr" <+> pretty r <~> "=" <> pretty (decodeUtf8 l))+ pretty (Store _ r a) = i4 ("str" <+> pretty r <~> pretty a)+ pretty (StoreByte _ r a) = i4 ("strb" <+> as32b r <~> pretty a)+ pretty (MovRR _ r0 r1) = i4 ("mov" <+> pretty r0 <~> pretty r1)+ pretty (AndRR _ r r0 r1) = i4 ("and" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (OrRR _ r r0 r1) = i4 ("orr" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (XorRR _ r r0 r1) = i4 ("eor" <+> pretty r <~> pretty r0 <~> pretty r1)+ pretty (CSet _ r c) = i4 ("cset" <+> pretty r <~> pretty c)+ pretty (MovRC _ r i) = i4 ("mov" <+> pretty r <~> prettyInt i)+ pretty (CmpRR _ r0 r1) = i4 ("cmp" <+> pretty r0 <~> pretty r1)+ pretty (Label _ l) = prettyLabel l <> colon+ pretty (GnuMacro _ b) = i4 (pretty (decodeUtf8 b))+ pretty (AddRC _ r r0 i) = i4 ("add" <+> pretty r <~> pretty r0 <~> "#" <> pretty i)+ pretty (SubRC _ r r0 i) = i4 ("sub" <+> pretty r <~> pretty r0 <~> "#" <> pretty i)+ pretty (CmpRC _ r0 i) = i4 ("cmp" <+> pretty r0 <~> "#" <> pretty i)+ pretty (Neg _ r0 r1) = i4 ("neg" <+> pretty r0 <~> pretty r1)++instance Copointed (Arm reg) where+ copoint = ann++prettyAsm :: (Pretty reg, As32 reg) => [Arm reg a] -> Doc ann+prettyAsm = (<> hardline) . ((prolegomena <#> macros <#> ".text" <> hardline) <>) . prettyLines . fmap pretty++-- http://www.mathcs.emory.edu/~cheung/Courses/255/Syl-ARM/7-ARM/array-define.html+prolegomena :: Doc ann+prolegomena = ".data" <#> "kempe_data: .skip 32768" -- 32kb++macros :: Doc ann+macros = prettyLines+ [ calleeSave+ , calleeRestore+ , callerSave+ , callerRestore+ ]++-- see:+-- https://community.arm.com/developer/ip-products/processors/b/processors-ip-blog/posts/using-the-stack-in-aarch64-implementing-push-and-pop++calleeSave :: Doc ann+calleeSave =+ ".macro calleesave"+ <#> i4 "sub sp, sp, #(8 * 10)" -- allocate space on stack+ <#> prettyLines (fmap pretty stores)+ <#> ".endm"+ where toPush = [X19 .. X28]+ stores = zipWith (\r o -> Store () r (AddRCPlus SP (8*o))) toPush [0..]++calleeRestore :: Doc ann+calleeRestore =+ ".macro calleerestore"+ <#> prettyLines (fmap pretty loads)+ <#> i4 "add sp, sp, #(8 * 10)" -- free stack space+ <#> ".endm"+ where toPop = [X19 .. X28]+ loads = zipWith (\r o -> Load () r (AddRCPlus SP (8*o))) toPop [0..]++callerSave :: Doc ann+callerSave =+ ".macro callersave"+ <#> i4 "sub sp, sp, #(8 * 8)"+ <#> prettyLines (fmap pretty stores)+ <#> ".endm"+ where toPush = X30 : [X9 .. X15]+ stores = zipWith (\r o -> Store () r (AddRCPlus SP (8*o))) toPush [0..]++callerRestore :: Doc ann+callerRestore =+ ".macro callerrestore"+ <#> prettyLines (fmap pretty loads)+ <#> i4 "add sp, sp, #(8 * 8)"+ <#> ".endm"+ where toPop = X30 : [X9 .. X15]+ loads = zipWith (\r o -> Load () r (AddRCPlus SP (8*o))) toPop [0..]++prettyLive :: (As32 reg, Pretty reg) => Arm reg Liveness -> Doc ann+prettyLive r = pretty r <+> pretty (ann r)++prettyDebugAsm :: (As32 reg, Pretty reg) => [Arm reg Liveness] -> Doc ann+prettyDebugAsm = concatWith (<#>) . fmap prettyLive
+ src/Kempe/Asm/Pretty.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Kempe.Asm.Pretty ( i4+ , prettyLabel+ ) where++import Data.Semigroup ((<>))+import Prettyprinter (Doc, indent, pretty)++i4 :: Doc ann -> Doc ann+i4 = indent 4++prettyLabel :: Word -> Doc ann+prettyLabel l = "kmp_" <> pretty l
src/Kempe/Asm/X86/ControlFlow.hs view
@@ -127,6 +127,7 @@ uses (MovRA _ _ a) = addrRegs a uses (MovAR _ a r) = singleton r <> addrRegs a uses (MovRR _ _ r) = singleton r+uses (MovRRLower _ _ r) = singleton r uses (AddRR _ r r') = fromList [r, r'] uses (SubRR _ r r') = fromList [r, r'] uses (ImulRR _ r r') = fromList [r, r']@@ -141,8 +142,9 @@ uses (CmpRegReg _ r r') = fromList [r, r'] uses (CmpRegBool _ r _) = singleton r uses (CmpAddrBool _ a _) = addrRegs a-uses (ShiftLRR _ r r') = fromList [r, r']-uses (ShiftRRR _ r r') = fromList [r, r']+uses (LShiftLRR _ r r') = fromList [r, r']+uses (LShiftRRR _ r r') = fromList [r, r']+uses (AShiftRRR _ r r') = fromList [r, r'] uses (MovRCi8 _ r _) = singleton r uses (MovACTag _ a _) = addrRegs a uses (IdivR _ r) = singleton r@@ -157,6 +159,7 @@ defs :: X86 AbsReg ann -> IS.IntSet defs (MovRA _ r _) = singleton r defs (MovRR _ r _) = singleton r+defs (MovRRLower _ r _) = singleton r defs (MovRC _ r _) = singleton r defs (MovRCBool _ r _) = singleton r defs (MovRCi8 _ r _) = singleton r@@ -168,9 +171,10 @@ defs (SubRC _ r _) = singleton r defs (XorRR _ r _) = singleton r defs (MovRL _ r _) = singleton r-defs (ShiftRRR _ r _) = singleton r+defs (LShiftRRR _ r _) = singleton r defs (PopReg _ r) = singleton r-defs (ShiftLRR _ r _) = singleton r+defs (LShiftLRR _ r _) = singleton r+defs (AShiftRRR _ r _) = singleton r defs (AndRR _ r _) = singleton r defs (OrRR _ r _) = singleton r defs (PopcountRR _ r _) = singleton r
src/Kempe/Asm/X86/Linear.hs view
@@ -221,6 +221,7 @@ allocReg (MovAR l a r) = (MovAR () <$> useAddr l a <*> useReg l r) <* freeDone l allocReg (MovAC _ (Reg DataPointer) i) = pure $ MovAC () (Reg Rbx) i allocReg (MovRR l r0 r1) = (MovRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (MovRRLower l r0 r1) = (MovRRLower () <$> useReg l r0 <*> useReg l r1) <* freeDone l allocReg (MovRA l r a) = (MovRA () <$> useReg l r <*> useAddr l a) <* freeDone l allocReg (CmpRegReg l r0 r1) = (CmpRegReg () <$> useReg l r0 <*> useReg l r1) <* freeDone l allocReg (CmpRegBool l r b) = (CmpRegBool () <$> useReg l r <*> pure b) <* freeDone l@@ -240,8 +241,9 @@ allocReg (AddRR l r0 r1) = (AddRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l allocReg (MovRL l r bl) = (MovRL () <$> useReg l r <*> pure bl) <* freeDone l allocReg (XorRR l r0 r1) = (XorRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l-allocReg (ShiftLRR l r0 r1) = (ShiftLRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l-allocReg (ShiftRRR l r0 r1) = (ShiftRRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (LShiftLRR l r0 r1) = (LShiftLRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (LShiftRRR l r0 r1) = (LShiftRRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l+allocReg (AShiftRRR l r0 r1) = (AShiftRRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l allocReg (ImulRR l r0 r1) = (ImulRR () <$> useReg l r0 <*> useReg l r1) <* freeDone l allocReg (MovRWord l r w) = (MovRWord () <$> useReg l r <*> pure w) <* freeDone l allocReg (IdivR l r) = (IdivR () <$> useReg l r) <* freeDone l
src/Kempe/Asm/X86/Trans.hs view
@@ -5,51 +5,28 @@ module Kempe.Asm.X86.Trans ( irToX86 ) where -import Control.Monad.State.Strict (State, evalState, gets, modify) import Data.Foldable.Ext-import Data.List (scanl')-import Data.Word (Word8)+import Data.List (scanl')+import Data.Word (Word8) import Kempe.AST.Size import Kempe.Asm.X86.Type-import qualified Kempe.IR.Type as IR+import Kempe.IR.Monad+import qualified Kempe.IR.Type as IR toAbsReg :: IR.Temp -> AbsReg toAbsReg (IR.Temp8 i) = AllocReg8 i toAbsReg (IR.Temp64 i) = AllocReg64 i toAbsReg IR.DataPointer = DataPointer -type WriteM = State IR.WriteSt- irToX86 :: SizeEnv -> IR.WriteSt -> [IR.Stmt] -> [X86 AbsReg ()] irToX86 env w = runWriteM w . foldMapA (irEmit env) -nextLabels :: IR.WriteSt -> IR.WriteSt-nextLabels (IR.WriteSt ls ts) = IR.WriteSt (tail ls) ts--nextInt :: IR.WriteSt -> IR.WriteSt-nextInt (IR.WriteSt ls ts) = IR.WriteSt ls (tail ts)--getInt :: WriteM Int-getInt = gets (head . IR.temps) <* modify nextInt--getLabel :: WriteM IR.Label-getLabel = gets (head . IR.wlabels) <* modify nextLabels--allocTemp64 :: WriteM IR.Temp-allocTemp64 = IR.Temp64 <$> getInt--allocTemp8 :: WriteM IR.Temp-allocTemp8 = IR.Temp8 <$> getInt- allocReg64 :: WriteM AbsReg allocReg64 = AllocReg64 <$> getInt allocReg8 :: WriteM AbsReg allocReg8 = AllocReg8 <$> getInt -runWriteM :: IR.WriteSt -> WriteM a -> a-runWriteM = flip evalState- -- | This should handle 'MovMem's of divers sizes but for now it just does -- 1 byte or 8 bytes at a time. irEmit :: SizeEnv -> IR.Stmt -> WriteM [X86 AbsReg ()]@@ -165,11 +142,11 @@ } irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.WordShiftRIR (IR.Reg r1) (IR.Reg r2))) = do { r' <- allocReg64- ; pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () r' (toAbsReg r1), ShiftRRR () r' ShiftExponent, MovAR () (Reg $ toAbsReg r) r' ]+ ; pure [ MovRRLower () ShiftExponent (toAbsReg r2), MovRR () r' (toAbsReg r1), LShiftRRR () r' ShiftExponent, MovAR () (Reg $ toAbsReg r) r' ] } irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.WordShiftLIR (IR.Reg r1) (IR.Reg r2))) = do { r' <- allocReg64- ; pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () r' (toAbsReg r1), ShiftLRR () r' ShiftExponent, MovAR () (Reg $ toAbsReg r) r' ]+ ; pure [ MovRRLower () ShiftExponent (toAbsReg r2), MovRR () r' (toAbsReg r1), LShiftLRR () r' ShiftExponent, MovAR () (Reg $ toAbsReg r) r' ] } irEmit _ (IR.MovMem (IR.Reg r) _ (IR.ExprIntBinOp IR.IntModIR (IR.Reg r1) (IR.Reg r2))) = -- QuotRes is rax, so move r1 to rax first@@ -263,23 +240,23 @@ -- registers across jumps... so evaluating = or < as an expression in -- general is hard ? evalE (IR.ExprIntBinOp IR.WordShiftLIR (IR.Reg r1) (IR.Reg r2)) r =- pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () (toAbsReg r) (toAbsReg r1), ShiftLRR () (toAbsReg r) ShiftExponent ]+ pure [ MovRRLower () ShiftExponent (toAbsReg r2), MovRR () (toAbsReg r) (toAbsReg r1), LShiftLRR () (toAbsReg r) ShiftExponent ] evalE (IR.ExprIntBinOp IR.WordShiftRIR (IR.Reg r1) (IR.Reg r2)) r = -- FIXME: maximal munch use evalE recursively- pure [ MovRR () ShiftExponent (toAbsReg r2), MovRR () (toAbsReg r) (toAbsReg r1), ShiftRRR () (toAbsReg r) ShiftExponent]-evalE (IR.ExprIntBinOp IR.WordShiftLIR e0 e1) r = do- { r0 <- allocTemp64- ; r1 <- allocTemp8- ; placeE0 <- evalE e0 r0- ; placeE1 <- evalE e1 r1- ; pure $ placeE0 ++ placeE1 ++ [ MovRR () ShiftExponent (toAbsReg r0), MovRR () (toAbsReg r) (toAbsReg r1), ShiftLRR () (toAbsReg r) ShiftExponent ]- }-evalE (IR.ExprIntBinOp IR.WordShiftRIR e0 e1) r = do- { r0 <- allocTemp64- ; r1 <- allocTemp8- ; placeE0 <- evalE e0 r0- ; placeE1 <- evalE e1 r1- ; pure $ placeE0 ++ placeE1 ++ [ MovRR () ShiftExponent (toAbsReg r0), MovRR () (toAbsReg r) (toAbsReg r1), ShiftRRR () (toAbsReg r) ShiftExponent ]- }+ pure [ MovRRLower () ShiftExponent (toAbsReg r2), MovRR () (toAbsReg r) (toAbsReg r1), LShiftRRR () (toAbsReg r) ShiftExponent]+-- evalE (IR.ExprIntBinOp IR.WordShiftLIR e0 e1) r = do+ -- { r0 <- allocTemp64+ -- ; r1 <- allocTemp8+ -- ; placeE0 <- evalE e0 r0+ -- ; placeE1 <- evalE e1 r1+ -- ; pure $ placeE0 ++ placeE1 ++ [ MovRR () ShiftExponent (toAbsReg r0), MovRR () (toAbsReg r) (toAbsReg r1), LShiftLRR () (toAbsReg r) ShiftExponent ]+ -- }+-- evalE (IR.ExprIntBinOp IR.WordShiftRIR e0 e1) r = do+ -- { r0 <- allocTemp64+ -- ; r1 <- allocTemp8+ -- ; placeE0 <- evalE e0 r0+ -- ; placeE1 <- evalE e1 r1+ -- ; pure $ placeE0 ++ placeE1 ++ [ MovRR () ShiftExponent (toAbsReg r0), MovRR () (toAbsReg r) (toAbsReg r1), LShiftRRR () (toAbsReg r) ShiftExponent ]+ -- } evalE (IR.ExprIntBinOp IR.IntModIR e0 e1) r = do { r0 <- allocTemp64 ; r1 <- allocTemp64
src/Kempe/Asm/X86/Type.hs view
@@ -22,12 +22,34 @@ import qualified Data.Text.Lazy.Encoding as TL import Data.Word (Word8) import GHC.Generics (Generic)+import Kempe.Asm.Pretty import Kempe.Asm.Type-import Prettyprinter (Doc, Pretty (pretty), brackets, colon, concatWith, hardline, indent, (<+>))+import Prettyprinter (Doc, Pretty (pretty), brackets, colon, concatWith, hardline, (<+>)) import Prettyprinter.Ext type Label = Word +-- | Used to implement 'MovRRLower' pretty-printer+class As8 reg where+ -- | Return the register for addressing the lower 8 bits given a 64-bit+ -- register+ as8 :: reg -> reg++instance As8 X86Reg where+ as8 R8 = R8b+ as8 R9 = R9b+ as8 R10 = R10b+ as8 R11 = R11b+ as8 R12 = R12b+ as8 R13 = R13b+ as8 R14 = R14b+ as8 R15 = R15b+ as8 Rsi = Sil+ as8 Rdi = Dil+ as8 Rax = AL+ as8 Rdx = DL+ as8 r = r -- other cases, as8 r8b = r8b, etc.+ -- currently just has 64-bit and 8-bit registers data X86Reg = R8 | R9@@ -112,7 +134,7 @@ | CArg4 | CArg5 | CArg6- | CRet -- x0 on aarch64+ | CRet | ShiftExponent | QuotRes -- quotient register for idiv, rax | RemRes -- remainder register for idiv, rdx@@ -158,6 +180,7 @@ | MovAR { ann :: a, addrDest :: Addr reg, rSrc :: reg } | MovABool { ann :: a, addrDest :: Addr reg, boolSrc :: Word8 } | MovRR { ann :: a, rDest :: reg, rSrc :: reg } -- for convenience+ | MovRRLower { ann :: a, rDest :: reg, rSrc :: reg } -- ^ Doesn't correspond 1-1 to an instruction, writes a 64-bit register to an 8-bit register | MovRC { ann :: a, rDest :: reg, iSrc :: Int64 } | MovRL { ann :: a, rDest :: reg, bsLabel :: BS.ByteString } | MovAC { ann :: a, addrDest :: Addr reg, iSrc :: Int64 }@@ -174,8 +197,9 @@ | AddAC { ann :: a, addrAdd1 :: Addr reg, iAdd2 :: Int64 } | AddRC { ann :: a, rAdd1 :: reg, iAdd2 :: Int64 } | SubRC { ann :: a, rSub1 :: reg, iSub2 :: Int64 }- | ShiftLRR { ann :: a, rDest :: reg, rSrc :: reg }- | ShiftRRR { ann :: a, rDest :: reg, rSrc :: reg }+ | LShiftLRR { ann :: a, rDest :: reg, rSrc :: reg }+ | LShiftRRR { ann :: a, rDest :: reg, rSrc :: reg }+ | AShiftRRR { ann :: a, rDest :: reg, rSrc :: reg } | Label { ann :: a, label :: Label } | BSLabel { ann :: a, bsLabel :: BS.ByteString } | Je { ann :: a, jLabel :: Label }@@ -201,9 +225,6 @@ instance Copointed (X86 reg) where copoint = ann -i4 :: Doc ann -> Doc ann-i4 = indent 4- instance Pretty reg => Pretty (Addr reg) where pretty (Reg r) = brackets (pretty r) pretty (AddrRRPlus r0 r1) = brackets (pretty r0 <> "+" <> pretty r1)@@ -211,14 +232,11 @@ pretty (AddrRCMinus r c) = brackets (pretty r <> "-" <> pretty c) pretty (AddrRRScale r0 r1 c) = brackets (pretty r0 <> "+" <> pretty r1 <> "*" <> pretty c) -prettyLabel :: Label -> Doc ann-prettyLabel l = "kmp_" <> pretty l--prettyLive :: Pretty reg => X86 reg Liveness -> Doc ann+prettyLive :: (As8 reg, Pretty reg) => X86 reg Liveness -> Doc ann prettyLive r = pretty r <+> pretty (ann r) -- intel syntax-instance Pretty reg => Pretty (X86 reg a) where+instance (As8 reg, Pretty reg) => Pretty (X86 reg a) where pretty (PushReg _ r) = i4 ("push" <+> pretty r) pretty (PushMem _ a) = i4 ("push" <+> pretty a) pretty (PopMem _ a) = i4 ("pop qword" <+> pretty a)@@ -234,11 +252,12 @@ pretty (MovRCi8 _ r i) = i4 ("mov byte" <+> pretty r <> "," <+> pretty i) pretty (MovRWord _ r w) = i4 ("mov qword" <+> pretty r <> "," <+> prettyHex w) pretty (MovRR _ r0 r1) = i4 ("mov" <+> pretty r0 <> "," <+> pretty r1)+ pretty (MovRRLower _ r0 r1) = i4 ("mov" <+> pretty r0 <> "," <+> pretty (as8 r1)) pretty (MovRC _ r i) = i4 ("mov" <+> pretty r <> "," <+> pretty i) pretty (MovAC _ a i) = i4 ("mov qword" <+> pretty a <> "," <+> pretty i) pretty (MovRCBool _ r b) = i4 ("mov" <+> pretty r <> "," <+> pretty b) pretty (MovRL _ r bl) = i4 ("mov" <+> pretty r <> "," <+> pretty (decodeUtf8 bl))- pretty (AddRR _ r0 r1) = i4 ("add" <+> pretty r0 <> "," <> pretty r1)+ pretty (AddRR _ r0 r1) = i4 ("add" <+> pretty r0 <> "," <+> pretty r1) pretty (AddAC _ a c) = i4 ("add" <+> pretty a <> "," <+> pretty c) pretty (SubRR _ r0 r1) = i4 ("sub" <+> pretty r0 <> "," <> pretty r1) pretty (ImulRR _ r0 r1) = i4 ("imul" <+> pretty r0 <> "," <+> pretty r1)@@ -253,8 +272,9 @@ pretty (CmpRegReg _ r0 r1) = i4 ("cmp" <+> pretty r0 <> "," <+> pretty r1) pretty (CmpAddrBool _ a b) = i4 ("cmp byte" <+> pretty a <> "," <+> pretty b) pretty (CmpRegBool _ r b) = i4 ("cmp" <+> pretty r <> "," <+> pretty b)- pretty (ShiftRRR _ r0 r1) = i4 ("shr" <+> pretty r0 <> "," <+> pretty r1)- pretty (ShiftLRR _ r0 r1) = i4 ("shl" <+> pretty r0 <> "," <+> pretty r1)+ pretty (LShiftRRR _ r0 r1) = i4 ("shr" <+> pretty r0 <> "," <+> pretty r1)+ pretty (LShiftLRR _ r0 r1) = i4 ("shl" <+> pretty r0 <> "," <+> pretty r1)+ pretty (AShiftRRR _ r0 r1) = i4 ("sar" <+> pretty r0 <> "," <+> pretty r1) pretty (IdivR _ r) = i4 ("idiv" <+> pretty r) pretty (DivR _ r) = i4 ("div" <+> pretty r) pretty Cqo{} = i4 "cqo"@@ -271,11 +291,11 @@ pretty (NasmMacro0 _ b) = i4 (pretty (decodeUtf8 b)) pretty (CallBS _ b) = i4 ("call" <+> pretty (TL.decodeUtf8 b)) -prettyAsm :: Pretty reg => [X86 reg a] -> Doc ann+prettyAsm :: (As8 reg, Pretty reg) => [X86 reg a] -> Doc ann prettyAsm = ((prolegomena <#> macros <#> "section .text" <> hardline) <>) . prettyLines . fmap pretty -prettyDebugAsm :: Pretty reg => [X86 reg Liveness] -> Doc ann-prettyDebugAsm = concatWith (\x y -> x <> hardline <> y) . fmap prettyLive+prettyDebugAsm :: (As8 reg, Pretty reg) => [X86 reg Liveness] -> Doc ann+prettyDebugAsm = concatWith (<#>) . fmap prettyLive prolegomena :: Doc ann prolegomena = "section .bss" <> hardline <> "kempe_data: resb 0x8012" -- 32 kb
+ src/Kempe/Debug.hs view
@@ -0,0 +1,17 @@+module Kempe.Debug ( armDebug+ ) where++import qualified Kempe.Asm.Arm.ControlFlow as Arm+import qualified Kempe.Asm.Arm.Type as Arm+import Kempe.Asm.Liveness+import Kempe.Module+import Kempe.Pipeline+import Prettyprinter (Doc)++-- | Helper function displays calculated live ranges for debugging+armDebug :: FilePath -> IO (Doc ann)+armDebug fp =+ Arm.prettyDebugAsm+ . reconstruct+ . Arm.mkControlFlow+ . uncurry armParsed <$> parseProcess fp
src/Kempe/File.hs view
@@ -4,8 +4,11 @@ , dumpTyped , irFile , x86File+ , armFile , dumpX86+ , dumpArm , compile+ , armCompile , dumpIR ) where @@ -20,7 +23,8 @@ import Data.Tuple.Extra (fst3) import Data.Typeable (Typeable) import Kempe.AST-import Kempe.Asm.X86.Type+import qualified Kempe.Asm.Arm.Type as Arm+import qualified Kempe.Asm.X86.Type as X86 import Kempe.Check.Lint import Kempe.Check.Pattern import Kempe.Check.TopLevel@@ -29,7 +33,8 @@ import Kempe.Lexer import Kempe.Module import Kempe.Pipeline-import Kempe.Proc.Nasm+import Kempe.Proc.As as As+import qualified Kempe.Proc.Nasm as Nasm import Kempe.Shuttle import Kempe.TyAssign import Prettyprinter (Doc, hardline)@@ -68,8 +73,11 @@ dumpIR = prettyIR . fst3 .* irGen dumpX86 :: Typeable a => Int -> Declarations a c b -> Doc ann-dumpX86 = prettyAsm .* x86Alloc+dumpX86 = X86.prettyAsm .* x86Alloc +dumpArm :: Typeable a => Int -> Declarations a c b -> Doc ann+dumpArm = Arm.prettyAsm .* armAlloc+ irFile :: FilePath -> IO () irFile fp = do res <- parseProcess fp@@ -80,10 +88,23 @@ res <- parseProcess fp putDoc $ uncurry dumpX86 res <> hardline +armFile :: FilePath -> IO ()+armFile fp = do+ res <- parseProcess fp+ putDoc $ uncurry dumpArm res -- don't need hardline b/c arm pp adds it already+ compile :: FilePath -> FilePath -> Bool -- ^ Debug symbols? -> IO () compile fp o dbg = do res <- parseProcess fp- writeO (uncurry dumpX86 res) o dbg+ Nasm.writeO (uncurry dumpX86 res) o dbg++armCompile :: FilePath+ -> FilePath+ -> Bool -- ^ Debug symbols?+ -> IO ()+armCompile fp o dbg = do+ res <- parseProcess fp+ As.writeO (uncurry dumpArm res) o dbg
src/Kempe/IR.hs view
@@ -118,10 +118,10 @@ intShift :: IntBinOp -> TempM [Stmt] intShift cons = do- t0 <- getTemp8+ t0 <- getTemp64 t1 <- getTemp64 pure $- pop 1 t0 ++ pop 8 t1 ++ push 8 (ExprIntBinOp cons (Reg t1) (Reg t0))+ pop 8 t0 ++ pop 8 t1 ++ push 8 (ExprIntBinOp cons (Reg t1) (Reg t0)) boolOp :: BoolBinOp -> TempM [Stmt] boolOp op = do@@ -189,7 +189,7 @@ writeAtom _ _ (AtBuiltin _ IntDiv) = intOp IntDivIR -- what to do on failure? writeAtom _ _ (AtBuiltin _ IntMod) = intOp IntModIR writeAtom _ _ (AtBuiltin _ IntXor) = intOp IntXorIR-writeAtom _ _ (AtBuiltin _ IntShiftR) = intShift WordShiftRIR -- TODO: shr or sar?+writeAtom _ _ (AtBuiltin _ IntShiftR) = intShift WordShiftRIR -- FIXME: shr or sar? writeAtom _ _ (AtBuiltin _ IntShiftL) = intShift WordShiftLIR writeAtom _ _ (AtBuiltin _ IntEq) = intRel IntEqIR writeAtom _ _ (AtBuiltin _ IntLt) = intRel IntLtIR
+ src/Kempe/IR/Monad.hs view
@@ -0,0 +1,36 @@+-- | Put this in its own module to+module Kempe.IR.Monad ( WriteM+ , nextLabels+ , nextInt+ , getInt+ , getLabel+ , runWriteM+ , allocTemp8+ , allocTemp64+ ) where++import Control.Monad.State.Strict (State, evalState, gets, modify)+import Kempe.IR.Type++type WriteM = State WriteSt++nextLabels :: WriteSt -> WriteSt+nextLabels (WriteSt ls ts) = WriteSt (tail ls) ts++nextInt :: WriteSt -> WriteSt+nextInt (WriteSt ls ts) = WriteSt ls (tail ts)++getInt :: WriteM Int+getInt = gets (head . temps) <* modify nextInt++getLabel :: WriteM Label+getLabel = gets (head . wlabels) <* modify nextLabels++allocTemp64 :: WriteM Temp+allocTemp64 = Temp64 <$> getInt++allocTemp8 :: WriteM Temp+allocTemp8 = Temp8 <$> getInt++runWriteM :: WriteSt -> WriteM a -> a+runWriteM = flip evalState
src/Kempe/IR/Opt.hs view
@@ -4,7 +4,7 @@ import Kempe.IR.Type optimize :: [Stmt] -> [Stmt]-optimize = sameTarget . successiveBumps . successiveBumps . removeNop+optimize = sameTarget . successiveBumps . successiveBumps . removeNop . liftOptE -- | Often IR generation will leave us with something like --@@ -70,10 +70,20 @@ :ss) | k == k' && e0 == e0' = st : sameTarget ss sameTarget (s:ss) = s : sameTarget ss +liftOptE :: [Stmt] -> [Stmt]+liftOptE [] = []+liftOptE ((MovMem e0 sz e1) : ss) = MovMem (optE e0) sz (optE e1) : liftOptE ss+liftOptE ((MovTemp t e) : ss) = MovTemp t (optE e) : liftOptE ss+liftOptE (s:ss) = s : liftOptE ss++optE :: Exp -> Exp+optE (ExprIntBinOp IntPlusIR e (ConstInt 0)) = optE e+optE (ExprIntBinOp IntMinusIR e (ConstInt 0)) = optE e+optE e = e+ removeNop :: [Stmt] -> [Stmt] removeNop = filter (not . isNop) where- isNop (MovTemp e (ExprIntBinOp IntPlusIR (Reg e') (ConstInt 0))) | e == e' = True- isNop (MovTemp e (ExprIntBinOp IntMinusIR (Reg e') (ConstInt 0))) | e == e' = True+ isNop (MovTemp e (Reg e')) | e == e' = True isNop (MovMem e _ (Mem _ e')) | e == e' = True -- the Eq on Exp is kinda weird, but if the syntax trees are the same then they're certainly equivalent semantically isNop _ = False
src/Kempe/IR/Type.hs view
@@ -13,16 +13,17 @@ , WriteSt (..) ) where -import Control.DeepSeq (NFData)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL-import Data.Int (Int64, Int8)-import Data.Semigroup ((<>))-import Data.Text.Encoding (decodeUtf8)-import Data.Word (Word8)-import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import Control.Monad.State.Strict (State)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import Data.Int (Int64, Int8)+import Data.Semigroup ((<>))+import Data.Text.Encoding (decodeUtf8)+import Data.Word (Word8)+import GHC.Generics (Generic) import Kempe.AST.Size-import Prettyprinter (Doc, Pretty (pretty), braces, brackets, colon, hardline, parens, (<+>))+import Prettyprinter (Doc, Pretty (pretty), braces, brackets, colon, hardline, parens, (<+>)) import Prettyprinter.Ext data WriteSt = WriteSt { wlabels :: [Label]@@ -75,7 +76,7 @@ data Stmt = Labeled Label | Jump Label -- conditional jump for ifs- | CJump Exp Label Label+ | CJump Exp Label Label -- ^ If the 'Exp' evaluates to @1@, go to the first label, otherwise go to the second (if-then-else) | MJump Exp Label | CCall MonoStackType BSL.ByteString | KCall Label -- KCall is a jump to a Kempe procedure@@ -87,7 +88,7 @@ data Exp = ConstInt Int64 | ConstInt8 Int8- | ConstTag Word8+ | ConstTag Word8 -- ^ Used to distinguish constructors of a sum type | ConstWord Word | ConstBool Bool | Reg Temp -- TODO: size?
src/Kempe/Pipeline.hs view
@@ -1,6 +1,8 @@ module Kempe.Pipeline ( irGen , x86Parsed , x86Alloc+ , armParsed+ , armAlloc ) where import Control.Composition ((.*))@@ -9,11 +11,16 @@ import Data.Typeable (Typeable) import Kempe.AST import Kempe.AST.Size+import qualified Kempe.Asm.Arm.ControlFlow as Arm+import qualified Kempe.Asm.Arm.Linear as Arm+import Kempe.Asm.Arm.Opt+import Kempe.Asm.Arm.Trans+import qualified Kempe.Asm.Arm.Type as Arm import Kempe.Asm.Liveness-import Kempe.Asm.X86.ControlFlow-import Kempe.Asm.X86.Linear+import qualified Kempe.Asm.X86.ControlFlow as X86+import qualified Kempe.Asm.X86.Linear as X86 import Kempe.Asm.X86.Trans-import Kempe.Asm.X86.Type+import qualified Kempe.Asm.X86.Type as X86 import Kempe.Check.Restrict import Kempe.IR import Kempe.IR.Opt@@ -28,8 +35,14 @@ mOk = maybe m throw (restrictConstructors m) adjEnv (x, y) = (x, y, env) -x86Parsed :: Typeable a => Int -> Declarations a c b -> [X86 AbsReg ()]+armParsed :: Typeable a => Int -> Declarations a c b -> [Arm.Arm Arm.AbsReg ()]+armParsed i m = let (ir, u, env) = irGen i m in irToAarch64 env u ir++armAlloc :: Typeable a => Int -> Declarations a c b -> [Arm.Arm Arm.ArmReg ()]+armAlloc = optimizeArm . Arm.allocRegs . reconstruct . Arm.mkControlFlow .* armParsed++x86Parsed :: Typeable a => Int -> Declarations a c b -> [X86.X86 X86.AbsReg ()] x86Parsed i m = let (ir, u, env) = irGen i m in irToX86 env u ir -x86Alloc :: Typeable a => Int -> Declarations a c b -> [X86 X86Reg ()]-x86Alloc = allocRegs . reconstruct . mkControlFlow .* x86Parsed+x86Alloc :: Typeable a => Int -> Declarations a c b -> [X86.X86 X86.X86Reg ()]+x86Alloc = X86.allocRegs . reconstruct . X86.mkControlFlow .* x86Parsed
+ src/Kempe/Proc/As.hs view
@@ -0,0 +1,26 @@+module Kempe.Proc.As ( writeO+ ) where++import Data.Functor (void)+import Prettyprinter (Doc, defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.String (renderString)+import System.Info (arch)+import System.Process (CreateProcess (..), StdStream (Inherit), proc, readCreateProcess)++-- | @as@ on Aarch64 systems, or @aarch64-linux-gnu-as@ when+-- cross-assembling/cross-compiling.+assembler :: String+assembler =+ case arch of+ "x86_64" -> "aarch64-linux-gnu-as"+ _ -> "as"++-- | Assemble using @as@, output in some file.+writeO :: Doc ann+ -> FilePath+ -> Bool -- ^ Debug symbols?+ -> IO ()+writeO p fpO dbg = do+ let inp = renderString (layoutPretty defaultLayoutOptions p)+ debugFlag = if dbg then ("-g":) else id+ void $ readCreateProcess ((proc assembler (debugFlag ["-o", fpO, "--"])) { std_err = Inherit }) inp
src/Kempe/TyAssign.hs view
@@ -205,13 +205,13 @@ intBinOp = StackType S.empty [TyBuiltin () TyInt, TyBuiltin () TyInt] [TyBuiltin () TyInt] intShift :: StackType ()-intShift = StackType S.empty [TyBuiltin () TyInt, TyBuiltin () TyInt8] [TyBuiltin () TyInt]+intShift = StackType S.empty [TyBuiltin () TyInt, TyBuiltin () TyInt] [TyBuiltin () TyInt] wordBinOp :: StackType () wordBinOp = StackType S.empty [TyBuiltin () TyWord, TyBuiltin () TyWord] [TyBuiltin () TyWord] wordShift :: StackType ()-wordShift = StackType S.empty [TyBuiltin () TyWord, TyBuiltin () TyInt8] [TyBuiltin () TyWord]+wordShift = StackType S.empty [TyBuiltin () TyWord, TyBuiltin () TyWord] [TyBuiltin () TyWord] tyLookup :: Name a -> TypeM a (StackType a) tyLookup n@(Name _ (Unique i) l) = do
src/Prettyprinter/Ext.hs view
@@ -2,6 +2,7 @@ module Prettyprinter.Ext ( (<#>) , (<##>)+ , (<~>) , prettyHex , prettyLines , sepDecls@@ -12,12 +13,18 @@ infixr 6 <#> infixr 6 <##>+infixr 6 <~> +--- ₀₁₂₃₄₅₆₇₈₉+ (<#>) :: Doc a -> Doc a -> Doc a (<#>) x y = x <> hardline <> y (<##>) :: Doc a -> Doc a -> Doc a (<##>) x y = x <> hardline <> hardline <> y++(<~>) :: Doc a -> Doc a -> Doc a+(<~>) x y = x <> ", " <> y prettyHex :: (Integral a, Show a) => a -> Doc ann prettyHex x = "0x" <> pretty (showHex x mempty)
test/Backend.hs view
@@ -2,8 +2,9 @@ ) where import Control.DeepSeq (deepseq)+import qualified Kempe.Asm.Arm.ControlFlow as Arm import Kempe.Asm.Liveness-import Kempe.Asm.X86.ControlFlow+import qualified Kempe.Asm.X86.ControlFlow as X86 import Kempe.Inline import Kempe.Module import Kempe.Monomorphize@@ -31,10 +32,13 @@ , irNoYeet "test/data/maybeC.kmp" , x86NoYeet "examples/factorial.kmp" , x86NoYeet "examples/splitmix.kmp"+ , armNoYeet "examples/factorial.kmp" , controlFlowGraph "examples/factorial.kmp" , controlFlowGraph "examples/splitmix.kmp"+ , controlFlowGraphArm "lib/gaussian.kmp" , liveness "examples/factorial.kmp" , liveness "examples/splitmix.kmp"+ , livenessArm "lib/gaussian.kmp" , codegen "examples/factorial.kmp" , codegen "examples/splitmix.kmp" , codegen "lib/numbertheory.kmp"@@ -43,6 +47,11 @@ , codegen "test/data/ccall.kmp" , codegen "test/data/mutual.kmp" , codegen "lib/rational.kmp"+ , armCodegen "examples/factorial.kmp"+ , armCodegen "lib/numbertheory.kmp"+ , armCodegen "lib/gaussian.kmp"+ , armCodegen "lib/rational.kmp"+ , armCodegen "examples/splitmix.kmp" ] codegen :: FilePath -> TestTree@@ -51,18 +60,43 @@ let code = uncurry x86Alloc parsed assertBool "Doesn't fail" (code `deepseq` True) +armCodegen :: FilePath -> TestTree+armCodegen fp = testCase ("Generates arm assembly without throwing exception (" ++ fp ++ ")") $ do+ parsed <- parseProcess fp+ let code = uncurry armAlloc parsed+ assertBool "Doesn't fail" (code `deepseq` True)++livenessArm :: FilePath -> TestTree+livenessArm fp = testCase ("Aarch64 liveness analysis terminates (" ++ fp ++ ")") $ do+ parsed <- parseProcess fp+ let arm = uncurry armParsed parsed+ cf = Arm.mkControlFlow arm+ assertBool "Doesn't bottom" (reconstruct cf `deepseq` True)+ liveness :: FilePath -> TestTree liveness fp = testCase ("Liveness analysis terminates (" ++ fp ++ ")") $ do parsed <- parseProcess fp let x86 = uncurry x86Parsed parsed- cf = mkControlFlow x86+ cf = X86.mkControlFlow x86 assertBool "Doesn't bottom" (reconstruct cf `deepseq` True) controlFlowGraph :: FilePath -> TestTree controlFlowGraph fp = testCase ("Doesn't crash while creating control flow graph for " ++ fp) $ do parsed <- parseProcess fp let x86 = uncurry x86Parsed parsed- assertBool "Worked without exception" (mkControlFlow x86 `deepseq` True)+ assertBool "Worked without exception" (X86.mkControlFlow x86 `deepseq` True)++controlFlowGraphArm :: FilePath -> TestTree+controlFlowGraphArm fp = testCase ("Doesn't crash while creating control flow graph for aarch64 assembly " ++ fp) $ do+ parsed <- parseProcess fp+ let arm = uncurry armParsed parsed+ assertBool "Worked without exception" (Arm.mkControlFlow arm `deepseq` True)++armNoYeet :: FilePath -> TestTree+armNoYeet fp = testCase ("Selects instructions for " ++ fp) $ do+ parsed <- parseProcess fp+ let arm = uncurry armParsed parsed+ assertBool "Worked without exception" (arm `deepseq` True) x86NoYeet :: FilePath -> TestTree x86NoYeet fp = testCase ("Selects instructions for " ++ fp) $ do
test/Golden.hs view
@@ -1,14 +1,28 @@ module Main (main) where import Harness+import System.Info (arch) import Test.Tasty main :: IO () main = defaultMain $- testGroup "Golden output tests"+ testGroup "Golden output tests" $ [ goldenOutput "examples/factorial.kmp" "test/harness/factorial.c" "test/golden/factorial.out" , goldenOutput "test/examples/splitmix.kmp" "test/harness/splitmix.c" "test/golden/splitmix.out" , goldenOutput "lib/numbertheory.kmp" "test/harness/numbertheory.c" "test/golden/numbertheory.out" , goldenOutput "test/examples/hamming.kmp" "test/harness/hamming.c" "test/golden/hamming.out" , goldenOutput "test/examples/bool.kmp" "test/harness/bool.c" "test/golden/bool.out"- ]+ , goldenOutput "test/examples/const.kmp" "test/harness/const.c" "test/golden/const.out"+ ] ++ crossTests++-- These are redundant on arm+crossTests :: [TestTree]+crossTests = case arch of+ "x86_64" -> [ compileArm "examples/factorial.kmp"+ , compileArm "lib/numbertheory.kmp"+ , compileArm "test/examples/bool.kmp"+ , compileArm "examples/splitmix.kmp"+ -- , compileArm "lib/gaussian.kmp"+ ]+ "aarch64" -> []+ _ -> error "Test suite must be run on x86_64 or aarch64"
test/Harness.hs view
@@ -1,4 +1,5 @@ module Harness ( goldenOutput+ , compileArm ) where import qualified Data.ByteString.Lazy as BSL@@ -7,9 +8,11 @@ import Kempe.File import System.FilePath ((</>)) import System.IO.Temp+import System.Info (arch) import System.Process (CreateProcess (std_err), StdStream (Inherit), proc, readCreateProcess) import Test.Tasty import Test.Tasty.Golden (goldenVsString)+import Test.Tasty.HUnit (assertBool, testCase) -- | Assemble using @nasm@, output in some file. runGcc :: [FilePath]@@ -18,6 +21,13 @@ runGcc fps o = void $ readCreateProcess ((proc "cc" (fps ++ ["-o", o])) { std_err = Inherit }) "" +compileArm :: FilePath -> TestTree+compileArm fp = testCase "Assembles arm" $+ withSystemTempDirectory "kmp" $ \dir -> do+ let oFile = dir </> "kempe.o"+ armCompile fp oFile False+ assertBool "Doesn't throw exception" True+ compileOutput :: FilePath -> FilePath -> IO BSL.ByteString@@ -25,7 +35,11 @@ withSystemTempDirectory "kmp" $ \dir -> do let oFile = dir </> "kempe.o" exe = dir </> "kempe"- compile fp oFile False+ compiler = case arch of+ "x86_64" -> compile+ "aarch64" -> armCompile+ _ -> error "Internal error in test suite! Must run on either x86_64 or aarch64"+ compiler fp oFile False runGcc [oFile, harness] exe readExe exe where readExe fp' = ASCII.pack <$> readCreateProcess ((proc fp' []) { std_err = Inherit }) ""
+ test/examples/const.kmp view
@@ -0,0 +1,4 @@+id_int : Int -- Int+ =: [ ]++%foreign cabi id_int
test/examples/splitmix.kmp view
@@ -1,8 +1,8 @@ next : Word -- Word Word =: [ 0x9e3779b97f4a7c15u +~ dup- dup 30i8 >>~ xoru 0xbf58476d1ce4e5b9u *~- dup 27i8 >>~ xoru 0x94d049bb133111ebu *~- dup 31i8 >>~ xoru+ dup 30u >>~ xoru 0xbf58476d1ce4e5b9u *~+ dup 27u >>~ xoru 0x94d049bb133111ebu *~+ dup 31u >>~ xoru ] from_seed : Word -- Word
+ test/golden/const.out view
@@ -0,0 +1,1 @@+3
test/golden/gaussian.ir view
@@ -6,7 +6,7 @@ kmp2: (movtemp datapointer (- (reg datapointer) (int 17))) (call kmp1)-(movmem (- (reg datapointer) (int 0)) (mem [1] (+ (reg datapointer) (int 17))))+(movmem (reg datapointer) (mem [1] (+ (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 18)))) (movmem (+ (reg datapointer) (int 2)) (mem [1] (+ (reg datapointer) (int 19)))) (movmem (+ (reg datapointer) (int 3)) (mem [1] (+ (reg datapointer) (int 20))))@@ -23,7 +23,7 @@ (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))))-(movmem (- (reg datapointer) (int 0)) (mem [8] (- (reg datapointer) (int 24))))+(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)))@@ -37,7 +37,7 @@ (movtemp t_4 (mem [8] (reg datapointer))) (movmem (reg datapointer) (+ (reg t_4) (reg t_3))) (movtemp datapointer (+ (reg datapointer) (int 8)))-(movmem (- (reg datapointer) (int 0)) (mem [8] (+ (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)))@@ -46,7 +46,7 @@ kmp3: (movtemp datapointer (- (reg datapointer) (int 17))) (call kmp1)-(movmem (- (reg datapointer) (int 0)) (mem [1] (+ (reg datapointer) (int 17))))+(movmem (reg datapointer) (mem [1] (+ (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 18)))) (movmem (+ (reg datapointer) (int 2)) (mem [1] (+ (reg datapointer) (int 19)))) (movmem (+ (reg datapointer) (int 3)) (mem [1] (+ (reg datapointer) (int 20))))@@ -63,7 +63,7 @@ (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))))-(movmem (- (reg datapointer) (int 0)) (mem [8] (- (reg datapointer) (int 24))))+(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)))@@ -77,7 +77,7 @@ (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) (int 0)) (mem [8] (+ (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)))@@ -86,7 +86,7 @@ (ret) kmp4:-(movmem (- (reg datapointer) (int 0)) (mem [1] (- (reg datapointer) (int 17))))+(movmem (reg datapointer) (mem [1] (- (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 16)))) (movmem (+ (reg datapointer) (int 2)) (mem [1] (- (reg datapointer) (int 15)))) (movmem (+ (reg datapointer) (int 3)) (mem [1] (- (reg datapointer) (int 14))))@@ -120,8 +120,9 @@ (movmem (- (reg datapointer) (int 3)) (mem [1] (- (reg datapointer) (int 20)))) (movmem (- (reg datapointer) (int 2)) (mem [1] (- (reg datapointer) (int 19)))) (movmem (- (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 18))))+(movmem (reg datapointer) (mem [1] (- (reg datapointer) (int 0)))) (movtemp datapointer (+ (reg datapointer) (int 17)))-(movmem (- (reg datapointer) (int 0)) (mem [1] (- (reg datapointer) (int 34))))+(movmem (reg datapointer) (mem [1] (- (reg datapointer) (int 34)))) (movmem (+ (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 33)))) (movmem (+ (reg datapointer) (int 2)) (mem [1] (- (reg datapointer) (int 32)))) (movmem (+ (reg datapointer) (int 3)) (mem [1] (- (reg datapointer) (int 31))))@@ -172,7 +173,7 @@ (movmem (- (reg datapointer) (int 3)) (mem [1] (+ (reg datapointer) (int 14)))) (movmem (- (reg datapointer) (int 2)) (mem [1] (+ (reg datapointer) (int 15)))) (movmem (- (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 16))))-(movmem (- (reg datapointer) (int 0)) (mem [1] (- (reg datapointer) (int 17))))+(movmem (reg datapointer) (mem [1] (- (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 16)))) (movmem (+ (reg datapointer) (int 2)) (mem [1] (- (reg datapointer) (int 15)))) (movmem (+ (reg datapointer) (int 3)) (mem [1] (- (reg datapointer) (int 14))))@@ -206,8 +207,9 @@ (movmem (- (reg datapointer) (int 3)) (mem [1] (- (reg datapointer) (int 20)))) (movmem (- (reg datapointer) (int 2)) (mem [1] (- (reg datapointer) (int 19)))) (movmem (- (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 18))))+(movmem (reg datapointer) (mem [1] (- (reg datapointer) (int 0)))) (movtemp datapointer (+ (reg datapointer) (int 17)))-(movmem (- (reg datapointer) (int 0)) (mem [1] (- (reg datapointer) (int 34))))+(movmem (reg datapointer) (mem [1] (- (reg datapointer) (int 34)))) (movmem (+ (reg datapointer) (int 1)) (mem [1] (- (reg datapointer) (int 33)))) (movmem (+ (reg datapointer) (int 2)) (mem [1] (- (reg datapointer) (int 32)))) (movmem (+ (reg datapointer) (int 3)) (mem [1] (- (reg datapointer) (int 31))))@@ -260,7 +262,7 @@ (movmem (- (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 16)))) (movtemp datapointer (- (reg datapointer) (int 17))) (call kmp1)-(movmem (- (reg datapointer) (int 0)) (mem [1] (+ (reg datapointer) (int 17))))+(movmem (reg datapointer) (mem [1] (+ (reg datapointer) (int 17)))) (movmem (+ (reg datapointer) (int 1)) (mem [1] (+ (reg datapointer) (int 18)))) (movmem (+ (reg datapointer) (int 2)) (mem [1] (+ (reg datapointer) (int 19)))) (movmem (+ (reg datapointer) (int 3)) (mem [1] (+ (reg datapointer) (int 20))))@@ -283,9 +285,9 @@ (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) (int 0)) (mem [8] (+ (reg datapointer) (int 8))))+(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) (movtemp datapointer (+ (reg datapointer) (int 8)))-(movmem (- (reg datapointer) (int 0)) (mem [8] (- (reg datapointer) (int 16))))+(movmem (reg datapointer) (mem [8] (- (reg datapointer) (int 16)))) (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)))@@ -294,13 +296,13 @@ (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) (int 0)) (mem [8] (+ (reg datapointer) (int 8))))+(movmem (reg datapointer) (mem [8] (+ (reg datapointer) (int 8)))) (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) (int 0)) (mem [8] (+ (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)))
+ test/harness/const.c view
@@ -0,0 +1,7 @@+#include <stdio.h>++extern int id_int(int);++int main(int argc, char *argv[]) {+ printf("%d", id_int(3));+}