{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, MultiWayIf, ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.Asm.Inline.QQ ( asm , asmTy , substitute , unroll , unrolls ) where import qualified Data.Map as M import Control.Applicative(ZipList(..)) import Control.Monad.Combinators.Expr as CE import Control.Monad.Except import Control.Monad.State.Strict import Data.Bifunctor import Data.Char import Data.Either.Combinators import Data.Foldable import Data.Functor import Data.List import Data.String import Data.Void import Foreign.Ptr import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as ML import Language.Asm.Inline.AsmCode instance AsmCode AsmQQType AsmQQCode where codeToString :: AsmQQType -> AsmQQCode -> String codeToString AsmQQType ty AsmQQCode code = case AsmQQType -> AsmQQCode -> Either String AsmQQCode substituteArgs AsmQQType ty AsmQQCode code of Left String e -> forall a. HasCallStack => String -> a error String e Right AsmQQCode s -> AsmQQCode -> String asmCode AsmQQCode s toTypeQ :: AsmQQType -> Q Type toTypeQ = AsmQQType -> Q Type unreflectTy asm :: QuasiQuoter asm :: QuasiQuoter asm = (String -> Q Exp) -> QuasiQuoter expQQ String -> Q Exp asmQE asmQE :: String -> Q Exp asmQE :: String -> Q Exp asmQE String p = [e| AsmQQCode p |] newtype AsmQQCode = AsmQQCode { AsmQQCode -> String asmCode :: String } instance Semigroup AsmQQCode where AsmQQCode c1 <> :: AsmQQCode -> AsmQQCode -> AsmQQCode <> AsmQQCode c2 = String -> AsmQQCode AsmQQCode forall a b. (a -> b) -> a -> b $ AsmQQCode -> String asmCode AsmQQCode c1 forall a. Semigroup a => a -> a -> a <> String "\n" forall a. Semigroup a => a -> a -> a <> AsmQQCode -> String asmCode AsmQQCode c2 instance Monoid AsmQQCode where mempty :: AsmQQCode mempty = String -> AsmQQCode AsmQQCode String "" parseExpr :: MonadError String m => String -> String -> m (Int -> Int) parseExpr :: forall (m :: * -> *). MonadError String m => String -> String -> m (Int -> Int) parseExpr String var String inputStr = forall e (m :: * -> *) a. MonadError e m => Either e a -> m a liftEither forall a b. (a -> b) -> a -> b $ forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first ParseErrorBundle String Void -> String showParseError forall a b. (a -> b) -> a -> b $ forall e s a. Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a runParser (ParsecT Void String Identity (Int -> Int) expr forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* forall e s (m :: * -> *). MonadParsec e s m => m () eof) String "" String inputStr where expr :: ParsecT Void String Identity (Int -> Int) expr = forall (m :: * -> *) a. MonadPlus m => m a -> [[Operator m a]] -> m a makeExprParser ParsecT Void String Identity (Int -> Int) term forall {t}. [[Operator (ParsecT Void String Identity) (t -> Int)]] table forall e s (m :: * -> *) a. MonadParsec e s m => m a -> String -> m a <?> String "expr" term :: ParsecT Void String Identity (Int -> Int) term = forall {a}. ParsecT Void String Identity a -> ParsecT Void String Identity a parens ParsecT Void String Identity (Int -> Int) expr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall {a}. ParsecT Void String Identity a -> ParsecT Void String Identity a lexeme (forall e s (m :: * -> *) a. (MonadParsec e s m, Token s ~ Char, Num a) => m () -> m a -> m a ML.signed ParsecT Void String Identity () lexSpace (forall e s (m :: * -> *). MonadParsec e s m => Tokens s -> m (Tokens s) string Tokens String "0x" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> forall e s (m :: * -> *) a. (MonadParsec e s m, Token s ~ Char, Num a) => m a ML.hexadecimal forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall e s (m :: * -> *) a. (MonadParsec e s m, Token s ~ Char, Num a) => m a ML.decimal) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> forall a b. a -> b -> a const) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall {a}. ParsecT Void String Identity a -> ParsecT Void String Identity a lexeme (forall e s (m :: * -> *). MonadParsec e s m => Tokens s -> m (Tokens s) string String var forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> forall a. a -> a id) table :: [[Operator (ParsecT Void String Identity) (t -> Int)]] table = [ [ forall {t} {t}. Tokens String -> (t -> t -> t) -> Operator (ParsecT Void String Identity) (t -> t) binary Tokens String "*" forall a. Num a => a -> a -> a (*) ] , [ forall {t} {t}. Tokens String -> (t -> t -> t) -> Operator (ParsecT Void String Identity) (t -> t) binary Tokens String "+" forall a. Num a => a -> a -> a (+) , forall {t} {t}. Tokens String -> (t -> t -> t) -> Operator (ParsecT Void String Identity) (t -> t) binary Tokens String "-" (-) ] ] binary :: Tokens String -> (t -> t -> t) -> Operator (ParsecT Void String Identity) (t -> t) binary Tokens String name t -> t -> t fun = forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a CE.InfixL forall a b. (a -> b) -> a -> b $ Tokens String -> ParsecT Void String Identity (Tokens String) symbol Tokens String name forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> (\t -> t l t -> t r t n -> t -> t l t n t -> t -> t `fun` t -> t r t n) symbol :: Tokens String -> ParsecT Void String Identity (Tokens String) symbol = forall e s (m :: * -> *). MonadParsec e s m => m () -> Tokens s -> m (Tokens s) ML.symbol ParsecT Void String Identity () lexSpace parens :: ParsecT Void String Identity a -> ParsecT Void String Identity a parens = forall (m :: * -> *) open close a. Applicative m => m open -> m close -> m a -> m a between (Tokens String -> ParsecT Void String Identity (Tokens String) symbol Tokens String "(") (Tokens String -> ParsecT Void String Identity (Tokens String) symbol Tokens String ")") lexeme :: ParsecT Void String Identity a -> ParsecT Void String Identity a lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a ML.lexeme ParsecT Void String Identity () lexSpace lexSpace :: ParsecT Void String Identity () lexSpace = forall e s (m :: * -> *). MonadParsec e s m => m () -> m () -> m () -> m () ML.space forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m () space1 forall (f :: * -> *) a. Alternative f => f a empty forall (f :: * -> *) a. Alternative f => f a empty unroll :: String -> [Int] -> AsmQQCode -> AsmQQCode unroll :: String -> [Int] -> AsmQQCode -> AsmQQCode unroll String var [Int] ints AsmQQCode code = case forall (f :: * -> *). Applicative f => (String -> f String) -> AsmQQCode -> Either String (f AsmQQCode) substitute String -> ZipList String sub AsmQQCode code of Left String err -> forall a. HasCallStack => String -> a error String err Right ZipList AsmQQCode codes -> forall a. Monoid a => [a] -> a mconcat forall a b. (a -> b) -> a -> b $ forall a. ZipList a -> [a] getZipList ZipList AsmQQCode codes where sub :: String -> ZipList String sub String str = case forall (m :: * -> *). MonadError String m => String -> String -> m (Int -> Int) parseExpr String var String str of Right Int -> Int fun -> forall a. [a] -> ZipList a ZipList forall a b. (a -> b) -> a -> b $ forall a. Show a => a -> String show forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> Int fun forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Int] ints Left String _ -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ String "{" forall a. Semigroup a => a -> a -> a <> String str forall a. Semigroup a => a -> a -> a <> String "}" unrolls :: String -> [Int] -> [AsmQQCode] -> AsmQQCode unrolls :: String -> [Int] -> [AsmQQCode] -> AsmQQCode unrolls String var [Int] ints = forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap forall a b. (a -> b) -> a -> b $ String -> [Int] -> AsmQQCode -> AsmQQCode unroll String var [Int] ints substitute :: Applicative f => (String -> f String) -> AsmQQCode -> Either String (f AsmQQCode) substitute :: forall (f :: * -> *). Applicative f => (String -> f String) -> AsmQQCode -> Either String (f AsmQQCode) substitute String -> f String subst AsmQQCode { String asmCode :: String asmCode :: AsmQQCode -> String .. } = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap String -> AsmQQCode AsmQQCode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> Either String (f String) go String asmCode where go :: String -> Either String (f String) go (Char '{' : String rest) | (String argStr, Char '}' : String rest') <- forall a. (a -> Bool) -> [a] -> ([a], [a]) break (forall a. Eq a => a -> a -> Bool == Char '}') String rest , Bool -> Bool not forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t a -> Bool null String argStr = (forall a. Semigroup a => a -> a -> a (<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> f String subst (String -> String trim String argStr) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> Either String (f String) go String rest' | Bool otherwise = forall a b. a -> Either a b Left forall a b. (a -> b) -> a -> b $ String "Unable to parse argument: " forall a. Semigroup a => a -> a -> a <> forall a. Int -> [a] -> [a] take Int 20 String rest forall a. Semigroup a => a -> a -> a <> String "..." go (Char x : String xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Char x forall a. a -> [a] -> [a] :) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> Either String (f String) go String xs go [] = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Applicative f => a -> f a pure [] substituteArgs :: AsmQQType -> AsmQQCode -> Either String AsmQQCode substituteArgs :: AsmQQType -> AsmQQCode -> Either String AsmQQCode substituteArgs AsmQQType { [(AsmVarName, AsmVarType)] rets :: AsmQQType -> [(AsmVarName, AsmVarType)] args :: AsmQQType -> [(AsmVarName, AsmVarType)] rets :: [(AsmVarName, AsmVarType)] args :: [(AsmVarName, AsmVarType)] .. } AsmQQCode asmCode = do [(AsmVarName, RegName)] argRegs <- [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)] computeRegisters [(AsmVarName, AsmVarType)] args [(AsmVarName, RegName)] retRegs <- [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)] computeRegisters [(AsmVarName, AsmVarType)] rets StateT (Map AsmVarName RegName) (Either String) AsmQQCode res <- forall (f :: * -> *). Applicative f => (String -> f String) -> AsmQQCode -> Either String (f AsmQQCode) substitute forall {m :: * -> *}. (MonadState (Map AsmVarName RegName) m, MonadError String m) => String -> m String subst AsmQQCode asmCode forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a evalStateT StateT (Map AsmVarName RegName) (Either String) AsmQQCode res forall a b. (a -> b) -> a -> b $ forall k a. Ord k => [(k, a)] -> Map k a M.fromList forall a b. (a -> b) -> a -> b $ [(AsmVarName, RegName)] retRegs forall a. Semigroup a => a -> a -> a <> [(AsmVarName, RegName)] argRegs where subst :: String -> m String subst String arg | String "move" forall a. Eq a => [a] -> [a] -> Bool `isPrefixOf` String arg = String -> m String moveReg String arg | Bool otherwise = do let var :: AsmVarName var = String -> AsmVarName AsmVarName String arg Maybe RegName maybeReg <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a gets forall a b. (a -> b) -> a -> b $ \Map AsmVarName RegName regMap -> forall k a. Ord k => k -> Map k a -> Maybe a M.lookup AsmVarName var Map AsmVarName RegName regMap RegName String reg <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a liftEither forall a b. (a -> b) -> a -> b $ forall b a. b -> Maybe a -> Either b a maybeToRight (String "Unknown argument: `" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show AsmVarName var forall a. Semigroup a => a -> a -> a <> String "`") Maybe RegName maybeReg forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ Char '%' forall a. a -> [a] -> [a] : String reg moveReg :: String -> m String moveReg (String -> [String] words -> [String "move", String regName, String reg]) = do String oldReg <- String -> m String subst String regName let mov :: String mov = String "mov " forall a. Semigroup a => a -> a -> a <> String oldReg forall a. Semigroup a => a -> a -> a <> String ", %" forall a. Semigroup a => a -> a -> a <> String reg forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify' forall a b. (a -> b) -> a -> b $ forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert (String -> AsmVarName AsmVarName String regName) (String -> RegName RegName String reg) forall (f :: * -> *) a. Applicative f => a -> f a pure String mov moveReg String s = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ String "Unable to parse move command `" forall a. Semigroup a => a -> a -> a <> String s forall a. Semigroup a => a -> a -> a <> String "`" newtype RegName = RegName { RegName -> String regName :: String } deriving (Int -> RegName -> String -> String [RegName] -> String -> String RegName -> String forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [RegName] -> String -> String $cshowList :: [RegName] -> String -> String show :: RegName -> String $cshow :: RegName -> String showsPrec :: Int -> RegName -> String -> String $cshowsPrec :: Int -> RegName -> String -> String Show, String -> RegName forall a. (String -> a) -> IsString a fromString :: String -> RegName $cfromString :: String -> RegName IsString) computeRegisters :: [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)] computeRegisters :: [(AsmVarName, AsmVarType)] -> Either String [(AsmVarName, RegName)] computeRegisters [(AsmVarName, AsmVarType)] vars = forall a b. (a, b) -> a fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM ([(AsmVarName, RegName)], Map VarTyCat Int) -> (AsmVarName, AsmVarType) -> Either String ([(AsmVarName, RegName)], Map VarTyCat Int) handleType ([], forall a. Monoid a => a mempty) [(AsmVarName, AsmVarType)] vars where handleType :: ([(AsmVarName, RegName)], Map VarTyCat Int) -> (AsmVarName, AsmVarType) -> Either String ([(AsmVarName, RegName)], Map VarTyCat Int) handleType ([(AsmVarName, RegName)] regNames, Map VarTyCat Int regCounts) (AsmVarName name, AsmVarType ty) = do [(AsmVarName, VarTyCat)] cats <- AsmVarName -> AsmVarType -> Either String [(AsmVarName, VarTyCat)] categorize AsmVarName name AsmVarType ty forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM forall {a}. ([(a, RegName)], Map VarTyCat Int) -> (a, VarTyCat) -> Either String ([(a, RegName)], Map VarTyCat Int) handleCats ([(AsmVarName, RegName)] regNames, Map VarTyCat Int regCounts) [(AsmVarName, VarTyCat)] cats handleCats :: ([(a, RegName)], Map VarTyCat Int) -> (a, VarTyCat) -> Either String ([(a, RegName)], Map VarTyCat Int) handleCats ([(a, RegName)] regNames, Map VarTyCat Int regCounts) (a name, VarTyCat cat) = do RegName reg <- VarTyCat -> Int -> Either String RegName argIdxToReg VarTyCat cat Int idx forall (f :: * -> *) a. Applicative f => a -> f a pure ((a name, RegName reg) forall a. a -> [a] -> [a] : [(a, RegName)] regNames, forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert VarTyCat cat (Int idx forall a. Num a => a -> a -> a + Int 1) Map VarTyCat Int regCounts) where idx :: Int idx = forall k a. Ord k => a -> k -> Map k a -> a M.findWithDefault Int 0 VarTyCat cat Map VarTyCat Int regCounts data VarTyCat = Integer | Other deriving (VarTyCat -> VarTyCat -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: VarTyCat -> VarTyCat -> Bool $c/= :: VarTyCat -> VarTyCat -> Bool == :: VarTyCat -> VarTyCat -> Bool $c== :: VarTyCat -> VarTyCat -> Bool Eq, Eq VarTyCat VarTyCat -> VarTyCat -> Bool VarTyCat -> VarTyCat -> Ordering VarTyCat -> VarTyCat -> VarTyCat forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: VarTyCat -> VarTyCat -> VarTyCat $cmin :: VarTyCat -> VarTyCat -> VarTyCat max :: VarTyCat -> VarTyCat -> VarTyCat $cmax :: VarTyCat -> VarTyCat -> VarTyCat >= :: VarTyCat -> VarTyCat -> Bool $c>= :: VarTyCat -> VarTyCat -> Bool > :: VarTyCat -> VarTyCat -> Bool $c> :: VarTyCat -> VarTyCat -> Bool <= :: VarTyCat -> VarTyCat -> Bool $c<= :: VarTyCat -> VarTyCat -> Bool < :: VarTyCat -> VarTyCat -> Bool $c< :: VarTyCat -> VarTyCat -> Bool compare :: VarTyCat -> VarTyCat -> Ordering $ccompare :: VarTyCat -> VarTyCat -> Ordering Ord, Int -> VarTyCat -> String -> String [VarTyCat] -> String -> String VarTyCat -> String forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [VarTyCat] -> String -> String $cshowList :: [VarTyCat] -> String -> String show :: VarTyCat -> String $cshow :: VarTyCat -> String showsPrec :: Int -> VarTyCat -> String -> String $cshowsPrec :: Int -> VarTyCat -> String -> String Show, Int -> VarTyCat VarTyCat -> Int VarTyCat -> [VarTyCat] VarTyCat -> VarTyCat VarTyCat -> VarTyCat -> [VarTyCat] VarTyCat -> VarTyCat -> VarTyCat -> [VarTyCat] forall a. (a -> a) -> (a -> a) -> (Int -> a) -> (a -> Int) -> (a -> [a]) -> (a -> a -> [a]) -> (a -> a -> [a]) -> (a -> a -> a -> [a]) -> Enum a enumFromThenTo :: VarTyCat -> VarTyCat -> VarTyCat -> [VarTyCat] $cenumFromThenTo :: VarTyCat -> VarTyCat -> VarTyCat -> [VarTyCat] enumFromTo :: VarTyCat -> VarTyCat -> [VarTyCat] $cenumFromTo :: VarTyCat -> VarTyCat -> [VarTyCat] enumFromThen :: VarTyCat -> VarTyCat -> [VarTyCat] $cenumFromThen :: VarTyCat -> VarTyCat -> [VarTyCat] enumFrom :: VarTyCat -> [VarTyCat] $cenumFrom :: VarTyCat -> [VarTyCat] fromEnum :: VarTyCat -> Int $cfromEnum :: VarTyCat -> Int toEnum :: Int -> VarTyCat $ctoEnum :: Int -> VarTyCat pred :: VarTyCat -> VarTyCat $cpred :: VarTyCat -> VarTyCat succ :: VarTyCat -> VarTyCat $csucc :: VarTyCat -> VarTyCat Enum, VarTyCat forall a. a -> a -> Bounded a maxBound :: VarTyCat $cmaxBound :: VarTyCat minBound :: VarTyCat $cminBound :: VarTyCat Bounded) categorize :: AsmVarName -> AsmVarType -> Either String [(AsmVarName, VarTyCat)] categorize :: AsmVarName -> AsmVarType -> Either String [(AsmVarName, VarTyCat)] categorize AsmVarName name (AsmVarType String ty) | String ty forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` (forall {a}. (Semigroup a, IsString a) => a -> [a] integralFamily String "Int" forall a. Semigroup a => a -> a -> a <> forall {a}. (Semigroup a, IsString a) => a -> [a] integralFamily String "Word" forall a. Semigroup a => a -> a -> a <> [String "Ptr", String "Unit"]) = forall (f :: * -> *) a. Applicative f => a -> f a pure [(AsmVarName name, VarTyCat Integer)] | String ty forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [String "Float", String "Double"] = forall (f :: * -> *) a. Applicative f => a -> f a pure [(AsmVarName name, VarTyCat Other)] where integralFamily :: a -> [a] integralFamily a base = [a base, a base forall a. Semigroup a => a -> a -> a <> a "8", a base forall a. Semigroup a => a -> a -> a <> a "16", a base forall a. Semigroup a => a -> a -> a <> a "32", a base forall a. Semigroup a => a -> a -> a <> a "64"] categorize AsmVarName name (AsmVarType String "ByteString") = forall (f :: * -> *) a. Applicative f => a -> f a pure [(AsmVarName name forall a. Semigroup a => a -> a -> a <> AsmVarName ":ptr", VarTyCat Integer), (AsmVarName name forall a. Semigroup a => a -> a -> a <> AsmVarName ":len", VarTyCat Integer)] categorize AsmVarName _ (AsmVarType String s) = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ String "Unknown register type for variable type `" forall a. Semigroup a => a -> a -> a <> String s forall a. Semigroup a => a -> a -> a <> String "`" argIdxToReg :: VarTyCat -> Int -> Either String RegName argIdxToReg :: VarTyCat -> Int -> Either String RegName argIdxToReg VarTyCat Integer Int 0 = forall (f :: * -> *) a. Applicative f => a -> f a pure RegName "rbx" argIdxToReg VarTyCat Integer Int 1 = forall (f :: * -> *) a. Applicative f => a -> f a pure RegName "r14" argIdxToReg VarTyCat Integer Int 2 = forall (f :: * -> *) a. Applicative f => a -> f a pure RegName "rsi" argIdxToReg VarTyCat Integer Int 3 = forall (f :: * -> *) a. Applicative f => a -> f a pure RegName "rdi" argIdxToReg VarTyCat Integer Int 4 = forall (f :: * -> *) a. Applicative f => a -> f a pure RegName "r8" argIdxToReg VarTyCat Integer Int 5 = forall (f :: * -> *) a. Applicative f => a -> f a pure RegName "r9" argIdxToReg VarTyCat Other Int n | Int n forall a. Ord a => a -> a -> Bool >= Int 0 Bool -> Bool -> Bool && Int n forall a. Ord a => a -> a -> Bool <= Int 6 = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ String -> RegName RegName forall a b. (a -> b) -> a -> b $ String "xmm" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show (Int n forall a. Num a => a -> a -> a + Int 1) argIdxToReg VarTyCat _ Int n = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ String "Unsupported register index: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show Int n trim :: String -> String trim :: String -> String trim = String -> String pass forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String pass where pass :: String -> String pass = forall a. [a] -> [a] reverse forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. (a -> Bool) -> [a] -> [a] dropWhile (forall a. Eq a => a -> a -> Bool == Char ' ') findSplitter :: String -> Either String (String, String) findSplitter :: String -> Either String (String, String) findSplitter String p = case forall a. (a -> Bool) -> [a] -> ([a], [a]) break (forall a. Eq a => a -> a -> Bool == Char '|') String p of (String vars, Char '|' : String body) -> forall (f :: * -> *) a. Applicative f => a -> f a pure (String vars, String body) (String, String) _ -> forall e (m :: * -> *) a. MonadError e m => e -> m a throwError String "Unable to find variable section separator" expQQ :: (String -> Q Exp) -> QuasiQuoter expQQ :: (String -> Q Exp) -> QuasiQuoter expQQ String -> Q Exp qq = QuasiQuoter { quoteExp :: String -> Q Exp quoteExp = String -> Q Exp qq, quotePat :: String -> Q Pat quotePat = forall {b} {a}. b -> a unsupported, quoteType :: String -> Q Type quoteType = forall {b} {a}. b -> a unsupported, quoteDec :: String -> Q [Dec] quoteDec = forall {b} {a}. b -> a unsupported } where unsupported :: b -> a unsupported = forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ forall a. HasCallStack => String -> a error String "Unsupported quasiquotation type" asmTy :: QuasiQuoter asmTy :: QuasiQuoter asmTy = (String -> Q Exp) -> QuasiQuoter expQQ String -> Q Exp asmTyQE asmTyQE :: String -> Q Exp asmTyQE :: String -> Q Exp asmTyQE String str = case String -> Either String AsmQQType parseAsmTyQQ String str of Left String err -> forall a. HasCallStack => String -> a error String err Right AsmQQType parsed -> [e| parsed |] newtype AsmVarName = AsmVarName { AsmVarName -> String varName :: String } deriving (Int -> AsmVarName -> String -> String [AsmVarName] -> String -> String AsmVarName -> String forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [AsmVarName] -> String -> String $cshowList :: [AsmVarName] -> String -> String show :: AsmVarName -> String $cshow :: AsmVarName -> String showsPrec :: Int -> AsmVarName -> String -> String $cshowsPrec :: Int -> AsmVarName -> String -> String Show, AsmVarName -> AsmVarName -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: AsmVarName -> AsmVarName -> Bool $c/= :: AsmVarName -> AsmVarName -> Bool == :: AsmVarName -> AsmVarName -> Bool $c== :: AsmVarName -> AsmVarName -> Bool Eq, Eq AsmVarName AsmVarName -> AsmVarName -> Bool AsmVarName -> AsmVarName -> Ordering AsmVarName -> AsmVarName -> AsmVarName forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: AsmVarName -> AsmVarName -> AsmVarName $cmin :: AsmVarName -> AsmVarName -> AsmVarName max :: AsmVarName -> AsmVarName -> AsmVarName $cmax :: AsmVarName -> AsmVarName -> AsmVarName >= :: AsmVarName -> AsmVarName -> Bool $c>= :: AsmVarName -> AsmVarName -> Bool > :: AsmVarName -> AsmVarName -> Bool $c> :: AsmVarName -> AsmVarName -> Bool <= :: AsmVarName -> AsmVarName -> Bool $c<= :: AsmVarName -> AsmVarName -> Bool < :: AsmVarName -> AsmVarName -> Bool $c< :: AsmVarName -> AsmVarName -> Bool compare :: AsmVarName -> AsmVarName -> Ordering $ccompare :: AsmVarName -> AsmVarName -> Ordering Ord, forall t. (forall (m :: * -> *). Quote m => t -> m Exp) -> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t forall (m :: * -> *). Quote m => AsmVarName -> m Exp forall (m :: * -> *). Quote m => AsmVarName -> Code m AsmVarName liftTyped :: forall (m :: * -> *). Quote m => AsmVarName -> Code m AsmVarName $cliftTyped :: forall (m :: * -> *). Quote m => AsmVarName -> Code m AsmVarName lift :: forall (m :: * -> *). Quote m => AsmVarName -> m Exp $clift :: forall (m :: * -> *). Quote m => AsmVarName -> m Exp Lift, NonEmpty AsmVarName -> AsmVarName AsmVarName -> AsmVarName -> AsmVarName forall b. Integral b => b -> AsmVarName -> AsmVarName forall a. (a -> a -> a) -> (NonEmpty a -> a) -> (forall b. Integral b => b -> a -> a) -> Semigroup a stimes :: forall b. Integral b => b -> AsmVarName -> AsmVarName $cstimes :: forall b. Integral b => b -> AsmVarName -> AsmVarName sconcat :: NonEmpty AsmVarName -> AsmVarName $csconcat :: NonEmpty AsmVarName -> AsmVarName <> :: AsmVarName -> AsmVarName -> AsmVarName $c<> :: AsmVarName -> AsmVarName -> AsmVarName Semigroup, String -> AsmVarName forall a. (String -> a) -> IsString a fromString :: String -> AsmVarName $cfromString :: String -> AsmVarName IsString) newtype AsmVarType = AsmVarType { AsmVarType -> String varType :: String } deriving (Int -> AsmVarType -> String -> String [AsmVarType] -> String -> String AsmVarType -> String forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [AsmVarType] -> String -> String $cshowList :: [AsmVarType] -> String -> String show :: AsmVarType -> String $cshow :: AsmVarType -> String showsPrec :: Int -> AsmVarType -> String -> String $cshowsPrec :: Int -> AsmVarType -> String -> String Show, AsmVarType -> AsmVarType -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: AsmVarType -> AsmVarType -> Bool $c/= :: AsmVarType -> AsmVarType -> Bool == :: AsmVarType -> AsmVarType -> Bool $c== :: AsmVarType -> AsmVarType -> Bool Eq, Eq AsmVarType AsmVarType -> AsmVarType -> Bool AsmVarType -> AsmVarType -> Ordering AsmVarType -> AsmVarType -> AsmVarType forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: AsmVarType -> AsmVarType -> AsmVarType $cmin :: AsmVarType -> AsmVarType -> AsmVarType max :: AsmVarType -> AsmVarType -> AsmVarType $cmax :: AsmVarType -> AsmVarType -> AsmVarType >= :: AsmVarType -> AsmVarType -> Bool $c>= :: AsmVarType -> AsmVarType -> Bool > :: AsmVarType -> AsmVarType -> Bool $c> :: AsmVarType -> AsmVarType -> Bool <= :: AsmVarType -> AsmVarType -> Bool $c<= :: AsmVarType -> AsmVarType -> Bool < :: AsmVarType -> AsmVarType -> Bool $c< :: AsmVarType -> AsmVarType -> Bool compare :: AsmVarType -> AsmVarType -> Ordering $ccompare :: AsmVarType -> AsmVarType -> Ordering Ord, forall t. (forall (m :: * -> *). Quote m => t -> m Exp) -> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t forall (m :: * -> *). Quote m => AsmVarType -> m Exp forall (m :: * -> *). Quote m => AsmVarType -> Code m AsmVarType liftTyped :: forall (m :: * -> *). Quote m => AsmVarType -> Code m AsmVarType $cliftTyped :: forall (m :: * -> *). Quote m => AsmVarType -> Code m AsmVarType lift :: forall (m :: * -> *). Quote m => AsmVarType -> m Exp $clift :: forall (m :: * -> *). Quote m => AsmVarType -> m Exp Lift) data AsmQQType = AsmQQType { AsmQQType -> [(AsmVarName, AsmVarType)] args :: [(AsmVarName, AsmVarType)] , AsmQQType -> [(AsmVarName, AsmVarType)] rets :: [(AsmVarName, AsmVarType)] } deriving (Int -> AsmQQType -> String -> String [AsmQQType] -> String -> String AsmQQType -> String forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [AsmQQType] -> String -> String $cshowList :: [AsmQQType] -> String -> String show :: AsmQQType -> String $cshow :: AsmQQType -> String showsPrec :: Int -> AsmQQType -> String -> String $cshowsPrec :: Int -> AsmQQType -> String -> String Show, forall t. (forall (m :: * -> *). Quote m => t -> m Exp) -> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t forall (m :: * -> *). Quote m => AsmQQType -> m Exp forall (m :: * -> *). Quote m => AsmQQType -> Code m AsmQQType liftTyped :: forall (m :: * -> *). Quote m => AsmQQType -> Code m AsmQQType $cliftTyped :: forall (m :: * -> *). Quote m => AsmQQType -> Code m AsmQQType lift :: forall (m :: * -> *). Quote m => AsmQQType -> m Exp $clift :: forall (m :: * -> *). Quote m => AsmQQType -> m Exp Lift) parseAsmTyQQ :: String -> Either String AsmQQType parseAsmTyQQ :: String -> Either String AsmQQType parseAsmTyQQ String str = do (String inputStr, String outputStr) <- String -> Either String (String, String) findSplitter String str [(AsmVarName, AsmVarType)] args <- forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first ParseErrorBundle String Void -> String showParseError forall a b. (a -> b) -> a -> b $ forall e s a. Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a runParser (forall (m :: * -> *) e. MonadParsec e String m => m [(AsmVarName, AsmVarType)] parseInTypes forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* forall e s (m :: * -> *). MonadParsec e s m => m () eof) String "" String inputStr [(AsmVarName, AsmVarType)] rets <- forall (p :: * -> * -> *) a b c. Bifunctor p => (a -> b) -> p a c -> p b c first ParseErrorBundle String Void -> String showParseError forall a b. (a -> b) -> a -> b $ forall e s a. Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a runParser (forall (m :: * -> *) e. MonadParsec e String m => m [(AsmVarName, AsmVarType)] parseInTypes forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* forall e s (m :: * -> *). MonadParsec e s m => m () eof) String "" String outputStr forall (f :: * -> *) a. Applicative f => a -> f a pure AsmQQType { [(AsmVarName, AsmVarType)] rets :: [(AsmVarName, AsmVarType)] args :: [(AsmVarName, AsmVarType)] rets :: [(AsmVarName, AsmVarType)] args :: [(AsmVarName, AsmVarType)] .. } showParseError :: ParseErrorBundle String Void -> String showParseError :: ParseErrorBundle String Void -> String showParseError = forall s e. (VisualStream s, TraversableStream s, ShowErrorComponent e) => ParseErrorBundle s e -> String errorBundlePretty parseInTypes :: forall m e. MonadParsec e String m => m [(AsmVarName, AsmVarType)] parseInTypes :: forall (m :: * -> *) e. MonadParsec e String m => m [(AsmVarName, AsmVarType)] parseInTypes = forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m () space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> forall (m :: * -> *) a. MonadPlus m => m a -> m [a] many m (AsmVarName, AsmVarType) parseType where parseType :: m (AsmVarName, AsmVarType) parseType = do forall (f :: * -> *) a. Functor f => f a -> f () void forall a b. (a -> b) -> a -> b $ forall {a}. m a -> m a lexeme forall a b. (a -> b) -> a -> b $ forall e s (m :: * -> *). MonadParsec e s m => Tokens s -> m (Tokens s) string Tokens String "(" String name <- forall {a}. m a -> m a lexeme forall a b. (a -> b) -> a -> b $ m Char -> m String parseWFirst forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> forall e s (m :: * -> *). MonadParsec e s m => Tokens s -> m (Tokens s) string Tokens String "_" forall (f :: * -> *) a. Functor f => f a -> f () void forall a b. (a -> b) -> a -> b $ forall {a}. m a -> m a lexeme forall a b. (a -> b) -> a -> b $ forall e s (m :: * -> *). MonadParsec e s m => Tokens s -> m (Tokens s) string Tokens String ":" String ty <- forall {a}. m a -> m a lexeme forall a b. (a -> b) -> a -> b $ m Char -> m String parseWFirst forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m (Token s) upperChar forall (f :: * -> *) a. Functor f => f a -> f () void forall a b. (a -> b) -> a -> b $ forall e s (m :: * -> *). MonadParsec e s m => Maybe String -> (Token s -> Bool) -> m (Tokens s) takeWhileP forall a. Maybe a Nothing (forall a. Eq a => a -> a -> Bool /= Char ')') forall (f :: * -> *) a. Functor f => f a -> f () void forall a b. (a -> b) -> a -> b $ forall {a}. m a -> m a lexeme forall a b. (a -> b) -> a -> b $ forall e s (m :: * -> *). MonadParsec e s m => Tokens s -> m (Tokens s) string Tokens String ")" forall (f :: * -> *) a. Applicative f => a -> f a pure (String -> AsmVarName AsmVarName String name, String -> AsmVarType AsmVarType String ty) parseWFirst :: m Char -> m String parseWFirst :: m Char -> m String parseWFirst m Char p = do Char firstLetter <- m Char p String rest <- forall e s (m :: * -> *). MonadParsec e s m => Maybe String -> (Token s -> Bool) -> m (Tokens s) takeWhileP (forall a. a -> Maybe a Just String "variable") Char -> Bool isAlphaNum forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ Char firstLetter forall a. a -> [a] -> [a] : String rest lexeme :: m a -> m a lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a ML.lexeme forall a b. (a -> b) -> a -> b $ forall e s (m :: * -> *). MonadParsec e s m => m () -> m () -> m () -> m () ML.space forall e s (m :: * -> *). (MonadParsec e s m, Token s ~ Char) => m () space1 forall (f :: * -> *) a. Alternative f => f a empty forall (f :: * -> *) a. Alternative f => f a empty unreflectTy :: AsmQQType -> Q Type unreflectTy :: AsmQQType -> Q Type unreflectTy AsmQQType { [(AsmVarName, AsmVarType)] rets :: [(AsmVarName, AsmVarType)] args :: [(AsmVarName, AsmVarType)] rets :: AsmQQType -> [(AsmVarName, AsmVarType)] args :: AsmQQType -> [(AsmVarName, AsmVarType)] .. } = do Type retTy <- [(AsmVarName, AsmVarType)] -> Q Type unreflectRetTy [(AsmVarName, AsmVarType)] rets Either String [Name] maybeArgTyNames <- [(AsmVarName, AsmVarType)] -> Q (Either String [Name]) lookupTyNames [(AsmVarName, AsmVarType)] args case Either String [Name] maybeArgTyNames of Left String err -> forall a. HasCallStack => String -> a error String err Right [Name] argTyNames -> forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b foldrM forall {m :: * -> *}. Quote m => Name -> Type -> m Type argFolder Type retTy [Name] argTyNames where argFolder :: Name -> Type -> m Type argFolder Name argName Type funAcc | Name argName forall a. Eq a => a -> a -> Bool == ''Ptr = [t| Ptr () -> $(pure funAcc) |] | Bool otherwise = [t| $(pure $ ConT argName) -> $(pure funAcc) |] unreflectRetTy :: [(AsmVarName, AsmVarType)] -> Q Type unreflectRetTy :: [(AsmVarName, AsmVarType)] -> Q Type unreflectRetTy [] = [t| () |] unreflectRetTy [(AsmVarName, AsmVarType)] rets = do Either String [Name] maybeRetTyNames <- [(AsmVarName, AsmVarType)] -> Q (Either String [Name]) lookupTyNames [(AsmVarName, AsmVarType)] rets case Either String [Name] maybeRetTyNames of Left String err -> forall a. HasCallStack => String -> a error String err Right [Name tyName] -> if Name tyName forall a. Eq a => a -> a -> Bool == ''Ptr then [t| Ptr () |] else forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ Name -> Type ConT Name tyName Right [Name] retNames -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl Type -> Name -> Type retFolder (Int -> Type TupleT forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a. Foldable t => t a -> Int length [Name] retNames) [Name] retNames where retFolder :: Type -> Name -> Type retFolder Type tupAcc Name ret | Name ret forall a. Eq a => a -> a -> Bool == ''Ptr = Type tupAcc Type -> Type -> Type `AppT` (Name -> Type ConT Name ret Type -> Type -> Type `AppT` Int -> Type TupleT Int 0) | Bool otherwise = Type tupAcc Type -> Type -> Type `AppT` Name -> Type ConT Name ret lookupTyNames :: [(AsmVarName, AsmVarType)] -> Q (Either String [Name]) lookupTyNames :: [(AsmVarName, AsmVarType)] -> Q (Either String [Name]) lookupTyNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM forall {a}. Show a => (a, AsmVarType) -> Q (Either String Name) f where f :: (a, AsmVarType) -> Q (Either String Name) f (a name, AsmVarType ty) = forall b a. b -> Maybe a -> Either b a maybeToRight (String "Unable to lookup type " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show AsmVarType ty forall a. Semigroup a => a -> a -> a <> String " for var " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show a name) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> Q (Maybe Name) lookupTypeName (AsmVarType -> String varType AsmVarType ty)