Generating more code with Harpy After a slight detour into expression representation I'm back to generating code again. To recap, here's how I'm going to do my embedded expressions in Haskell. For now I'll stick to ugly looking boolean operators. Fixing that is a whole other story.

module Exp(Exp(..), Lit(..), Fun(..), PrimOp(..)) where

data Exp
    = Con Lit
    | Arg Int
    | App Fun [Exp]
    deriving (Eq, Ord, Show)

data Lit
    = LInt  Int
    deriving (Eq, Ord, Show)

data Fun
    = FPrimOp PrimOp
    deriving (Eq, Ord, Show)

data PrimOp
    = I_Add | I_Sub | I_Mul | I_Quot | I_Rem | I_Neg
    | I_EQ | I_NE | I_LT | I_LE | I_GT | I_GE
    | I_Cond
    deriving (Eq, Ord, Show)
-----------------------------------------------------
module MExp(M(..)) where
import Exp

newtype M a = M { unM :: Exp }
    deriving (Show)
-----------------------------------------------------
module M(M, cond,
         (.==), (./=), (.<), (.<=), (.>), (.>=),
         false, true, (.&&), (.||)
        ) where
import Exp
import MExp

instance Eq (M a)
instance Ord (M a)

instance Num (M Int) where
    x + y  =  binOp I_Add x y
    x - y  =  binOp I_Sub x y
    x * y  =  binOp I_Mul x y
    negate x =  unOp I_Neg x
    fromInteger i = M $ Con $ LInt $ fromInteger i

instance Enum (M Int)
instance Real (M Int) where

instance Integral (M Int) where
    quot x y = binOp I_Quot x y
    rem x y = binOp I_Rem x y

binOp op (M x) (M y) = M $ App (FPrimOp op) [x, y]
unOp op (M x) = M $ App (FPrimOp op) [x]

--------

infix 4 ./=, .==, .<, .<=, .>, .>=
(.==), (./=), (.<), (.<=), (.>), (.>=) :: M Int -> M Int -> M Bool
(.==) = binOp I_EQ
(./=) = binOp I_NE
(.<)  = binOp I_LT
(.<=) = binOp I_LE
(.>)  = binOp I_GT
(.>=) = binOp I_GE

cond :: M Bool -> M Int -> M Int -> M Int
cond (M c) (M t) (M e) = M $ App (FPrimOp I_Cond) [c, t, e]

condB :: M Bool -> M Bool -> M Bool -> M Bool
condB (M c) (M t) (M e) = M $ App (FPrimOp I_Cond) [c, t, e]

false, true :: M Bool
false = M $ Con $ LInt 0
true  = M $ Con $ LInt 1

infixr 3 .&&
infixr 2 .||
(.&&), (.||) :: M Bool -> M Bool -> M Bool
x .&& y = condB x y false
x .|| y = condB x true y

So the Exp type is the internal representation of expressions. It's just constants, variables, and some primitive operations. The M (for machine) type is the phantom type that the DSL user will see. The module M contains all the user visible functions. Note that it handles booleans by represented the C way, by an int that is 0 or 1. There's a conditional function, cond, and a corresponding primitive that will serve as our if. So now we need to generate code for these. This is all very similar to what I did in a previous posting, I have just refactored some of the code generation. The invariant (that I arbitrarily decided on) is that each block of code that implements a primitive operation will may clobber EAX but must leave all other registers intact. This is mostly just a chunk of rather boring code. Division is causing problems as usual, since the IA32 instructions don't allow you to specify a destination register. One point worth a look is the code generation for cond. It has to test a boolean and then select one of two code blocks, but that is just what you'd expect.

module CodeGen(cgExp, CGen, cgPrologue, cgEpilogue, compileFun) where
import Prelude hiding(and, or)
import Control.Monad.Trans
import Data.Maybe(fromJust)
import Foreign
import Harpy.CodeGenMonad
import Harpy.X86Assembler

import Exp
import MExp

type StackDepth = Int
type Env = ()
type CGen a = CodeGen Env StackDepth a

addDepth :: StackDepth -> CGen ()
addDepth i = do
    d <- getState
    setState (d+i)

cgExp :: Exp -> CGen ()
cgExp (Con l) = cgLit l
cgExp (Arg a) = cgArg a
cgExp (App (FPrimOp I_Cond) [c, t, e]) = cgCond c t e
cgExp (App f es) = do mapM_ cgExp es; cgFun f (length es)

cgFun (FPrimOp p) _ = cgPrimOp p

cgPrimOp I_Add = twoOp add
cgPrimOp I_Sub = twoOp sub
cgPrimOp I_Mul = twoOp (imul InPlace)
cgPrimOp I_Quot = twoOp (cgQuotRem eax)
cgPrimOp I_Rem = twoOp (cgQuotRem edx)
cgPrimOp I_Neg = oneOp neg
cgPrimOp I_EQ = cmpOp sete
cgPrimOp I_NE = cmpOp setnz
cgPrimOp I_LT = cmpOp setl
cgPrimOp I_LE = cmpOp setle
cgPrimOp I_GT = cmpOp setg
cgPrimOp I_GE = cmpOp setge

cgCond c t e = do
    cgExp c
    popReg eax
    test eax eax
    l1 <- newLabel
    l2 <- newLabel
    jz l1
    cgExp t
    addDepth (-1)               -- pretend last cgExp didn't push anything
    jmp l2
    l1 @@ cgExp e
    l2 @@ return ()

cmpOp op = twoOp $ \ r1 r2 -> do
    cmp r1 r2
    op (reg32ToReg8 r1)
    and r1 (1 :: Word32)

cgLit (LInt i) = do
    mov eax (fromIntegral i :: Word32)
    pushReg eax

cgArg :: Int -> CGen ()
cgArg n = do
    d <- getState
    let o = 4 * (d + n)
    mov eax (Disp (fromIntegral o), esp)
    pushReg eax

cgQuotRem res r1 r2 = do
    push edx                    -- save temp reg
    push r2                     -- push second operand (in case it's edx)
    xmov  eax r1                -- first operand must be in eax
    mov  edx eax
    sar  edx (31 :: Word8)      -- sign extend
    idiv (Disp 0, esp)          -- divide by second operand (now on stack)
    add  esp (4 :: Word32)      -- remove second operand
    xmov  r1 res                -- put result in r1
    pop  edx                    -- restore edx

-- Do a register to register move, but do generate no-ops
xmov r1 r2 = if r1 == r2 then return () else mov r1 r2

reg32ToReg8 (Reg32 r) = Reg8 r

--------

twoOp op = do
    pop ebx
    pop ecx
    op ecx ebx
    push ecx
    addDepth (-1)

oneOp op = do
    pop ebx
    op ebx
    push ebx

pushReg r = do
    push r
    addDepth 1

popReg r = do
    pop r
    addDepth (-1)

--------

compileFun :: (M Int -> M Int) -> CGen ()
compileFun f = do
    ensureBufferSize 1000
    setState startDepth
    cgPrologue
    cgExp $ unM $ f $ M $ Arg 0
    cgEpilogue

----

savedRegs = [ebx, ecx]

startDepth = length savedRegs + 1

-- Push all register we'll be using, except eax.
cgPrologue :: CGen ()
cgPrologue = do
    mapM_ push savedRegs

-- Pop return value to eax, restore regs, and return
cgEpilogue :: CGen ()
cgEpilogue = do
    popReg  eax
    mapM_ pop (reverse savedRegs)
    ret

Given all this, we can generate code for a function and call it from Haskell code. But that's rather boring since we have only primitive functions and no way to call DSL functions from within the DSL. So we have no recursion. And as we all know, recursion is where the fun starts. So we need to add expressions and code generation for calling functions. First we extend the Exp module.

data Fun
    = FPrimOp PrimOp
    | Func FuncNo

newtype FuncNo = FuncNo Int

The idea being that our DSL functions will be represented by a FuncNo which is an Int. Next, we will extend the code generation. While generating code we will keep an environment that maps function numbers to the corresponding labels to call.

type Env = [(FuncNo, Label)]
...
cgFun (Func f) n = do
    e <- getEnv
    call $ fromJust $ lookup f e
    add esp (fromIntegral (4 * n) :: Word32)
    addDepth (-n)
    pushReg eax

To call a function we look up its label and generate a call instruction to that label. Then we pop off the arguments that we pushed before the call, and finally we push EAX (where the return value is). Simple, huh? But where did the environment come from? Well, it's time to be a little inventive and introduce a monad. Functions are represented by unique integers in the expression type, so we'll need a state monad to generate them.

module Gen where
import Control.Monad.State
import Harpy.CodeGenMonad
import Exp
import MExp
import CodeGen

data GenState = GenState { funcs :: [(FuncNo, CGen ())], nextFunc :: Int }

startGenState :: GenState
startGenState = GenState { funcs = [], nextFunc = 0 }

type G a = State GenState a

fun :: MInt2MInt -> G MInt2MInt
fun f = do
    s <- get
    let n = nextFunc s
        fno = FuncNo n
    put GenState{ funcs = (fno, compileFun f) : funcs s,
                  nextFunc = n + 1 }
    return $ \ x -> M $ App (Func fno) [unM x]

runG :: G MInt2MInt -> CGen ()
runG g = do
    let (ret, s) = runState g startGenState
        funs = reverse $ funcs s
    funMap <- mapM (\ (fno, _) -> do l <- newLabel; return (fno, l)) funs
    withEnv funMap $ do
        compileFun ret
        zipWithM_ (\ (f, l) (_, g) -> l @@ g) funMap funs

This code actually has some interesting points. First, the monad, G, keeps a list of defined functions. The list has the function number and the CodeGen block that will generate code for it. Second, the fun function is the one that creates a new function number. It also calls compileFun to get a CodeGen block that will generate code for the function. Note that no code is generated at this point. The G monad is just a simple state monad, not the IO based codeGen monad. Also note how fun returns an expression that is of the same type as the argument, but it now uses an App to call the function. Finally, the runG function generates all the code. It uses runState to obtain the list of defined function and the result to return. Now code generation starts. For each function we generate a new label. Pairing up the function number and the label forms our environment, funMap. With this environment installed we start code generation for the functions, first the return value, then all the defined function; each with its label attached. Well, that's it. Let's wrap it all up.

module Compile(compileIO, disasmIO, module M, module Gen) where
import Convert
import Gen
import M

type MInt = M Int

compileIO :: G (MInt -> MInt) -> IO (Int -> Int)
compileIO f = fmap flex $ compileIOW32 f
  where flex g = fromIntegral . g . fromIntegral

compileIOW32 :: G (MInt -> MInt) -> IO (Word32 -> Word32)
compileIOW32 = conv_Word32ToWord32 [] undefined . runG

disasmIO :: G (MInt -> MInt) -> IO String
disasmIO = disasm [] undefined . runG

And, of course, a test. Here we hit a snag. We want recursion, but monadic bindings (do) are not recursive. Luckily, ghc does implement recursive do called mdo (why that name, I have no idea) for any monad that is in the class MonadFix. And the state monad is, so we are in luck.

{-# OPTIONS_GHC -fglasgow-exts #-}
module Main where
import Compile

main = do
    let g = mdo
                fib <- fun $ \ n -> cond (n .< 2) 1 (fib(n-1) + fib(n-2))
                return $ fib
    test <- compileIO g
    print (test 40)

It even runs and produces the right answer, 165580141. Running time for this example is about 4.0s on my machine. Running fib compiled with 'ghc -O' takes about 3.4s, so we're in the same ballpark. Oh, and if anyone wonders what the code looks like for this example, here it is. This is really, really bad code.

003d6cd0  53                            push   ebx
003d6cd1  51                            push   ecx
003d6cd2  8b 44 24 0c                   mov    eax,dword ptr [esp+12]
003d6cd6  50                            push   eax
003d6cd7  e8 08 00 00 00                call   [3d6ce4H]
003d6cdc  83 c4 04                      add    esp,4H
003d6cdf  50                            push   eax
003d6ce0  58                            pop    eax
003d6ce1  59                            pop    ecx
003d6ce2  5b                            pop    ebx
003d6ce3  c3                            ret
003d6ce4  53                            push   ebx
003d6ce5  51                            push   ecx
003d6ce6  8b 44 24 0c                   mov    eax,dword ptr [esp+12]
003d6cea  50                            push   eax
003d6ceb  b8 02 00 00 00                mov    eax,2H
003d6cf0  50                            push   eax
003d6cf1  5b                            pop    ebx
003d6cf2  59                            pop    ecx
003d6cf3  3b cb                         cmp    ecx,ebx
003d6cf5  0f 9c c1                      setl   cl
003d6cf8  83 e1 01                      and    ecx,1H
003d6cfb  51                            push   ecx
003d6cfc  58                            pop    eax
003d6cfd  85 c0                         test   eax,eax
003d6cff  0f 84 0b 00 00 00             je     [3d6d10H]
003d6d05  b8 01 00 00 00                mov    eax,1H
003d6d0a  50                            push   eax
003d6d0b  e9 37 00 00 00                jmp    [3d6d47H]
003d6d10  8b 44 24 0c                   mov    eax,dword ptr [esp+12]
003d6d14  50                            push   eax
003d6d15  b8 01 00 00 00                mov    eax,1H
003d6d1a  50                            push   eax
003d6d1b  5b                            pop    ebx
003d6d1c  59                            pop    ecx
003d6d1d  2b cb                         sub    ecx,ebx
003d6d1f  51                            push   ecx
003d6d20  e8 bf ff ff ff                call   [3d6ce4H]
003d6d25  83 c4 04                      add    esp,4H
003d6d28  50                            push   eax
003d6d29  8b 44 24 10                   mov    eax,dword ptr [esp+16]
003d6d2d  50                            push   eax
003d6d2e  b8 02 00 00 00                mov    eax,2H
003d6d33  50                            push   eax
003d6d34  5b                            pop    ebx
003d6d35  59                            pop    ecx
003d6d36  2b cb                         sub    ecx,ebx
003d6d38  51                            push   ecx
003d6d39  e8 a6 ff ff ff                call   [3d6ce4H]
003d6d3e  83 c4 04                      add    esp,4H
003d6d41  50                            push   eax
003d6d42  5b                            pop    ebx
003d6d43  59                            pop    ecx
003d6d44  03 cb                         add    ecx,ebx
003d6d46  51                            push   ecx
003d6d47  58                            pop    eax
003d6d48  59                            pop    ecx
003d6d49  5b                            pop    ebx
003d6d4a  c3                            ret

Representing DSL expressions in Haskell When you want to embed a DSL in Haskell you will almost certainly be faced with having some kind of expressions in your DSL. If you are lucky you can get away with using the Haskell types as the DSL type (i.e., use the meta types as object types). E.g., if you DSL needs integer expressions you can use the Haskell type Integer. But sometimes you're not that lucky, so you need to represent the DSL expressions as a Haskell data type. What are the options for representing expressions in Haskell? A normal data type Let's start with the most obvious one, an ordinary data type with constructors for the different kinds of expressions. As an example I'll have a simple expression language that has constants (of type Int), addition, less-or-equal, and conditional.

data Exp
    = ConI Int
    | Add Exp Exp
    | LE Exp Exp
    | Cond Exp Exp Exp
    deriving (Show)

Just to exemplify, here's an evaluator for these expressions. We need a type of values that the evaluator can return as well.

data Val = ValI Int | ValB Bool
    deriving (Show)

eval :: Exp -> Val
eval (ConI i) = ValI i
eval (Add x y) = case (eval x, eval y) of
                 (ValI vx, ValI vy) -> ValI (vx + vy)
                 _ -> error "Bad arguments to Add"
eval (LE x y) = case (eval x, eval y) of
                (ValI vx, ValI vy) -> ValB (vx <= vy)
                _ -> error "Bad arguments to LE"
eval (Cond x y z) = case (eval x) of
                    ValB b -> if b then eval y else eval z
                    _ -> error "Bad arguments to Cond"

And a test run:

main = print $ eval e
  where e = Cond (LE (ConI 3) (ConI 5)) (Add (ConI 1) (ConI 2)) (ConI 0)

prints ValI 3 This is OK, but look at all the error cases in the evaluator. Remember that these are expressions in a DSL, so we are going to have expression fragments in our Haskell code. If we make a mistake, like Cond (ConI 1) (ConI 1) (ConI 1) this is not going to be caught by the Haskell type checker since everything is of type Exp. Instead it is going to cause some error when the program is run. Being advocates of static type checking (why else use Haskell?), this is rather disgusting. GADTs So let's try a new and shiny feature in GHC, namely GADTs. (GADTs are new in ghc, but the idea is old; it's been well known in constructive type theory for ages, Kent Petersson and I suggested it as an addition to Haskell almost 15 years ago.) With a GADT you can specify more precise types for the constructors.

data Exp a where
    ConI :: Int -> Exp Int
    Add  :: Exp Int -> Exp Int -> Exp Int
    LE   :: Exp Int -> Exp Int -> Exp Bool
    Cond :: Exp Bool -> Exp a -> Exp a -> Exp a

These are the types we want. It's now impossible to construct ill typed value of type Exp t; it will be caught by the Haskell type checker. The evaluator looks very neat and natural with GADTs

eval :: Exp a -> a
eval (ConI i) = i
eval (Add x y) = eval x + eval y
eval (LE x y) = eval x <= eval y
eval (Cond x y z) = if eval x then eval y else eval z

GADTs is really the way to go, but it has the disadvantage of not being standard Haskell. It can also get somewhat cumbersome when we have variables; the evaluator now needs a typed environment. It's certainly doable, but starting to look less nice. Phantom types Let's explore a third way that in some sense combines the previous two. The idea is to have an untyped representation, like Exp, but to use an abstract data type on top of it that only allows constructing well typed expressions. We start with the original type, but rename it to Exp'

data Exp'
    = ConI Int
    | Add Exp' Exp'
    | LE Exp' Exp'
    | Cond Exp' Exp' Exp'
    deriving (Show)

On top of this we provide the type the user will see.

newtype Exp a = E Exp'
    deriving (Show)

conI :: Int -> Exp Int
conI = E . ConI

add :: Exp Int -> Exp Int -> Exp Int
add (E x) (E y) = E $ Add x y

le :: Exp Int -> Exp Int -> Exp Bool
le (E x) (E y) = E $ LE x y

cond :: Exp Bool -> Exp a -> Exp a -> Exp a
cond (E x) (E y) (E z) = E $ Cond x y z

The functions conI, add, le, and cond are the only ones the DSL user will see. Note that they have the same types as the constructors in the GADT. To ensure the DSL user can only use these we need to put it all in a module and export the right things.

module Exp(Exp, conI, add, le, cond) where ...

We can write an evaluator again (inside the Exp module).

eval :: Exp a -> Val
eval (E x) = eval' x

eval' :: Exp' -> Val
eval' (ConI i) = ValI i
eval' (Add x y) = case (eval' x, eval' y) of
                 (ValI vx, ValI vy) -> ValI (vx + vy)
                 _ -> error "Bad arguments to Add"
eval' (LE x y) = case (eval' x, eval' y) of
                 (ValI vx, ValI vy) -> ValB (vx <= vy)
                 _ -> error "Bad arguments to LE"
eval' (Cond x y z) = case (eval' x) of
                    ValB b -> if b then eval' y else eval' z
                    _ -> error "Bad arguments to Cond"

Not as elegant as the GADT evaluator, but at least the error cases are impossible when expressions are constructed using the exported interface. And the test would now look like

main = print $ eval e
  where e = cond (le (conI 3) (conI 5)) (add (conI 1) (conI 2)) (conI 0)

Phantom types gets its name from the fact that the type variable in the definition of the Exp type doesn't occur anywhere in the constructors; so it's a phantom. Now and then people suggest implementing a dynamically typed version of Haskell. Phantom types is one of the things that makes such an implementation difficult. There are no values that carry the type information at runtime, the types only exist at compile time.

Disassembly The Harpy package also contains a disassembler, so let's put it to work.

disasm :: e -> s -> CodeGen e s a -> IO String
disasm e s cg = do
    let cg' = do cg; getCodeBufferList
    (_, r) <- runCodeGen cg' e s
    case r of
        Left msg -> error (show msg)
        Right bs -> fmap concat $ mapM disAsm bs
  where disAsm (ptr, n) = do
            r <- disassembleBlock ptr n
            case r of
                Left msg -> error $ show msg
                Right insns -> return $ unlines $ map showIntel insns

Using the same example as in the last post we get.

main = do
    let fun x = (x+1) * x `quot` 2
    str <- disasmIO fun
    putStr str

And here is the sad truth:

003d6d20  53                            push   ebx
003d6d21  51                            push   ecx
003d6d22  52                            push   edx
003d6d23  8b 44 24 10                   mov    eax,dword ptr [esp+16]
003d6d27  50                            push   eax
003d6d28  6a 01                         push   1H
003d6d2a  5b                            pop    ebx
003d6d2b  58                            pop    eax
003d6d2c  03 c3                         add    eax,ebx
003d6d2e  50                            push   eax
003d6d2f  8b 44 24 14                   mov    eax,dword ptr [esp+20]
003d6d33  50                            push   eax
003d6d34  5b                            pop    ebx
003d6d35  58                            pop    eax
003d6d36  0f af c3                      imul   eax,ebx
003d6d39  50                            push   eax
003d6d3a  6a 02                         push   2H
003d6d3c  5b                            pop    ebx
003d6d3d  58                            pop    eax
003d6d3e  8b d0                         mov    edx,eax
003d6d40  c1 fa 1f                      sar    edx,1fH
003d6d43  f7 fb                         idiv   eax,ebx
003d6d45  50                            push   eax
003d6d46  58                            pop    eax
003d6d47  5a                            pop    edx
003d6d48  59                            pop    ecx
003d6d49  5b                            pop    ebx
003d6d4a  c3                            ret

A simple compiler In my last post I played a little with Harpy to generate code from what looked like assembly language. So the next logical step is to make a compiler. And I mean a real machine-code compiler, not some wimpy byte-code nonsense. To make life simple (it is a simple compiler, after all) I'm going to start by generating code that uses the stack all the time. So all operands will live on the stack and all operations on them will push and pop the stack. Of course, the code generated from such a compiler will make any serious compiler writer weep. The CodeGen type in Harpy is the monad used during code generation. It allows you to keep some extra information around besides the generated code; it gives you access to a state monad. I will use the state to keep track of the current stack depth. (We will see why soon.)

type StackDepth = Int
type Gen = CodeGen () StackDepth ()

addDepth :: StackDepth -> Gen
addDepth i = do
    d <- getState
    setState (d+i)

The addDepth function changes the current stack depth by grabbing the old one, adding the argument and storing it back. The getState and setState functions don't generate any code, they just manipulate the state available in the CodeGen monad. With that out of the way, let's implement code generation for addition.

gadd :: Gen
gadd = do
    pop  ebx
    pop  eax
    add  eax ebx
    push eax
    addDepth (-1)

It pops the two operands off the stack, adds them, and pushes the result. The net effect on the stack is that it has one word less on it (I count my stack depth in words), so there's also a call to addDepth. Subtraction and multiplication are very similar.

gsub :: Gen
gsub = do
    pop  ebx
    pop  eax
    sub  eax ebx
    push eax
    addDepth (-1)

gmul :: Gen
gmul = do
    pop  ebx
    pop  eax
    imul InPlace eax ebx
    push eax
    addDepth (-1)

On the i386 (signed) division and remainder is computed with the idiv instruction. It divides the EDX:EAX 64 bit number with the given operand. So we must convert a 32 signed number to a 64 bit signed number, this is simply done by moving EAX to EDX and then shifting right 31 steps. This will copy the sign bit into every bit of EDX. Depending of if we want the quotient or remainder we need to push EAX or EDX.

gquot :: Gen
gquot = do
    gquotRem
    push eax
    addDepth (-1)

grem :: Gen
grem = do
    gquotRem
    push edx
    addDepth (-1)

gquotRem :: Gen
gquotRem = do
    pop  ebx
    pop  eax
    mov  edx eax
    sar  edx (31 :: Word8)
    idiv ebx

To put a constant on the stack we simply push it and increment the remembered stack depth.

gconst :: Int -> Gen
gconst c = do
    push (fromIntegral c :: Word32)
    addDepth 1

OK, so now for something more interesting. Assuming we are generating code for a function, we also want to access the arguments to the function. Where are the arguments? Well, according to the IA32 calling conventions the caller pushes the arguments on the stack, so we'll follow those. First we have a bunch things on the stack, how many is kept track of in the stack depth in the CodeGen monad, and then the arguments follow in order, pushed right-to-left. So to get an argument we compute the offset, convert it to a byte offset, and push that word on the stack.

-- Get the Nth argument
gargN :: Int -> Gen
gargN n = do
    d <- getState
    let o = 4 * (d + n)
    mov  eax (Disp (fromIntegral o), esp)
    push eax
    addDepth 1

When generating code for a function we should not clobber any callee-save registers, so to be on the safe side we save all used registers on function entry and restore them on function exit. On function exit we also return the result in EAX.

savedRegs = [ebx, edx]

-- Push all register we'll be using, except eax.
gprologue :: Gen
gprologue = do
    mapM_ push savedRegs

-- Pop return value to eax, restore regs, and return
gepilogue :: Gen
gepilogue = do
    pop  eax
    mapM_ pop (reverse savedRegs)
    ret

OK, so that was a lot of stuff, let's put it together for a test.

testGen = conv_Word32ToWord32 () (length savedRegs + 1) $ do
    gprologue
    gargN 0
    gconst 1
    gadd
    gepilogue

main = do
    test <- testGen
    print (test 10)

The testGen function generates the prologue, push argument, push 1, add, and the epilogue. The conv_Word32ToWord32 (from my previous post) converts the machine code to a Haskell function. We also have to give the start value of the stack depth. The stack initially contains the return address and the saved registers, so that's the number we pass. Running this gives 11, as it should. OK, so let's actually write a compiler and not just a code generator. Here is a data type for integer expressions.

data Exp
    = Con Int
    | Arg Int
    | BinOp BOp Exp Exp
    deriving (Show)

data BOp = Add | Sub | Mul | Quot | Rem
    deriving (Show)

We have constants, arguments (variables), and a few binary operators. It's all easily translated to machine code.

translate :: Exp -> Gen
translate (Con c) = gconst c
translate (Arg n) = gargN n
translate (BinOp op x y) = do translate x; translate y; binop op
  where binop Add = gadd
        binop Sub = gsub
        binop Mul = gmul
        binop Quot = gquot
        binop Rem = grem

For simplicity, let's compile only functions of one argument for now.

compileIOW32 :: (Exp -> Exp) -> IO (Word32 -> Word32)
compileIOW32 f = conv_Word32ToWord32 () (length savedRegs + 1) $ do
    gprologue
    translate (f (Arg 0))
    gepilogue 

This function takes an Exp->Exp function, by giving this function the argument Arg 0 we get an expression to translate. We tack on the usual prologue and epilogue. So let's try it.

main = do
    let fun x = BinOp Add x (Con 1)
    test <- compileIOW32 fun
    print (test 10)

Which prints 11. But yuck, writing BinOp etc. isn't nice. Let's make some instances.

instance Eq Exp
instance Ord Exp

instance Num Exp where
    x + y  =  BinOp Add x y
    x - y  =  BinOp Sub x y
    x * y  =  BinOp Mul x y
    fromInteger i = Con (fromInteger i)

instance Enum Exp
instance Real Exp

instance Integral Exp where
    quot x y = BinOp Quot x y
    rem x y = BinOp Rem x y

And give it a whirl:

main = do
    let fun x = (x+1) * x `quot` 2
    test <- compileIOW32 fun
    print (test 10)

And this prints 55, as expected. Not bad, a compiler from (a tiny subset of) Haskell functions to machine code in a few pages. But I do admit being embarrassed about generating such incredibly poor code. But there's always future blog posts to rectify that.

Playing with Harpy Recently there was an announcement of the Harpy package for Haskell. Harpy is a very cool package that lets you generate machine code from a Haskell program into a memory buffer. Using the Haskell FFI interface you can then turn the machine code into a Haskell function and call it. The way that you generate machine code from Harpy looks very much like assembly code. Oh, btw, apologies to those who are not using x86 machines, this blog post is very machine dependent, since Harpy generate x86 machine code. A small Harpy example First, some sample code (stolen from the Harpy tutorial). It might look like assembly code, but it's actually Haskell.

asm_fac = do
    loopTest  <- newLabel
    loopStart <- newLabel
    ensureBufferSize 160
    push ecx
    mov  ecx (Disp 8, esp)
    mov  eax (1 :: Word32)
    jmp  loopTest
    loopStart @@ mul ecx
    sub  ecx (1 :: Word32)
    loopTest @@ cmp ecx (0 :: Word32)
    jne  loopStart
    pop  ecx
    ret

Just some comments: This is (obviously) monadic code. The newLabel operation creates a new label that later has to be defined and that can be used as a jump target. The ensureBufferSize is a tedious function to make sure there is enough space to emit the instructions. I hope the next version of Harpy will not require this, since it's really the computers job to count bytes, not mine (and it's not hard to do). Apart from that, most of the code should be obvious for anyone who has done assembly programming on an x86. To generate code and then convert the generated code we need some utility functions.

type Importer f = FunPtr f -> f
foreign import ccall safe "dynamic" import_Word32ToWord32 :: Importer (Word32 -> Word32)

conv_Word32ToWord32 :: e -> s -> CodeGen e s a -> IO (Word32 -> Word32)
conv_Word32ToWord32 = conv import_Word32ToWord32

conv :: (Importer f) -> e -> s -> CodeGen e s a -> IO f
conv imp e s cg = do
    let cg' = do cg; getEntryPoint
    (_, r) <- runCodeGen cg' e s
    case r of
        Left msg -> error (show msg)
        Right addr -> return $ imp $ castPtrToFunPtr addr

The important function is conv_Word32ToWord32 which takes a block like asm_fac and turns it into a Haskell function. The e and s arguments we can ignore for now, they are for more advanced uses of the machine code generator. Note that there is no type safety here. The asm_fac block has nothing that says what kind of function it might implement, so it's all up to us to use it correctly. (Once you use FFI Haskell isn't any safer than C.) Finally, to use it all:

main = do
    fac <- conv_Word32ToWord32 () () asm_fac
    print (fac 5, fac 10)

Pretty nifty, huh? Calling conv_Word32ToWord32 with the asm_fac argument will emit machine code for the factorial function into a memory buffer and then wrap it up so it can be called as a regular Haskell function. Running the program will print (120,3628800) as expected. Final thoughts Harpy is really cool and uses Haskell type classes in a clever way to make Harpy "assembly" code look almost like normal assembly code. But there is room for improvement. Currently you have no control over the buffer handling; Harpy uses mallocBytes internally. I would like to see the buffer handling (mallocBytes, peek, the IO monad) abstracted out. That way I don't have to generate code into a memory buffer if I don't want to. I could generate code in, e.g., a list. Or I could not generate code at all, but just count bytes. Or I could allocate buffers with something better than mallocBytes. On the whole, I think Harpy is great for experimenting with code generation. More about that soon.