linearscan-hoopl (empty) → 0.1.0.0
raw patch · 8 files changed
+1056/−0 lines, 8 filesdep +basedep +containersdep +freesetup-changed
Dependencies added: base, containers, free, hoopl, hspec, hspec-expectations, lens-family-core, linearscan, linearscan-hoopl, transformers
Files
- LICENSE +30/−0
- LinearScan/Hoopl.hs +103/−0
- LinearScan/Hoopl/DSL.hs +84/−0
- Setup.hs +2/−0
- linearscan-hoopl.cabal +52/−0
- test/AsmTest.hs +44/−0
- test/Assembly.hs +279/−0
- test/Main.hs +462/−0
+ LICENSE view
@@ -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.
+ LinearScan/Hoopl.hs view
@@ -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
+ LinearScan/Hoopl/DSL.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ linearscan-hoopl.cabal view
@@ -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
+ test/AsmTest.hs view
@@ -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
+ test/Assembly.hs view
@@ -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
+ test/Main.hs view
@@ -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"