Simple monadic x86 generation using Haskell

Emitter.hs

import Data.Word
import Data.List
import Control.Monad.State.Strict
import Control.DeepSeq

data EmitterState = EmitterState {
  emNextLabel :: Int
} deriving (Read, Show, Eq, Ord)

instance NFData EmitterState where
    rnf = rnf . emNextLabel

type EmitterT = StateT EmitterState

type Emitter = EmitterT IO

emitOp :: String -> Emitter ()
emitOp op = lift . putStrLn $ "\t" ++ op

wrapEmit :: Emitter () -> Emitter ()
wrapEmit action = emitHeader >> action >> emitFooter

word :: Word64 -> Emitter ()
word w = emitOp $ "pushq $" ++ (show w)

pop :: String -> Emitter ()
pop reg = emitOp $ "popq " ++ reg

push :: String -> Emitter ()
push reg = emitOp $ "pushq " ++ reg

arith :: String -> Emitter ()
arith op = do
    pop "%rbx"
    pop "%rax"
    emitOp $ op ++ " %rbx, %rax"
    push "%rax"

emitHeader :: Emitter ()
emitHeader = lift . mapM_ putStrLn $ 
  ["\t.text",
   "\t.globl entry",
   "entry:",
   "\tpushq %rbp",
   "\tmovq %rsp, %rbp"]

emitFooter :: Emitter ()
emitFooter = pop "%rax" >> (lift $ mapM_ putStrLn ["\tpopq %rbp", "\tret"])

newLabel :: Monad m => EmitterT m String
newLabel = do
    st <- get
    let labelNumber = emNextLabel st
    let label = "L" ++ show labelNumber
    put $!! st { emNextLabel = succ labelNumber }
    return label

label :: String -> Emitter ()
label l = lift . putStrLn $ l ++ ":"

branch :: Emitter () -> Emitter () -> Emitter ()
branch trueBranch falseBranch = do
    l0 <- newLabel
    l1 <- newLabel
    pop "%rax"
    emitOp $ "cmpq $0, %rax"
    emitOp $ "je " ++ l0
    trueBranch
    emitOp $ "jmp " ++ l1
    label l0
    falseBranch
    label l1

while :: Emitter () -> Emitter ()
while body = do
    entry <- newLabel
    exit  <- newLabel

    label entry
    pop "%rax"
    emitOp $ "cmpq $0, %rax"
    emitOp $ "je " ++ exit
    body
    emitOp $ "jmp " ++ entry
    label exit

dup :: Emitter ()
dup = do
    pop "%rax"
    push "%rax"
    push "%rax"

call :: String -> Emitter ()
call lbl = emitOp $ "call " ++ lbl

printd :: Emitter ()
printd = do
    pop "%rdi"
    call "printd"

output :: Emitter ()
output = do
    word $ 1
    dup
    while $ do
      word 1
      arith "addq"
      dup
      dup
      printd

initialState :: EmitterState
initialState = EmitterState {
    emNextLabel = 0
}

main :: IO ()
main = flip evalStateT initialState $ wrapEmit output