diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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 diff --git a/docs/manual.pdf b/docs/manual.pdf Binary files a/docs/manual.pdf and b/docs/manual.pdf differ diff --git a/examples/splitmix.kmp b/examples/splitmix.kmp --- a/examples/splitmix.kmp +++ b/examples/splitmix.kmp @@ -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 diff --git a/kempe.cabal b/kempe.cabal --- a/kempe.cabal +++ b/kempe.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: kempe -version: 0.1.1.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: diff --git a/run/Main.hs b/run/Main.hs --- a/run/Main.hs +++ b/run/Main.hs @@ -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) diff --git a/src/Kempe/Asm/Arm/ControlFlow.hs b/src/Kempe/Asm/Arm/ControlFlow.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Arm/ControlFlow.hs @@ -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 diff --git a/src/Kempe/Asm/Arm/Linear.hs b/src/Kempe/Asm/Arm/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Arm/Linear.hs @@ -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 diff --git a/src/Kempe/Asm/Arm/Opt.hs b/src/Kempe/Asm/Arm/Opt.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Arm/Opt.hs @@ -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 [] = [] diff --git a/src/Kempe/Asm/Arm/Trans.hs b/src/Kempe/Asm/Arm/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Arm/Trans.hs @@ -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 diff --git a/src/Kempe/Asm/Arm/Type.hs b/src/Kempe/Asm/Arm/Type.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Arm/Type.hs @@ -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 diff --git a/src/Kempe/Asm/Pretty.hs b/src/Kempe/Asm/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Asm/Pretty.hs @@ -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 diff --git a/src/Kempe/Asm/X86/ControlFlow.hs b/src/Kempe/Asm/X86/ControlFlow.hs --- a/src/Kempe/Asm/X86/ControlFlow.hs +++ b/src/Kempe/Asm/X86/ControlFlow.hs @@ -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 diff --git a/src/Kempe/Asm/X86/Linear.hs b/src/Kempe/Asm/X86/Linear.hs --- a/src/Kempe/Asm/X86/Linear.hs +++ b/src/Kempe/Asm/X86/Linear.hs @@ -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 diff --git a/src/Kempe/Asm/X86/Trans.hs b/src/Kempe/Asm/X86/Trans.hs --- a/src/Kempe/Asm/X86/Trans.hs +++ b/src/Kempe/Asm/X86/Trans.hs @@ -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 diff --git a/src/Kempe/Asm/X86/Type.hs b/src/Kempe/Asm/X86/Type.hs --- a/src/Kempe/Asm/X86/Type.hs +++ b/src/Kempe/Asm/X86/Type.hs @@ -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 diff --git a/src/Kempe/Debug.hs b/src/Kempe/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Debug.hs @@ -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 diff --git a/src/Kempe/File.hs b/src/Kempe/File.hs --- a/src/Kempe/File.hs +++ b/src/Kempe/File.hs @@ -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 diff --git a/src/Kempe/IR.hs b/src/Kempe/IR.hs --- a/src/Kempe/IR.hs +++ b/src/Kempe/IR.hs @@ -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 diff --git a/src/Kempe/IR/Monad.hs b/src/Kempe/IR/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/IR/Monad.hs @@ -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 diff --git a/src/Kempe/IR/Opt.hs b/src/Kempe/IR/Opt.hs --- a/src/Kempe/IR/Opt.hs +++ b/src/Kempe/IR/Opt.hs @@ -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 diff --git a/src/Kempe/IR/Type.hs b/src/Kempe/IR/Type.hs --- a/src/Kempe/IR/Type.hs +++ b/src/Kempe/IR/Type.hs @@ -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? diff --git a/src/Kempe/Pipeline.hs b/src/Kempe/Pipeline.hs --- a/src/Kempe/Pipeline.hs +++ b/src/Kempe/Pipeline.hs @@ -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 diff --git a/src/Kempe/Proc/As.hs b/src/Kempe/Proc/As.hs new file mode 100644 --- /dev/null +++ b/src/Kempe/Proc/As.hs @@ -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 diff --git a/src/Kempe/TyAssign.hs b/src/Kempe/TyAssign.hs --- a/src/Kempe/TyAssign.hs +++ b/src/Kempe/TyAssign.hs @@ -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 diff --git a/src/Prettyprinter/Ext.hs b/src/Prettyprinter/Ext.hs --- a/src/Prettyprinter/Ext.hs +++ b/src/Prettyprinter/Ext.hs @@ -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) diff --git a/test/Backend.hs b/test/Backend.hs --- a/test/Backend.hs +++ b/test/Backend.hs @@ -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 diff --git a/test/Golden.hs b/test/Golden.hs --- a/test/Golden.hs +++ b/test/Golden.hs @@ -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" diff --git a/test/Harness.hs b/test/Harness.hs --- a/test/Harness.hs +++ b/test/Harness.hs @@ -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 }) "" diff --git a/test/examples/const.kmp b/test/examples/const.kmp new file mode 100644 --- /dev/null +++ b/test/examples/const.kmp @@ -0,0 +1,4 @@ +id_int : Int -- Int + =: [ ] + +%foreign cabi id_int diff --git a/test/examples/splitmix.kmp b/test/examples/splitmix.kmp --- a/test/examples/splitmix.kmp +++ b/test/examples/splitmix.kmp @@ -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 diff --git a/test/golden/const.out b/test/golden/const.out new file mode 100644 --- /dev/null +++ b/test/golden/const.out @@ -0,0 +1,1 @@ +3 diff --git a/test/golden/gaussian.ir b/test/golden/gaussian.ir --- a/test/golden/gaussian.ir +++ b/test/golden/gaussian.ir @@ -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))) diff --git a/test/harness/const.c b/test/harness/const.c new file mode 100644 --- /dev/null +++ b/test/harness/const.c @@ -0,0 +1,7 @@ +#include + +extern int id_int(int); + +int main(int argc, char *argv[]) { + printf("%d", id_int(3)); +}