diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2014, John Wiegley
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of John Wiegley nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/LinearScan/Hoopl.hs b/LinearScan/Hoopl.hs
new file mode 100644
--- /dev/null
+++ b/LinearScan/Hoopl.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module LinearScan.Hoopl where
+
+import           Compiler.Hoopl as Hoopl hiding ((<*>))
+import           Control.Applicative
+import           Control.Monad.Trans.State (State, get, put)
+import qualified Data.Map as M
+import           Data.Monoid
+import           LinearScan
+
+class HooplNode n1
+      => NodeAlloc s n1 n2 | n1 -> n2, n2 -> n1, n1 -> s, n2 -> s where
+    isCall   :: n1 O O -> Bool
+    isBranch :: n1 O C -> Bool
+
+    getReferences :: n1 e x -> [VarInfo]
+    setRegisters  :: [(Int, PhysReg)] -> n1 e x -> n2 e x
+
+    mkMoveOps    :: PhysReg     -> PhysReg     -> State s [n2 O O]
+    mkSwapOps    :: PhysReg     -> PhysReg     -> State s [n2 O O]
+    mkSaveOps    :: PhysReg     -> Maybe VarId -> State s [n2 O O]
+    mkRestoreOps :: Maybe VarId -> PhysReg     -> State s [n2 O O]
+
+data NodeV n = NodeCO { getNodeCO :: n C O }
+             | NodeOO { getNodeOO :: n O O }
+             | NodeOC { getNodeOC :: n O C }
+
+blockInfo :: NonLocal n1
+          => (Label -> Int)
+          -> BlockInfo (Block n1 C C) (Block n2 C C) (NodeV n1) (NodeV n2)
+blockInfo getBlockId = BlockInfo
+    { blockId = getBlockId . entryLabel
+
+    , blockSuccessors = Prelude.map getBlockId . successors
+
+    , blockOps = \(BlockCC a b z) ->
+        ([NodeCO a], Prelude.map NodeOO (blockToList b), [NodeOC z])
+
+    , setBlockOps = \_ [a] b [z] ->
+        BlockCC
+            (getNodeCO a)
+            (blockFromList (Prelude.map getNodeOO b))
+            (getNodeOC z)
+    }
+
+opInfo :: forall s n1 n2. NodeAlloc s n1 n2 => OpInfo s (NodeV n1) (NodeV n2)
+opInfo = OpInfo
+    { opKind = \node -> case node of
+           NodeOO n | isCall n  -> IsCall
+                    | otherwise -> IsNormal
+           NodeOC n | isBranch n -> IsBranch
+                    | otherwise  -> IsNormal
+           _ -> IsNormal
+
+    , opRefs = \node -> case node of
+           NodeCO n -> getReferences n
+           NodeOO n -> getReferences n
+           NodeOC n -> getReferences n
+
+    , moveOp    = \x y -> fmap NodeOO <$> mkMoveOps x y
+    , swapOp    = \x y -> fmap NodeOO <$> mkSwapOps x y
+    , saveOp    = \x y -> fmap NodeOO <$> mkSaveOps x y
+    , restoreOp = \x y -> fmap NodeOO <$> mkRestoreOps x y
+
+    , applyAllocs = \node m -> case node of
+           NodeCO n -> [NodeCO (setRegisters m n)]
+           NodeOO n -> [NodeOO (setRegisters m n)]
+           NodeOC n -> [NodeOC (setRegisters m n)]
+    }
+
+data SpillStack = SpillStack
+    { stackPtr      :: Int
+    , stackSlotSize :: Int
+    , stackSlots    :: M.Map (Maybe Int) Int
+    }
+    deriving (Eq, Show)
+
+newSpillStack :: Int -> Int -> SpillStack
+newSpillStack offset slotSize = SpillStack
+    { stackPtr      = offset
+    , stackSlotSize = slotSize
+    , stackSlots    = mempty
+    }
+
+getStackSlot :: Maybe VarId -> State SpillStack Int
+getStackSlot vid = do
+    stack <- get
+    case M.lookup vid (stackSlots stack) of
+        Just off -> return off
+        Nothing -> do
+            let off = stackPtr stack
+            put stack
+                 { stackPtr   = off + stackSlotSize stack
+                 , stackSlots =
+                     M.insert vid off (stackSlots stack)
+                 }
+            return off
diff --git a/LinearScan/Hoopl/DSL.hs b/LinearScan/Hoopl/DSL.hs
new file mode 100644
--- /dev/null
+++ b/LinearScan/Hoopl/DSL.hs
@@ -0,0 +1,84 @@
+module LinearScan.Hoopl.DSL where
+
+import           Compiler.Hoopl as Hoopl hiding ((<*>))
+import           Control.Applicative
+import           Control.Monad.Free
+import           Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.Free as TF
+import           Control.Monad.Trans.Free hiding (FreeF(..), Free)
+import           Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import qualified Data.Map as M
+import           Data.Monoid
+
+type Labels = M.Map String Label
+
+-- | The 'Asm' monad lets us create labels by name and refer to them later.
+type Asm = StateT Labels SimpleUniqueMonad
+
+getLabel :: String -> Asm Label
+getLabel str = do
+    l <- gets (M.lookup str)
+    case l of
+        Just lbl -> return lbl
+        Nothing -> do
+            lbl <- lift freshLabel
+            modify (M.insert str lbl)
+            return lbl
+
+-- | A series of 'Nodes' is a set of assembly instructions that ends with some
+--   kind of closing operation, such as a jump, branch or return.
+type Nodes n a = Free ((,) (n O O)) a
+
+-- | The 'Nodes' free monad is really just a convenient way to describe a list
+--   that must result in a closing operation at the end.
+nodesToList :: Nodes n a -> (a, [n O O])
+nodesToList (Pure a) = (a, [])
+nodesToList (Free (n, xs)) = (n :) <$> nodesToList xs
+
+type BodyNode n = Nodes n ()
+
+bodyNode :: n O O -> BodyNode n
+bodyNode n = Free (n, Pure ())
+
+type EndNode n = Nodes n (Asm (n O C))
+
+endNode :: Asm (n O C) -> EndNode n
+endNode = return
+
+-- | A program is a series of 'Nodes', each associated with a label.
+data ProgramF n = FreeBlock
+    { labelEntry :: Label
+    , labelBody  :: EndNode n
+    }
+type Program n = FreeT ((,) (ProgramF n)) Asm ()
+
+label :: String -> EndNode n -> Program n
+label str body = do
+    lbl <- lift $ getLabel str
+    liftF (FreeBlock lbl body, ())
+
+jump :: HooplNode n => String -> EndNode n
+jump dest = endNode $ mkBranchNode <$> getLabel dest
+
+-- | When we compile a program, the result is a closed Hoopl Graph and the
+--   label corresponding to the requested entry label name.
+compile :: (NonLocal n, HooplNode n)
+        => String -> Program n -> (Graph n C C, Label)
+compile name prog
+    = runSimpleUniqueMonad
+    $ flip evalStateT (mempty :: Labels)
+    $ do body  <- go prog
+         entry <- gets (M.lookup name)
+         case entry of
+             Nothing  -> error $ "Missing label: " ++ name
+             Just lbl -> return (bodyGraph body, lbl)
+  where
+    go m = do
+        p <- runFreeT m
+        case p of
+            TF.Pure () -> return emptyBody
+            TF.Free (blk, xs) -> addBlock <$> comp blk <*> go xs
+
+    comp (FreeBlock lbl body) = do
+        let (close, blocks) = nodesToList body
+        BlockCC (mkLabelNode lbl) (blockFromList blocks) <$> close
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/linearscan-hoopl.cabal b/linearscan-hoopl.cabal
new file mode 100644
--- /dev/null
+++ b/linearscan-hoopl.cabal
@@ -0,0 +1,52 @@
+name:          linearscan-hoopl
+version:       0.1.0.0
+synopsis:      Make it easy to use the linearscan register allocator with Hoopl
+homepage:      http://github.com/jwiegley/linearscan-hoopl
+license:       BSD3
+license-file:  LICENSE
+author:        John Wiegley
+maintainer:    johnw@newartisans.com
+category:      Development
+build-type:    Simple
+cabal-version: >=1.10
+
+description:
+  This module provides a convenience wrapper and a type class, 'NodeAlloc',
+  which makes it much easier to use the @linearscan@ library to allocate
+  registers for Hoople intermediate representations.
+  .
+  Additionally, it provides a DSL for construction of assembly language DSLs
+  that compile into Hoople program graphs.  See the tests for a concrete
+  example.
+
+library
+  default-language: Haskell2010
+  exposed-modules:
+    LinearScan.Hoopl
+    LinearScan.Hoopl.DSL
+  build-depends:    base >=4.7 && <4.8
+                  , hoopl >= 3.10.0.1
+                  , linearscan >= 0.3.0.1
+                  , containers
+                  , transformers
+                  , free
+
+test-suite test
+  default-language: Haskell2010
+  type:             exitcode-stdio-1.0
+  ghc-options:      -Wall -Werror -fno-warn-deprecated-flags
+  hs-source-dirs:   test
+  main-is:          Main.hs
+  other-modules:    AsmTest
+                    Assembly
+  build-depends: 
+        base >=3
+      , linearscan
+      , hspec              >= 1.4.4
+      , hspec-expectations >= 0.3
+      , hoopl              >= 3.10.0.1
+      , linearscan         >= 0.3.0.1
+      , linearscan-hoopl
+      , containers         >= 0.5.5
+      , transformers       >= 0.3.0.0
+      , lens-family-core
diff --git a/test/AsmTest.hs b/test/AsmTest.hs
new file mode 100644
--- /dev/null
+++ b/test/AsmTest.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module AsmTest where
+
+import           Assembly
+import           Compiler.Hoopl as Hoopl hiding ((<*>))
+import           Control.Exception
+import           Control.Monad.Trans.State (evalState)
+import           Data.Foldable
+import qualified Data.Map as M
+import           Data.Maybe (fromMaybe)
+import           LinearScan
+import           LinearScan.Hoopl
+import           LinearScan.Hoopl.DSL
+import           Test.Hspec
+
+asmTest :: Int -> Program (Node IRVar) -> Program (Node PhysReg) -> Expectation
+asmTest regs (compile "entry" -> (prog, entry))
+             (compile "entry" -> (result, _)) =
+    go $ M.fromList $ zip (Prelude.map entryLabel blocks) [(1 :: Int)..]
+  where
+    GMany NothingO body NothingO = prog
+    blocks = postorder_dfs_from body entry
+
+    alloc blockIds = allocate regs (blockInfo getBlockId) opInfo blocks
+      where
+        getBlockId :: Hoopl.Label -> Int
+        getBlockId lbl = fromMaybe (error "The impossible happened")
+                                   (M.lookup lbl blockIds)
+
+    go blockIds = case evalState (alloc blockIds) (newSpillStack 0 8) of
+        Left err -> error $ "Allocation failed: " ++ err
+        Right blks -> do
+            let graph' = newGraph blks
+            catch (showGraph show graph' `shouldBe`
+                   showGraph show result) $ \e -> do
+                putStrLn $ "---- Expecting ----\n" ++ showGraph show result
+                putStrLn $ "---- Compiled  ----\n" ++ showGraph show graph'
+                putStrLn "-------------------"
+                throwIO (e :: SomeException)
+      where
+        newBody = Data.Foldable.foldl' (flip addBlock) emptyBody
+        newGraph xs = GMany NothingO (newBody xs) NothingO
diff --git a/test/Assembly.hs b/test/Assembly.hs
new file mode 100644
--- /dev/null
+++ b/test/Assembly.hs
@@ -0,0 +1,279 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+module Assembly where
+
+import           Compiler.Hoopl as Hoopl hiding ((<*>))
+import           Control.Applicative
+import           Data.Foldable
+import qualified Data.List
+import           Data.Maybe (fromMaybe)
+import           Data.Monoid
+import           Data.Traversable
+import           Lens.Family hiding (Constant)
+import           LinearScan
+import           LinearScan.Hoopl
+import           LinearScan.Hoopl.DSL
+
+default (Int)
+
+-- | The basic instructions that have nothing to do with control flow.
+data Instruction reg = Add reg reg reg
+                     | Nop
+    deriving (Eq, Show, Functor, Foldable, Traversable)
+
+-- | Tests used for branching (correspond to branching instructions)
+data Test = Zero                -- ^ beq
+          | NonZero             -- ^ bne
+          | Positive            -- ^ bgt
+          | Negative            -- ^ blt
+          deriving (Eq, Show)
+
+data CConv = InlineC
+           | CConvC { ccArgs     :: [PhysReg]
+                    , ccResults  :: [PhysReg]
+                    , ccIsBrack  :: Bool
+                    }
+    deriving (Eq, Show)
+
+type Src a      = a -- ^ Type synonym for indicating source operands
+type Dst a      = a -- ^ Type synonym for indicating destination operands
+type Success a  = a -- ^ Type synonym for indicating success or true branch
+type Failure a  = a -- ^ Type synonym for indicating failure or false branch
+
+data Node v e x where
+    Label :: Label -> Node v C O
+
+    Alloc     :: Maybe (Src v) -> Dst v -> Node v O O
+    Reclaim   :: Src v -> Node v O O
+    Instr     :: Instruction v -> Node v O O
+    Call      :: CConv -> Instruction v -> Node v O O
+    LoadConst :: Int -> Dst v -> Node v O O
+    Move      :: Src v -> Dst v -> Node v O O
+    Copy      :: Src v -> Dst v -> Node v O O
+    Save      :: Src v -> Dst Int -> Node v O O
+    Restore   :: Src Int -> Dst v -> Node v O O
+
+    Jump        :: Label -> Node v O C
+    Branch      :: Test -> v -> Success Label -> Failure Label -> Node v O C
+    ReturnInstr :: [PhysReg] -> Instruction v -> Node v O C
+
+deriving instance Eq v => Eq (Node v e x)
+
+instance Show v => Show (Node v e x) where
+    show (Label l)         = show l ++ ":"
+    show (Alloc x1 x2)     = "\t@alloc " ++
+                             (case x1 of Just v -> " " ++ show v ; _ -> " _")
+                             ++ " " ++ show x2
+    show (Reclaim v)       = "\t@reclaim " ++ show v
+    show (Instr i)         = "\t" ++ show i
+    show (Call c i)        = "\t@call " ++ show c ++ " " ++ show i
+    show (LoadConst c v)   = "\t@lc " ++ show v ++ " " ++ show c
+    show (Move x1 x2)      = "\t@mvrr " ++ show x1 ++ " " ++ show x2
+    show (Copy x1 x2)      = "\t@cprr " ++ show x1 ++ " " ++ show x2
+    show (Save src dst)    = "\t@save " ++ " " ++ show src ++ " " ++ show dst
+    show (Restore src dst) = "\t@restore " ++ " " ++ show src ++ " " ++ show dst
+    show (Jump l)          = "\t@jmp " ++ show l
+    show (Branch c v t f)  = "\t@b" ++ show c ++ " " ++ show v
+                          ++ " " ++ show t ++ "; @jmp " ++ show f
+    show (ReturnInstr regs i) = "\t@return " ++ show regs ++ " " ++ show i
+
+instance NonLocal (Node v) where
+  entryLabel (Label l) = l
+
+  successors (Jump l)          = [l]
+  successors (Branch _ _ t f)  = [t, f]
+  successors (ReturnInstr _ _) = []
+
+instance HooplNode (Node v) where
+    mkBranchNode = Jump
+    mkLabelNode  = Label
+
+variables :: Applicative f => LensLike f (Node v1 e x) (Node v2 e x) v1 v2
+variables f = go
+  where
+    go (Alloc msrc dst)           = Alloc <$> traverse f msrc <*> f dst
+    go (Reclaim src)              = Reclaim <$> f src
+    go (Instr i)                  = Instr <$> traverse f i
+    go (LoadConst c dst)          = LoadConst c <$> f dst
+    go (Move src dst)             = Move <$> f src <*> f dst
+    go (Copy src dst)             = Copy <$> f src <*> f dst
+    go (Save src x)               = Save <$> f src <*> pure x
+    go (Restore x src)            = Restore x <$> f src
+    go (Branch x1 cond x2 x3)     = Branch x1 <$> f cond <*> pure x2 <*> pure x3
+    go (Call cc i)                = Call cc <$> traverse f i
+    go (ReturnInstr liveInRegs i) = ReturnInstr liveInRegs <$> traverse f i
+    go (Label x)                  = pure $ Label x
+    go (Jump x)                   = pure $ Jump x
+
+add :: v -> v -> v -> BodyNode (Node v)
+add x0 x1 x2 = bodyNode $ Instr (Add x0 x1 x2)
+
+nop :: BodyNode (Node v)
+nop = bodyNode $ Instr Nop
+
+move :: v -> v -> BodyNode (Node v)
+move x0 x1 = bodyNode $ Move x0 x1
+
+lc :: v -> BodyNode (Node v)
+lc x0 = bodyNode $ LoadConst 0 x0
+
+save :: PhysReg -> Dst PhysReg -> BodyNode (Node PhysReg)
+save r dst = bodyNode $ Save r dst
+
+restore :: Src PhysReg -> PhysReg -> BodyNode (Node PhysReg)
+restore src r = bodyNode $ Restore src r
+
+branch :: Test -> v -> String -> String -> EndNode (Node v)
+branch tst v good bad =
+    endNode $ Branch tst v <$> getLabel good <*> getLabel bad
+
+return_ :: EndNode (Node v)
+return_ = endNode $ return $ ReturnInstr [] Nop
+
+data IRVar = PhysicalIV PhysReg | VirtualIV Int deriving Eq
+
+instance Show IRVar where
+    show (PhysicalIV r) = "r" ++ show r
+    show (VirtualIV n)  = "v" ++ show n
+
+instance NodeAlloc SpillStack (Node IRVar) (Node PhysReg) where
+    isCall (Call {}) = True
+    isCall _ = False
+
+    isBranch (Jump {})   = True
+    isBranch (Branch {}) = True
+    isBranch _ = False
+
+    getReferences = go
+      where
+        go :: Node IRVar e x -> [VarInfo]
+        go (Label _)         = mempty
+        go (Instr i)         = fromInstr i
+        go (Jump _)          = mempty
+        go (Move src dst)    = mkv Input src <> mkv Output dst
+        go (LoadConst _ v)   = mkv Output v
+        go (Branch _ v _ _)  = mkv Input v
+        go (ReturnInstr _ i) = fromInstr i
+        go n = error $ "getReferences: unhandled node: " ++ show n
+
+        fromInstr :: Instruction IRVar -> [VarInfo]
+        fromInstr Nop = mempty
+        fromInstr (Add s1 s2 d1) =
+            mkv Input s1 <> mkv Input s2 <> mkv Output d1
+
+        mkv :: VarKind -> IRVar -> [VarInfo]
+        mkv k (PhysicalIV n) = [vinfo k (Left n)]
+        mkv k (VirtualIV n)  = [vinfo k (Right n)]
+
+        vinfo k en = VarInfo
+            { varId       = en
+            , varKind     = k
+            , regRequired = True
+            }
+
+    setRegisters = over variables . go
+      where
+        go :: [(Int, PhysReg)] -> IRVar -> PhysReg
+        go _ (PhysicalIV r) = r
+        go m (VirtualIV n)  =
+            fromMaybe (error $ "Allocation failed for variable " ++ show n)
+                      (Data.List.lookup n m)
+
+    mkMoveOps src dst = return [Move src dst]
+    mkSwapOps src dst = liftA2 (++) (mkRestoreOps Nothing dst)
+                                    (mkSaveOps src Nothing)
+
+    mkSaveOps    src dst = do off <- getStackSlot dst
+                              return [Save src off]
+    mkRestoreOps src dst = do off <- getStackSlot src
+                              return [Restore off dst]
+
+var :: Int -> IRVar
+var = VirtualIV
+
+v0  = var 0
+v1  = var 1
+v2  = var 2
+v3  = var 3
+v4  = var 4
+v5  = var 5
+v6  = var 6
+v7  = var 7
+v8  = var 8
+v9  = var 9
+v10 = var 10
+v11 = var 11
+v12 = var 12
+v13 = var 13
+v14 = var 14
+v15 = var 15
+v16 = var 16
+v17 = var 17
+v18 = var 18
+v19 = var 19
+v20 = var 20
+v21 = var 21
+v22 = var 22
+v23 = var 23
+v24 = var 24
+v25 = var 25
+v26 = var 26
+v27 = var 27
+v28 = var 28
+v29 = var 29
+v30 = var 30
+v31 = var 31
+v32 = var 32
+v33 = var 33
+v34 = var 34
+v35 = var 35
+v36 = var 36
+v37 = var 37
+v38 = var 38
+v39 = var 39
+v40 = var 40
+
+reg :: PhysReg -> PhysReg
+reg r = r
+
+r0  = reg 0
+r1  = reg 1
+r2  = reg 2
+r3  = reg 3
+r4  = reg 4
+r5  = reg 5
+r6  = reg 6
+r7  = reg 7
+r8  = reg 8
+r9  = reg 9
+r10 = reg 10
+r11 = reg 11
+r12 = reg 12
+r13 = reg 13
+r14 = reg 14
+r15 = reg 15
+r16 = reg 16
+r17 = reg 17
+r18 = reg 18
+r19 = reg 19
+r20 = reg 20
+r21 = reg 21
+r22 = reg 22
+r23 = reg 23
+r24 = reg 24
+r25 = reg 25
+r26 = reg 26
+r27 = reg 27
+r28 = reg 28
+r29 = reg 29
+r30 = reg 30
+r31 = reg 31
+r32 = reg 32
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,462 @@
+module Main where
+
+import AsmTest
+import Assembly
+import LinearScan.Hoopl.DSL
+import Test.Hspec
+
+-- | The objective of these tests is to present a program to the register
+--   allocator algorithm, and verify that for certain inputs we get the
+--   expected outputs.
+
+main :: IO ()
+main = hspec $ do
+  describe "Sanity tests" sanityTests
+  describe "Block tests" blockTests
+
+sanityTests :: SpecWith ()
+sanityTests = do
+  it "Single instruction" $ asmTest 32
+    (label "entry" $ do
+        add v0 v1 v2
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r2
+        return_
+
+  it "Single, repeated instruction" $ asmTest 32
+    (label "entry" $ do
+        add v0 v1 v2
+        add v0 v1 v2
+        add v0 v1 v2
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r2
+        add r0 r1 r2
+        add r0 r1 r2
+        return_
+
+  it "Multiple instructions" $ asmTest 32
+    (label "entry" $ do
+        add v0 v1 v2
+        add v0 v1 v3
+        add v0 v1 v2
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r2
+        add r0 r1 r3
+        add r0 r1 r2
+        return_
+
+  it "More variables used than registers" $ asmTest 32
+    (label "entry" $ do
+        add v0 v1 v2
+        add v3 v4 v5
+        add v6 v7 v8
+        add v9 v10 v11
+        add v12 v13 v14
+        add v15 v16 v17
+        add v18 v19 v20
+        add v21 v22 v23
+        add v24 v25 v26
+        add v27 v28 v29
+        add v30 v31 v32
+        add v33 v34 v35
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r24
+        add r2 r3 r0
+        add r4 r5 r1
+        add r6 r7 r2
+        add r8 r9 r3
+        add r10 r11 r4
+        add r12 r13 r5
+        add r14 r15 r6
+        add r16 r17 r7
+        add r18 r19 r8
+        add r20 r21 r9
+        add r22 r23 r10
+        return_
+
+  it "Single long-lived variable" $ asmTest 32
+    (label "entry" $ do
+        add v0 v1 v2
+        add v0 v4 v5
+        add v0 v7 v8
+        add v0 v10 v11
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r5
+        add r0 r2 r1
+        add r0 r3 r2
+        add r0 r4 r3
+        return_
+
+  it "Two long-lived variables" $ asmTest 32
+    (label "entry" $ do
+        add v0 v1 v2
+        add v0 v4 v5
+        add v0 v4 v8
+        add v0 v4 v11
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r3
+        add r0 r2 r1
+        add r0 r2 r4
+        add r0 r2 r5
+        return_
+
+  it "One variable with a long interval" $ asmTest 32
+    (label "entry" $ do
+        add v0   v1  v2
+        add v3   v4  v5
+        add v6   v7  v8
+        add v9  v10 v11
+        add v12 v13 v14
+        add v15 v16 v17
+        add v18 v19 v20
+        add v21 v22 v23
+        add v24 v25 v26
+        add v27 v28 v29
+        add v30 v31 v32
+        add v0  v34 v35
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r23
+        add r2 r3 r1
+        add r4 r5 r2
+        add r6 r7 r3
+        add r8 r9 r4
+        add r10 r11 r5
+        add r12 r13 r6
+        add r14 r15 r7
+        add r16 r17 r8
+        add r18 r19 r9
+        add r20 r21 r10
+        add r0 r22 r11
+        return_
+
+  it "Many variables with long intervals" $ asmTest 32
+    (label "entry" $ do
+        add v0   v1  v2
+        add v3   v4  v5
+        add v6   v7  v8
+        add v9  v10 v11
+        add v12 v13 v14
+        add v15 v16 v17
+        add v18 v19 v20
+        add v21 v22 v23
+        add v24 v25 v26
+        add v27 v28 v29
+        add v0   v1  v2
+        add v3   v4  v5
+        add v6   v7  v8
+        add v9  v10 v11
+        add v12 v13 v14
+        add v15 v16 v17
+        add v18 v19 v20
+        add v21 v22 v23
+        add v24 v25 v26
+        add v27 v28 v29
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r20
+        add r2 r3 r21
+        add r4 r5 r22
+        add r6 r7 r23
+        add r8 r9 r24
+        add r10 r11 r25
+        add r12 r13 r26
+        add r14 r15 r27
+        add r16 r17 r28
+        add r18 r19 r29
+        add r0 r1 r20
+        add r2 r3 r21
+        add r4 r5 r22
+        add r6 r7 r23
+        add r8 r9 r24
+        add r10 r11 r25
+        add r12 r13 r26
+        add r14 r15 r27
+        add r16 r17 r28
+        add r18 r19 r29
+        return_
+
+  it "Spilling one variable" $ asmTest 32
+    (label "entry" $ do
+        add v0   v1  v2
+        add v3   v4  v5
+        add v6   v7  v8
+        add v9  v10 v11
+        add v12 v13 v14
+        add v15 v16 v17
+        add v18 v19 v20
+        add v21 v22 v23
+        add v24 v25 v26
+        add v27 v28 v29
+        add v30 v31 v32
+        add v0   v1  v2
+        add v3   v4  v5
+        add v6   v7  v8
+        add v9  v10 v11
+        add v12 v13 v14
+        add v15 v16 v17
+        add v18 v19 v20
+        add v21 v22 v23
+        add v24 v25 v26
+        add v27 v28 v29
+        add v30 v31 v32
+        return_) $
+
+    label "entry" $ do
+        add r0 r1 r22
+        add r2 r3 r23
+        add r4 r5 r24
+        add r6 r7 r25
+        add r8 r9 r26
+        add r10 r11 r27
+        add r12 r13 r28
+        add r14 r15 r29
+        add r16 r17 r30
+        add r18 r19 r31
+
+        -- When we reach the 32nd variable considered (which happens to be
+        -- v30), we must spill a register because there are not 32 registers.
+        -- So we pick the first register, counting from 0, whose next use
+        -- position is the furthest from this position.  That happens to be
+        -- r18, which is next used at position 41.
+        save r18 0
+        add r20 r21 r18
+        add r0 r1 r22
+        add r2 r3 r23
+        add r4 r5 r24
+        add r6 r7 r25
+        add r8 r9 r26
+        add r10 r11 r27
+        add r12 r13 r28
+        add r14 r15 r29
+        add r16 r17 r30
+
+        -- When it comes time to reload v29 (which had been allocated to r18),
+        -- we pick the first available register which happens to be r0 in this
+        -- case.
+        restore 0 r0
+        add r0 r19 r31
+        add r20 r21 r18
+        return_
+
+  it "Inserts only necessary saves and restores" $ asmTest 4
+    (label "entry" $ do
+        add v0 v1 v2
+        add v2 v1 v3
+        add v3 v2 v4
+        add v4 v1 v0
+        return_) $
+
+    label "entry" $ do
+        add r1 r0 r2
+        add r2 r0 r3
+        save r0 0
+        add r3 r2 r0
+        restore 0 r2
+        add r0 r2 r1
+        return_
+
+blockTests :: SpecWith ()
+blockTests = do
+  it "Allocates across blocks" $ asmTest 32
+    (do label "entry" $ do
+            add v0 v1 v2
+            jump "L2"
+
+        label "L2" $ do
+            add v2 v3 v4
+            add v2 v4 v5
+            jump "L3"
+
+        label "L3" $ do
+            add v2 v5 v6
+            add v2 v6 v7
+            add v2 v7 v8
+            return_) $
+
+    do label "entry" $ do
+           add r0 r1 r3
+           jump "L2"
+
+       label "L2" $ do
+           add r3 r2 r0
+           add r3 r0 r1
+           jump "L3"
+
+       label "L3" $ do
+           add r3 r1 r0
+           add r3 r0 r1
+           add r3 r1 r0
+           return_
+
+  it "Inserts resolving moves" $ asmTest 4
+    (do label "entry" $ do
+            add v0 v1 v2
+            branch Zero v2 "B3" "B2"
+
+        label "B2" $ do
+            add v1 v2 v3
+            add v0 v0 v4
+            add v0 v0 v5
+            add v0 v4 v6
+            add v0 v5 v6
+            jump "B4"
+
+        label "B3" $ do
+            add v1 v2 v3
+            jump "B4"
+
+        label "B4" $ do
+            add v3 v3 v0
+            return_) $
+
+    do label "entry" $ do
+           add r0 r1 r2
+           branch Zero r2 "B2" "B3"
+
+       label "B2" $ do
+           add r1 r2 r3
+           jump "B4"
+
+       label "B3" $ do
+           add r1 r2 r3
+           save r3 16
+           save r2 8
+           save r1 0
+           add r0 r0 r1
+           add r0 r0 r2
+           add r0 r1 r3
+           add r0 r2 r3
+           restore 16 r3
+           jump "B4"
+
+       label "B4" $ do
+           add r3 r3 r0
+           return_
+
+  it "Inserts resolving moves another way" $ asmTest 4
+    (do label "entry" $ do
+            add v0 v1 v2
+            branch Zero v2 "B3" "B2"
+
+        label "B2" $ do
+            add v1 v2 v3
+            jump "B4"
+
+        label "B3" $ do
+            add v1 v2 v3
+            add v0 v0 v4
+            add v0 v0 v5
+            add v0 v4 v6
+            add v0 v5 v6
+            jump "B4"
+
+        label "B4" $ do
+            add v3 v3 v0
+            return_) $
+
+    do label "entry" $ do
+           add r0 r1 r2
+           branch Zero r2 "B2" "B3"
+
+       label "B2" $ do
+           add r1 r2 r3
+           save r3 0
+           add r0 r0 r1
+           add r0 r0 r2
+           add r0 r1 r3
+           add r0 r2 r3
+           restore 0 r1
+           jump "B4"
+
+       label "B3" $ do
+           add r1 r2 r3
+           move r3 r1
+           jump "B4"
+
+       label "B4" $ do
+           add r1 r1 r0
+           return_
+
+  it "Another resolution case" $ asmTest 4
+    (do label "entry" $ do
+            lc v3
+            lc v4
+            lc v15
+            lc v20
+            jump "L3"
+
+        label "L3" $ do
+            move v3 v9
+            move v9 v11
+            move v11 v10
+            move v10 v12
+            move v12 v13
+            lc v14
+            move v15 v5
+            jump "L6"
+
+        label "L6" $
+	    branch Zero v4 "L3" "L2"
+
+        label "L2" $ do
+            lc v21
+            move v21 v18
+            move v5 v4
+            lc v19
+            move v20 v17
+            jump "L6") $
+
+    do label "entry" $ do
+           lc r0
+           lc r1
+           lc r2
+           lc r3
+           save r3 0
+           jump "L3"
+
+       label "L3" $ do
+           restore 8 r0
+           move r0 r3
+           save r0 8
+           move r3 r0
+           move r0 r3
+           move r3 r0
+           move r0 r3
+           lc r0
+           save r0 16
+           move r2 r0
+           save r2 24
+           jump "L6"
+
+       label "L6" $
+           branch Zero r1 "L3" "L2"
+
+       label "L2" $ do
+           lc r3
+           move r3 r2
+           move r0 r1
+           save r1 40
+           save r0 32
+           lc r3
+           restore 0 r1
+           move r1 r0
+           restore 40 r1
+           restore 32 r0
+           restore 24 r2
+           save r1 0
+           jump "L6"