MASMGen (empty) → 0.1.0.0
raw patch · 6 files changed
+426/−0 lines, 6 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl
Files
- LICENSE +13/−0
- MASMGen.cabal +38/−0
- Setup.hs +2/−0
- src/Language/MASMGen/Core.hs +211/−0
- src/Language/MASMGen/Types.hs +125/−0
- test/Main.hs +37/−0
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2016 Ruey-Lin Hsu (petercommand)++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU Lesser General Public License as published by+ the Free Software Foundation, version 3 of the License.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU Lesser General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.
+ MASMGen.cabal view
@@ -0,0 +1,38 @@+name: MASMGen+version: 0.1.0.0+synopsis: Generate MASM code from haskell+description: Please see README.md+license: LGPL-3+license-file: LICENSE+author: Ruey-Lin Hsu (petercommand)+maintainer: petercommand@gmail.com+copyright: 2016 petercommand+category: Development+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ exposed-modules: Language.MASMGen.Core+ , Language.MASMGen.Types+ hs-source-dirs: src+ build-depends: base >=4.7 && <4.9+ , containers >=0.5+ , mtl >=2.2+ default-language: Haskell2010++Test-suite Main+ hs-source-dirs: src+ , test+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2+ build-depends: base >=4.7 && <4.9+ , containers >=0.5+ , mtl >=2.2+ type: exitcode-stdio-1.0+ default-language: Haskell2010+++source-repository head+ type: git+ location: git@github.com:petercommand/MASMGen.git
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Language/MASMGen/Core.hs view
@@ -0,0 +1,211 @@+module Language.MASMGen.Core where+import Language.MASMGen.Types+import qualified Data.Map as M+import Control.Monad.State.Lazy+import Control.Monad.Writer.Lazy++import Data.List+import Data.Word++mkFunc :: String -> MASMFuncM () -> MASMProgM ()+mkFunc name thisFunc = do+ f <- gets funcs+ modify $ \s -> s { funcs = Func (execState thisFunc (initFuncState name)) : f }++++initFuncState :: String -> MASMFunc+initFuncState s = MASMFunc { funcName = s+ , instrs = []+ }+initProgState :: MASMProg+initProgState = MASMProg { globalVarMap = M.empty+ , funcs = []+ }++ ++section :: String -> Writer [MASMOutput] ()+section x = stell $ MASMOutput $ '.' : x ++output :: [MASMOutput] -> [String]+output x = let output' :: Int -> [MASMOutput] -> [String]+ output' indent (y:ys) = case y of+ MASMOutput str -> (replicate indent ' ') <> str : output' indent ys+ MASMOutputNoIndent str -> str : output' indent ys+ Indent -> output' (indent + 4) ys+ Dedent -> case indent - 4 >= 0 of+ True -> output' (indent - 4) ys+ False -> output' 0 ys+ NewLine -> "" : output' indent ys+ output' _ [] = []+ in output' 0 x+produceAsm :: MASM -> Writer [MASMOutput] ()+produceAsm (MASM { masmProgMode = progMode+ , masmProgOptions = progOptions+ , masmInclude = include+ , masmProg = prog+ }) = do+ stell $ MASMOutput $ case progMode of+ Mode386 -> ".386"+ Mode486 -> ".486"+ Mode586 -> ".586"+ Mode686 -> ".686"+ produceAsmOptions progOptions+ produceAsmInclude include+ produceAsmProg prog++produceAsmOptions :: [String] -> Writer [MASMOutput] ()+produceAsmOptions = tell . map (MASMOutput . ("option " <>))++produceAsmInclude :: [MASMInclude] -> Writer [MASMOutput] ()+produceAsmInclude = tell . map (\item -> MASMOutput (case item of+ MASMInclude a -> "include " <> a+ MASMIncludeLib a -> "includelib " <> a))+ +produceAsmProg :: MASMProgM () -> Writer [MASMOutput] ()+produceAsmProg prog = let finalProg = execState prog initProgState+ in do+ section "DATA"+ produceAsmGlobalVarMap $ globalVarMap finalProg+ section "CODE"+ produceAsmFuncs $ reverse $ funcs finalProg++produceAsmGlobalVarMap :: MASMVarMap -> Writer [MASMOutput] ()+produceAsmGlobalVarMap varMap = let assocsList = M.assocs varMap+ printVar :: (String, (MASMType, [Word8])) -> Writer [MASMOutput] ()+ printVar (name, (varType, val)) = stell $ MASMOutput $ name <> " " <> show varType <> " " <> intersperse ',' (concat . map show $ val)+ in do+ sequence_ $ map printVar assocsList+produceAsmFuncs :: [MASMTopLevel] -> Writer [MASMOutput] ()+produceAsmFuncs (x:xs) = do+ case x of+ Func func -> let name = funcName func+ ins = reverse $ instrs func+ in do+ stell $ MASMOutput $ name <> " PROC"+ stell $ Indent+ sequence_ $ map printShowableInstr ins+ stell $ Dedent+ stell $ MASMOutput $ name <> " ENDP"+ stell $ NewLine+ produceAsmFuncs xs+produceAsmFuncs [] = return ()+++printShowableInstr :: MASMInstr -> Writer [MASMOutput] ()+printShowableInstr instr = let binOp m x y = stell $ MASMOutput $ m <> " " <> show x <> ", " <> show y+ sizedBinOp m size x y = case size of+ Just size -> stell $ MASMOutput $ m <> " " <> show size <> " " <> show x <> ", " <> show y+ Nothing -> binOp m x y+ + sinOp m x = stell $ MASMOutput $ m <> " " <> show x+ sizedSinOp m size x = case size of+ Just size -> stell $ MASMOutput $ m <> " " <> show size <> " " <> show x+ Nothing -> sinOp m x+ + in case instr of+ MASMAdd size x y -> sizedBinOp "ADD" size x y+ MASMSub size x y -> sizedBinOp "SUB" size x y+ MASMMul size x y -> sizedBinOp "IMUL" size x y+ MASMDiv size x y -> sizedBinOp "IDIV" size x y+ MASMInc size x -> sizedSinOp "INC" size x+ MASMDec size x -> sizedSinOp "DEC" size x+ MASMMov size x y -> sizedBinOp "MOV" size x y+ MASMFuncCall name convention _ -> error "func call not implemented"+ MASMGoto x -> sinOp "GOTO" x+ MASMLabel x -> stell $ MASMOutputNoIndent $ x <> ":"+ MASMPush size x -> sizedSinOp "PUSH" size x+ MASMPop size x -> sizedSinOp "POP" size x+ MASMComment x -> stell $ MASMOutput $ ';' : x++modFun :: MASMInstr -> MASMFuncM ()+modFun x = modify (\f -> let i = instrs f+ in f { instrs = x : i })++add :: Operand -> Operand -> MASMFuncM ()+add x y = modFun $ MASMAdd Nothing x y++addb :: Operand -> Operand -> MASMFuncM ()+addb x y = modFun $ MASMAdd (Just DB) x y++addw :: Operand -> Operand -> MASMFuncM ()+addw x y = modFun $ MASMAdd (Just DW) x y++addl :: Operand -> Operand -> MASMFuncM ()+addl x y = modFun $ MASMAdd (Just DD) x y+ +sub :: Operand -> Operand -> MASMFuncM ()+sub x y = modFun $ MASMSub Nothing x y++subb :: Operand -> Operand -> MASMFuncM ()+subb x y = modFun $ MASMSub (Just DB) x y++subw :: Operand -> Operand -> MASMFuncM ()+subw x y = modFun $ MASMSub (Just DW) x y++subl :: Operand -> Operand -> MASMFuncM ()+subl x y = modFun $ MASMSub (Just DD) x y++ +imul :: Operand -> Operand -> MASMFuncM ()+imul x y = modFun $ MASMMul Nothing x y+ +idiv :: Operand -> Operand -> MASMFuncM ()+idiv x y = modFun $ MASMDiv Nothing x y+ +inc :: Operand -> MASMFuncM ()+inc x = modFun $ MASMInc Nothing x++dec :: Operand -> MASMFuncM ()+dec x = modFun $ MASMDec Nothing x++mov :: Operand -> Operand -> MASMFuncM ()+mov x y = modFun $ MASMMov Nothing x y++-- Do not pass the arg 'ty' pointer types, it is designed to use with DB / DW / DD+typedSinOp :: TypedMASMInstrSinCon -> MASMType -> Operand -> MASMFuncM ()+typedSinOp instr ty x = case operandClass x of+ Pointer -> modFun $ instr (Just (Ptr ty)) x+ _ -> modFun $ instr (Just ty) x++typedBinOp :: TypedMASMInstrBinCon -> MASMType -> Operand -> Operand -> MASMFuncM ()+typedBinOp instr ty x y = case operandClass x of+ Pointer -> modFun $ instr (Just (Ptr ty)) x y+ _ -> modFun $ instr (Just ty) x y+ +movb :: Operand -> Operand -> MASMFuncM ()+movb = typedBinOp MASMMov DB++movw :: Operand -> Operand -> MASMFuncM ()+movw = typedBinOp MASMMov DW++movl :: Operand -> Operand -> MASMFuncM ()+movl = typedBinOp MASMMov DD++goto :: String -> MASMFuncM ()+goto x = modFun $ MASMGoto x++push :: Operand -> MASMFuncM ()+push x = modFun $ MASMPush Nothing x++pushl :: Operand -> MASMFuncM ()+pushl x = typedSinOp MASMPush DD x+ +pop :: Operand -> MASMFuncM ()+pop x = modFun $ MASMPop Nothing x++popl :: Operand -> MASMFuncM ()+popl x = typedSinOp MASMPop DD x++ +label :: String -> MASMFuncM ()+label x = modFun $ MASMLabel x++comment :: String -> MASMFuncM ()+comment x = modFun $ MASMComment x+ +stell :: (Monad m, Monoid (m a)) => a -> Writer (m a) ()+stell = tell . return++
+ src/Language/MASMGen/Types.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE GADTs, ExistentialQuantification, FlexibleContexts, StandaloneDeriving #-}+module Language.MASMGen.Types where+import qualified Data.Map as M+import Data.Word+import Control.Monad.State.Lazy+class Def a where+ def :: a+data MASM = MASM { masmProgMode :: MASMMode+ , masmProgOptions :: [String]+ , masmInclude :: [MASMInclude]+ , masmProg :: MASMProgM ()+ }+instance Def MASM where+ def = MASM { masmProgMode = Mode386+ , masmProgOptions = []+ , masmInclude = []+ , masmProg = return ()+ }++data Lit = IntLit Word8 | Lits [Lit]+type Addr = Word16+type Scale = Int+type Displacement = Int++ +data Operand where+ Imm :: Word16 -> Operand -- to be fixed+ Direct :: Addr -> Operand+ Reg :: forall a. Reg a => a -> Operand+ RegIndirect :: forall a. Reg a => a -> Operand+ RegIndex :: forall a. Reg a => a -> Displacement -> Operand+ RegIndexScale :: forall a. Reg a => a -> a -> Scale -> Displacement -> Operand+ VarAddr :: String -> Operand++data OpClass = Pointer | Register RegClass | Immediate+ +class OperandClass a where+ operandClass :: a -> OpClass++instance OperandClass Operand where+ operandClass (Imm _) = Immediate+ operandClass (Direct _) = Pointer+ operandClass (Reg x) = Register (regClass x)+ operandClass (RegIndirect _) = Pointer+ operandClass (RegIndex _ _) = Pointer+ operandClass (RegIndexScale _ _ _ _) = Pointer+ operandClass (VarAddr _) = Pointer++instance Show Operand where+ show (Imm x) = show x ++ "D"+ show (Direct addr) = show addr ++ "D" -- Decimal+ show (Reg reg) = show reg+ show (RegIndirect reg) = "[" ++ show reg ++ "]"+ show (RegIndex reg disp) = "[" ++ show reg ++ " + " ++ show disp ++ "]"+ show (RegIndexScale baseReg indexReg scale disp) = "[" ++ show baseReg+ ++ " + " ++ show indexReg+ ++ "*" ++ show scale+ ++ " + " ++ show disp+ ++ "]"+ show (VarAddr x) = "[" ++ show x ++ "]"+data MASMMode = Mode386 | Mode486 | Mode586 | Mode686+data Reg32 = EAX | EBX | ECX | EDX | ESI | EDI | ESP | EBP deriving Show+data Reg16 = AX | BX | CX | DX | SI | DI | SP | BP deriving Show+data Reg8 = AH | AL | BH | BL | CH | CL | DH | DL | SPL | BPL | SIL | DIL deriving Show+data RegXMM = XMM0 | XMM1 | XMM2 | XMM3 | XMM4 | XMM5 | XMM6 | XMM7 | XMM8 | XMM9 | XMM10 | XMM11 | XMM12 | XMM13 | XMM14 | XMM15 deriving Show+data RegClass = Reg32 | Reg16 | Reg8 | RegXMM+class Show a => Reg a where+ showReg :: a -> String+ showReg = show+ regClass :: a -> RegClass+instance Reg Reg32 where+ regClass = const Reg32+instance Reg Reg16 where+ regClass = const Reg16+instance Reg Reg8 where+ regClass = const Reg8+instance Reg RegXMM where+ regClass = const RegXMM+data MASMInclude = MASMInclude String | MASMIncludeLib String+data MASMType where+ DB :: MASMType+ DW :: MASMType+ DD :: MASMType+ Ptr :: MASMType -> MASMType+instance Show MASMType where+ show DB = "BYTE"+ show DW = "WORD"+ show DD = "DWORD"+ show (Ptr x) = show x ++ " PTR"+ +type MASMVar = (MASMType, [Word8])+type MASMVarMap = M.Map String MASMVar+data CallingConvention = Default | Cdecl | FastCall | StdCall+data MASMInstr = MASMAdd (Maybe MASMType) Operand Operand+ | MASMSub (Maybe MASMType) Operand Operand+ | MASMMul (Maybe MASMType) Operand Operand+ | MASMDiv (Maybe MASMType) Operand Operand+ | MASMMov (Maybe MASMType) Operand Operand+ | MASMInc (Maybe MASMType) Operand+ | MASMDec (Maybe MASMType) Operand+ | MASMPush (Maybe MASMType) Operand+ | MASMPop (Maybe MASMType) Operand+ | MASMFuncCall String CallingConvention [FuncArg]+ | MASMGoto String+ | MASMLabel String+ | MASMComment String+type FuncArg = Operand+data MASMFunc = MASMFunc { funcName :: String+ , instrs :: [MASMInstr]+ }+type MASMFuncM a = State MASMFunc a+type MASMProgM a = State MASMProg a++data MASMTopLevel = Func MASMFunc+data MASMProg = MASMProg { globalVarMap :: MASMVarMap+ , funcs :: [MASMTopLevel]+ }++data MASMOutput = MASMOutput String | MASMOutputNoIndent String | Indent | Dedent | NewLine++type UntypedMASMInstrSinCon = (Operand -> MASMInstr)+type UntypedMASMInstrBinCon = (Operand -> Operand -> MASMInstr)+type TypedMASMInstrSinCon = (Maybe MASMType) -> Operand -> MASMInstr+type TypedMASMInstrBinCon = (Maybe MASMType) -> Operand -> Operand -> MASMInstr+
+ test/Main.hs view
@@ -0,0 +1,37 @@+module Main where++import Language.MASMGen.Core+import Language.MASMGen.Types+import Control.Monad.Writer.Lazy+ +main :: IO ()+main =+ let+ masm = def { masmProgMode = Mode386+ , masmProgOptions = ["casemap :none"]+ , masmInclude = [ MASMInclude "\\masm32\\include\\windows.inc"+ , MASMInclude "\\masm32\\include\\kernel32.inc"+ , MASMInclude "\\masm32\\include\\masm32.inc"+ , MASMIncludeLib "\\masm32\\lib\\kernel32.lib"+ , MASMIncludeLib "\\masm32\\lib\\masm32.lib"+ ]+ , masmProg = prog+ }+ prog = do+ mkFunc "start" $ do+ mov (Reg AX) (Imm 0)+ movl (RegIndirect EAX) (Reg EBX)+ addw (Reg AX) (Imm 10)+ sub (Reg AX) (Imm 100)+ mkFunc "testFunc1" $ do+ let loop n = if n > 0+ then do+ mov (Reg EAX) (Imm $ n * n)+ loop (n - 1)+ else+ return ()+ loop 20+ comment "this is a comment"+ label "testLabel"+ in+ (mapM_ putStrLn) . output . snd . runWriter . produceAsm $ masm