## Friday, June 29, 2007

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 Data.Maybe(fromJust)
import Foreign
import Harpy.X86Assembler

import Exp
import MExp

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

addDepth :: StackDepth -> CGen ()
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_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

oneOp op = do
pop ebx
op ebx
push ebx

pushReg r = do
push r

popReg r = do
pop r

--------

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)
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 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
003d6d46  51                            push   ecx
003d6d47  58                            pop    eax
003d6d48  59                            pop    ecx
003d6d49  5b                            pop    ebx
003d6d4a  c3                            ret
```

Labels: ,

## Thursday, June 28, 2007

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
| 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)
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)
```
```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
| 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

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)
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.

Labels: ,

## Tuesday, June 26, 2007

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
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
```

Labels: ,

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 ()

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
pop  ebx
pop  eax
push eax
```
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

gmul :: Gen
gmul = do
pop  ebx
pop  eax
imul InPlace eax ebx
push eax
```
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

grem :: Gen
grem = do
gquotRem
push edx

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)
```
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
```
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
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
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.

Labels: , ,

## Monday, June 25, 2007

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)
```main = do