linearscan-hoopl 0.4.0.1 → 0.5.0.0

raw patch · 7 files changed

+556/−363 lines, 7 filesdep +deepseqdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LinearScan/Hoopl.hs +47/−49
• LinearScan/Hoopl/DSL.hs +65/−4
• linearscan-hoopl.cabal +5/−3
• test/AsmTest.hs +46/−24
• test/Assembly.hs +57/−24
• test/Main.hs +279/−259
• test/Normal.hs +57/−0

@@ -9,38 +9,63 @@  import           Compiler.Hoopl as Hoopl hiding ((<*>)) import           Control.Applicative-import           Control.Monad.Trans.State (State, get, put)+import           Control.Arrow+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.State (State, get, put, modify) import qualified Data.Map as M import           Data.Monoid+import           Debug.Trace import           LinearScan+import           LinearScan.Hoopl.DSL -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+class HooplNode (n v) => NodeAlloc n v r | n -> v, n -> r where+    fromVar :: v -> Either PhysReg VarId+    fromReg :: r -> PhysReg -    getReferences :: n1 e x -> [VarInfo]-    setRegisters  :: [(Int, PhysReg)] -> n1 e x -> n2 e x+    isCall   :: n v O O -> Bool+    isBranch :: n v O C -> Bool -    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]+    retargetBranch :: n v O C -> Label -> Label -> n v O C -    op1ToString  :: n1 e x -> String+    mkLabelOp :: Label -> n v C O+    mkJumpOp  :: Label -> n v O C +    getReferences :: n v e x -> [VarInfo]+    setRegisters  :: [(Int, PhysReg)] -> n v e x -> Env (n r e x)++    mkMoveOps    :: PhysReg -> PhysReg -> Env [n r O O]+    mkSwapOps    :: PhysReg -> PhysReg -> Env [n r O O]+    mkSaveOps    :: PhysReg -> Maybe VarId -> Env [n r O O]+    mkRestoreOps :: Maybe VarId -> PhysReg -> Env [n r O O]++    op1ToString  :: n v e x -> String+ 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 :: (NodeAlloc n v r, NonLocal (n v))+          => (Label -> Env Int)+          -> BlockInfo Env (Block (n v) C C) (Block (n r) C C)+                           (NodeV (n v)) (NodeV (n r)) blockInfo getBlockId = BlockInfo     { blockId = getBlockId . entryLabel -    , blockSuccessors = Prelude.map getBlockId . successors+    , blockSuccessors = Prelude.mapM getBlockId . successors +    , splitCriticalEdge = \(BlockCC b m e)+                           (BlockCC next _ _) -> do+        let lab = entryLabel next+        lab' <- lift freshLabel+        modify $ \st ->+            st { envLabels   = M.insert (show lab ++ "'") lab' (envLabels st)+               , envBlockIds = let m = envBlockIds st in+                               M.insert lab' (M.size m + 1) m+               }+        let e' = retargetBranch e lab lab'+        return (BlockCC b m e',+                BlockCC (mkLabelOp lab') BNil (mkJumpOp lab))+     , blockOps = \(BlockCC a b z) ->         ([NodeCO a], Prelude.map NodeOO (blockToList b), [NodeOC z]) @@ -51,7 +76,7 @@             (getNodeOC z)     } -opInfo :: forall s n1 n2. NodeAlloc s n1 n2 => OpInfo s (NodeV n1) (NodeV n2)+opInfo :: NodeAlloc n v r => OpInfo Env (NodeV (n v)) (NodeV (n r)) opInfo = OpInfo     { opKind = \node -> case node of            NodeOO n | isCall n  -> IsCall@@ -70,41 +95,14 @@     , 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)]+    , applyAllocs = \node m ->+        case node of+           NodeCO n -> setRegisters m n >>= \alloc -> return [NodeCO alloc]+           NodeOO n -> setRegisters m n >>= \alloc -> return [NodeOO alloc]+           NodeOC n -> setRegisters m n >>= \alloc -> return [NodeOC alloc]      , showOp1 = \node -> case node of            NodeCO n -> op1ToString n            NodeOO n -> op1ToString n            NodeOC n -> op1ToString 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

@@ -2,16 +2,66 @@  import           Compiler.Hoopl as Hoopl hiding ((<*>)) import           Control.Applicative+import           Control.Arrow (first) 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           Control.Monad.Trans.State (StateT, evalStateT,+                                            gets, modify, get, put) import qualified Data.Map as M import           Data.Monoid+import           LinearScan  type Labels = M.Map String Label+type BlockIds = M.Map Label Int +data SpillStack = SpillStack+    { stackPtr      :: Int+    , stackSlotSize :: Int+    , stackSlots    :: M.Map (Maybe Int) Int+    }+    deriving (Eq, Show)++data EnvState = EnvState+    { envLabels      :: Labels+    , envBlockIds    :: BlockIds+    , envSpillStack  :: SpillStack+    , envAssignments :: M.Map PhysReg VarId+    }++type Env = StateT EnvState SimpleUniqueMonad++newSpillStack :: Int -> Int -> SpillStack+newSpillStack offset slotSize = SpillStack+    { stackPtr      = offset+    , stackSlotSize = slotSize+    , stackSlots    = mempty+    }++newEnvState :: EnvState+newEnvState = EnvState+    { envLabels      = mempty+    , envBlockIds    = mempty+    , envSpillStack  = newSpillStack 0 8+    , envAssignments = mempty+    }++getStackSlot :: Maybe VarId -> Env Int+getStackSlot vid = do+    st <- get+    let stack = envSpillStack st+    case M.lookup vid (stackSlots stack) of+        Just off -> return off+        Nothing -> do+            let off = stackPtr stack+            put st { envSpillStack = stack+                 { stackPtr   = off + stackSlotSize stack+                 , stackSlots =+                     M.insert vid off (stackSlots stack)+                 }}+            return off+ -- | The 'Asm' monad lets us create labels by name and refer to them later. type Asm = StateT Labels SimpleUniqueMonad @@ -25,6 +75,18 @@             modify (M.insert str lbl)             return lbl +setAssignment :: PhysReg -> VarId -> Env ()+setAssignment reg vid =+    modify $ \env ->+        env { envAssignments = M.insert reg vid (envAssignments env) }++getAssignment :: PhysReg -> Env VarId+getAssignment reg = do+    l <- gets (M.lookup reg . envAssignments)+    case l of+        Just vid -> return vid+        Nothing  -> error $ "No assignment for register: " ++ show reg+ -- | 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@@ -63,10 +125,9 @@ -- | 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)+        => String -> Program n -> SimpleUniqueMonad (Graph n C C, Label) compile name prog-    = runSimpleUniqueMonad-    $ flip evalStateT (mempty :: Labels)+    = flip evalStateT (mempty :: Labels)     $ do body  <- go prog          entry <- gets (M.lookup name)          case entry of

@@ -1,5 +1,5 @@ name:          linearscan-hoopl-version:       0.4.0.1+version:       0.5.0.0 synopsis:      Makes it easy to use the linearscan register allocator with Hoopl homepage:      http://github.com/jwiegley/linearscan-hoopl license:       BSD3@@ -24,7 +24,7 @@   exposed-modules:     LinearScan.Hoopl     LinearScan.Hoopl.DSL-  build-depends:    base >=4.7 && <4.8+  build-depends:    base >=4.7 && <5                   , hoopl >= 3.10.0.1                   , linearscan >= 0.3.0.1                   , containers@@ -34,11 +34,12 @@ test-suite test   default-language: Haskell2010   type:             exitcode-stdio-1.0-  ghc-options:      -Wall -Werror -fno-warn-deprecated-flags+  ghc-options:      -Wall -fno-warn-deprecated-flags   hs-source-dirs:   test   main-is:          Main.hs   other-modules:    AsmTest                     Assembly+                    Normal   build-depends:          base >=3       , linearscan@@ -50,3 +51,4 @@       , containers         >= 0.5.5       , transformers       >= 0.3.0.0       , lens-family-core+      , deepseq

@@ -1,44 +1,66 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE ViewPatterns #-}  module AsmTest where  import           Assembly import           Compiler.Hoopl as Hoopl hiding ((<*>))+import           Control.DeepSeq import           Control.Exception-import           Control.Monad.Trans.State (evalState)+import           Control.Monad.Trans.State (evalStateT, gets) import           Data.Foldable import qualified Data.Map as M import           Data.Maybe (fromMaybe) import           LinearScan import           LinearScan.Hoopl import           LinearScan.Hoopl.DSL+import           Normal () 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) [(0 :: 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+asmTestLiteral :: Int -> Program (Node IRVar) -> String -> Expectation+asmTestLiteral regs program expected = do+    let eres = runSimpleUniqueMonad $ do+            x <- compile "entry" program+            uncurry runTest x+    case eres 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'+            let graph' = newGraph $!! blks+            let g = showGraph show graph'+            catch (g `shouldBe` expected) $ \e -> do+                let input = runSimpleUniqueMonad $ compile "entry" program+                putStrLn $ "---- Parsed ----\n" ++ showGraph show (fst input)+                putStrLn $ "---- Expecting ----\n" ++ expected+                putStrLn $ "---- Compiled  ----\n" ++ g                 putStrLn "-------------------"                 throwIO (e :: SomeException)+  where+    runTest prog entry =+        go $ M.fromList $ zip (Prelude.map entryLabel blocks) [(0 :: Int)..]       where-        newBody = Data.Foldable.foldl' (flip addBlock) emptyBody-        newGraph xs = GMany NothingO (newBody xs) NothingO+        GMany NothingO body NothingO = prog+        blocks = postorder_dfs_from body entry++        alloc = allocate regs (blockInfo getBlockId) opInfo $!! blocks+          where+            getBlockId :: Hoopl.Label -> Env Int+            getBlockId lbl = do+                bids <- gets envBlockIds+                return $ fromMaybe+                    (error $ "Unable to find block at label " ++ show lbl)+                    (M.lookup lbl bids)++        go blockIds = evalStateT alloc (newEnvState { envBlockIds = blockIds })++    newBody = Data.Foldable.foldl' (flip addBlock) emptyBody+    newGraph xs = GMany NothingO (newBody xs) NothingO++asmTest :: Int+        -> Program (Node IRVar)+        -> Program (Node (Assign VarId PhysReg))+        -> Expectation+asmTest regs program expected+    = asmTestLiteral regs program+    $ showGraph show+    $ fst+    $ runSimpleUniqueMonad+    $ compile "entry" expected

@@ -25,10 +25,15 @@ 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)+data Instruction reg+    = Add reg reg reg+    | Nop+    deriving (Eq, Functor, Foldable, Traversable) +instance Show r => Show (Instruction r) where+    show (Add x1 x2 x3) = "add " ++ show x1 ++ " " ++ show x2 ++ " " ++ show x3+    show Nop = "nop"+ -- | Tests used for branching (correspond to branching instructions) data Test = Zero                -- ^ beq           | NonZero             -- ^ bne@@ -79,8 +84,8 @@     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 (Save src dst)    = "\t@save " ++ show src ++ " " ++ show dst+    show (Restore src dst) = "\t@restore " ++ show src ++ " " ++ show dst     show (Trace str)       = "\tTRACE " ++ " " ++ show str     show (Jump l)          = "\t@jmp " ++ show l     show (Branch c v t f)  = "\t@b" ++ show c ++ " " ++ show v@@ -131,10 +136,10 @@ lc :: v -> BodyNode (Node v) lc x0 = bodyNode $ LoadConst 0 x0 -save :: PhysReg -> Dst PhysReg -> BodyNode (Node PhysReg)+save :: v -> Dst PhysReg -> BodyNode (Node v) save r dst = bodyNode $ Save r dst -restore :: Src PhysReg -> PhysReg -> BodyNode (Node PhysReg)+restore :: Src PhysReg -> v -> BodyNode (Node v) restore src r = bodyNode $ Restore src r  trace :: String -> BodyNode (Node v)@@ -147,13 +152,25 @@ return_ :: EndNode (Node v) return_ = endNode $ return $ ReturnInstr [] Nop +data Assign a b = Assign a b++instance Show a => Show (Assign a PhysReg) where+    show (Assign v (-1)) = "<<v" ++ show v ++ ">>"+    -- show (Assign v r)    = "r" ++ show r ++ "|v" ++ show v+    show (Assign v r)    = show r+ 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+instance NodeAlloc Node IRVar (Assign VarId PhysReg) where+    fromVar (PhysicalIV r) = Left r+    fromVar (VirtualIV n)  = Right n++    fromReg (Assign _ r) = r+     isCall (Call {}) = True     isCall _ = False @@ -161,6 +178,15 @@     isBranch (Branch {}) = True     isBranch _ = False +    retargetBranch (Jump _) _ lab = Jump lab+    retargetBranch (Branch b v x y) old lab+        | x == old  = Branch b v lab y+        | otherwise = Branch b v x lab+    retargetBranch x _ _ = error $ "Cannot retarget " ++ show x++    mkLabelOp = Label+    mkJumpOp  = Jump+     getReferences = go       where         go :: Node IRVar e x -> [VarInfo]@@ -190,23 +216,29 @@             , regRequired = True             } -    setRegisters = over variables . go+    setRegisters m g = do+        for_ m $ \(v, r) -> setAssignment r v+        return $ over variables go g       where-        go :: [(Int, PhysReg)] -> IRVar -> PhysReg-        go _ (PhysicalIV r) = r-        go m (VirtualIV n)  =-            fromMaybe-                (-1) -- (error $ "Allocation failed for variable " ++ show n)-                (Data.List.lookup n m)+        go :: IRVar -> Assign VarId PhysReg+        go (PhysicalIV r) = Assign (-1) r+        go (VirtualIV n)  = Assign n (fromMaybe (-1) (Data.List.lookup n m)) -    mkMoveOps src dst = return [Move src dst]-    mkSwapOps src dst = liftA2 (++) (mkRestoreOps Nothing dst)-                                    (mkSaveOps src Nothing)+    mkMoveOps src dst = do+        vid <- getAssignment src+        return [Move (Assign vid src) (Assign vid 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]+    mkSaveOps src dst = do+        off <- getStackSlot dst+        vid <- getAssignment src+        return [Save (Assign vid src) off]+    mkRestoreOps src dst = do+        off <- getStackSlot src+        vid <- getAssignment dst+        return [Restore off (Assign vid dst)]      op1ToString = show @@ -255,8 +287,9 @@ v39 = var 39 v40 = var 40 -reg :: PhysReg -> PhysReg-reg r = r+reg :: PhysReg -> IRVar -> Assign VarId PhysReg+reg _ (PhysicalIV _) = error "Don't use reg to reference a literal register"+reg r (VirtualIV v) = Assign v r  r0  = reg 0 r1  = reg 1

@@ -12,6 +12,7 @@ main :: IO () main = hspec $ do   describe "Sanity tests" sanityTests+  describe "Spill tests" spillTests   describe "Block tests" blockTests   describe "Call tests" callTests   describe "Loop tests" loopTests@@ -24,7 +25,7 @@         return_) $      label "entry" $ do-        add 0 1 0+        add (r0 v0) (r1 v1) (r0 v2)         return_    it "Single, repeated instruction" $ asmTest 32@@ -35,9 +36,9 @@         return_) $      label "entry" $ do-        add 0 1 2-        add 0 1 2-        add 0 1 2+        add (r0 v0) (r1 v0) (r2 v0)+        add (r0 v0) (r1 v0) (r2 v0)+        add (r0 v0) (r1 v0) (r2 v0)         return_    it "Multiple instructions" $ asmTest 32@@ -48,9 +49,9 @@         return_) $      label "entry" $ do-        add 0 1 2-        add 0 1 3-        add 0 1 2+        add (r0 v0) (r1 v0) (r2 v0)+        add (r0 v0) (r1 v0) (r3 v0)+        add (r0 v0) (r1 v0) (r2 v0)         return_    it "More variables used than registers" $ asmTest 6@@ -73,31 +74,31 @@         return_) $      label "entry" $ do-	lc 0-	lc 1-	lc 2-	lc 3-	lc 4-	lc 5-	save  4 0-	lc 4-	save  4 8-	lc 4-	save  4 16-	lc 4-	save  4 24-	lc 4-	add 0 1 0-	add 2 3 1-	restore  0 3-	add 3 5 2-	save  0 32-	restore  8 5-	restore  16 0-	add 5 0 3-	restore  24 5-	add 5 4 0-	return_+        lc (r0 v0)+        lc (r1 v0)+        lc (r2 v0)+        lc (r3 v0)+        lc (r4 v0)+        lc (r5 v0)+        save (r4 v0) 0+        lc (r4 v0)+        save (r4 v0) 8+        lc (r4 v0)+        save (r4 v0) 16+        lc (r4 v0)+        save (r4 v0) 24+        lc (r4 v0)+        add (r0 v0) (r1 v0) (r0 v0)+        add (r2 v0) (r3 v0) (r1 v0)+        restore 0 (r3 v0)+        add (r3 v0) (r5 v0) (r2 v0)+        save (r0 v0) 32+        restore 8 (r5 v0)+        restore 16 (r0 v0)+        add (r5 v0) (r0 v0) (r3 v0)+        restore 24 (r5 v0)+        add (r5 v0) (r4 v0) (r0 v0)+        return_    it "Single long-lived variable" $ asmTest 32     (label "entry" $ do@@ -108,10 +109,10 @@         return_) $      label "entry" $ do-        add 0 1 1-        add 0 2 2-        add 0 3 3-        add 0 4 0+        add (r0 v0) (r1 v0) (r1 v0)+        add (r0 v0) (r2 v0) (r2 v0)+        add (r0 v0) (r3 v0) (r3 v0)+        add (r0 v0) (r4 v0) (r0 v0)         return_    it "Two long-lived variables" $ asmTest 32@@ -123,10 +124,10 @@         return_) $      label "entry" $ do-        add 0 1 1-        add 0 2 3-        add 0 2 4-        add 0 2 0+        add (r0 v0) (r1 v0) (r1 v0)+        add (r0 v0) (r2 v0) (r3 v0)+        add (r0 v0) (r2 v0) (r4 v0)+        add (r0 v0) (r2 v0) (r0 v0)         return_    it "One variable with a long interval" $ asmTest 32@@ -146,18 +147,18 @@         return_) $      label "entry" $ do-        add 0 1 1-        add 2 3 2-        add 4 5 3-        add 6 7 4-        add 8 9 5-        add 10 11 6-        add 12 13 7-        add 14 15 8-        add 16 17 9-        add 18 19 10-        add 20 21 11-        add 0 22 0+        add (r0 v0) (r1 v0) (r1 v0)+        add (r2 v0) (r3 v0) (r2 v0)+        add (r4 v0) (r5 v0) (r3 v0)+        add (r6 v0) (r7 v0) (r4 v0)+        add (r8 v0) (r9 v0) (r5 v0)+        add (r10 v0) (r11 v0) (r6 v0)+        add (r12 v0) (r13 v0) (r7 v0)+        add (r14 v0) (r15 v0) (r8 v0)+        add (r16 v0) (r17 v0) (r9 v0)+        add (r18 v0) (r19 v0) (r10 v0)+        add (r20 v0) (r21 v0) (r11 v0)+        add (r0 v0) (r22 v0) (r0 v0)         return_    it "Many variables with long intervals" $ asmTest 32@@ -185,28 +186,30 @@         return_) $      label "entry" $ do-        add 0 1 20-        add 2 3 21-        add 4 5 22-        add 6 7 23-        add 8 9 24-        add 10 11 25-        add 12 13 26-        add 14 15 27-        add 16 17 28-        add 18 19 29-        add 0 1 20-        add 2 3 21-        add 4 5 22-        add 6 7 23-        add 8 9 24-        add 10 11 25-        add 12 13 26-        add 14 15 27-        add 16 17 28-        add 18 19 29+        add (r0 v0) (r1 v0) (r20 v0)+        add (r2 v0) (r3 v0) (r21 v0)+        add (r4 v0) (r5 v0) (r22 v0)+        add (r6 v0) (r7 v0) (r23 v0)+        add (r8 v0) (r9 v0) (r24 v0)+        add (r10 v0) (r11 v0) (r25 v0)+        add (r12 v0) (r13 v0) (r26 v0)+        add (r14 v0) (r15 v0) (r27 v0)+        add (r16 v0) (r17 v0) (r28 v0)+        add (r18 v0) (r19 v0) (r29 v0)+        add (r0 v0) (r1 v0) (r20 v0)+        add (r2 v0) (r3 v0) (r21 v0)+        add (r4 v0) (r5 v0) (r22 v0)+        add (r6 v0) (r7 v0) (r23 v0)+        add (r8 v0) (r9 v0) (r24 v0)+        add (r10 v0) (r11 v0) (r25 v0)+        add (r12 v0) (r13 v0) (r26 v0)+        add (r14 v0) (r15 v0) (r27 v0)+        add (r16 v0) (r17 v0) (r28 v0)+        add (r18 v0) (r19 v0) (r29 v0)         return_ +spillTests :: SpecWith ()+spillTests = do   it "Spilling one variable" $ asmTest 32     (label "entry" $ do         add v0   v1  v2@@ -234,40 +237,40 @@         return_) $      label "entry" $ do-        add 0 1 22-        add 2 3 23-        add 4 5 24-        add 6 7 25-        add 8 9 26-        add 10 11 27-        add 12 13 28-        add 14 15 29-        add 16 17 30-        add 18 19 31+        add (r0 v0) (r1 v0) (r22 v0)+        add (r2 v0) (r3 v0) (r23 v0)+        add (r4 v0) (r5 v0) (r24 v0)+        add (r6 v0) (r7 v0) (r25 v0)+        add (r8 v0) (r9 v0) (r26 v0)+        add (r10 v0) (r11 v0) (r27 v0)+        add (r12 v0) (r13 v0) (r28 v0)+        add (r14 v0) (r15 v0) (r29 v0)+        add (r16 v0) (r17 v0) (r30 v0)+        add (r18 v0) (r19 v0) (r31 v0)          -- 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         -- 18, which is next used at position 41.-        save 18 0-        add 20 21 18-        add 0 1 22-        add 2 3 23-        add 4 5 24-        add 6 7 25-        add 8 9 26-        add 10 11 27-        add 12 13 28-        add 14 15 29-        add 16 17 30+        save (r18 v0) 0+        add (r20 v0) (r21 v0) (r18 v0)+        add (r0 v0) (r1 v0) (r22 v0)+        add (r2 v0) (r3 v0) (r23 v0)+        add (r4 v0) (r5 v0) (r24 v0)+        add (r6 v0) (r7 v0) (r25 v0)+        add (r8 v0) (r9 v0) (r26 v0)+        add (r10 v0) (r11 v0) (r27 v0)+        add (r12 v0) (r13 v0) (r28 v0)+        add (r14 v0) (r15 v0) (r29 v0)+        add (r16 v0) (r17 v0) (r30 v0)          -- When it comes time to reload v29 (which had been allocated to 18),         -- we pick the first available register which happens to be 0 in this         -- case.-        restore 0 0-        add 0 19 31-        add 20 21 18+        restore 0 (r0 v0)+        add (r0 v0) (r19 v0) (r31 v0)+        add (r20 v0) (r21 v0) (r18 v0)         return_    it "Higher register pressure" $ asmTest 3@@ -285,25 +288,25 @@         return_) $      label "entry" $ do-	lc 0-	lc 1-	add 0 1 2-	add 2 1 0-	save  1 0-	add 0 2 1-	save  2 8-	add 1 0 2-	save  1 16-	restore  8 1-	add 1 0 0-	save  0 24-	restore  16 0-	add 0 2 1-	restore  24 2-	add 2 1 0-	restore  0 1-	add 0 1 0-	return_+        lc (r0 v0)+        lc (r1 v0)+        add (r0 v0) (r1 v0) (r2 v0)+        add (r2 v0) (r1 v0) (r0 v0)+        save (r1 v0) 0+        add (r0 v0) (r2 v0) (r1 v0)+        save (r2 v0) 8+        add (r1 v0) (r0 v0) (r2 v0)+        save (r1 v0) 16+        restore 8 (r1 v0)+        add (r1 v0) (r0 v0) (r0 v0)+        save (r0 v0) 24+        restore 16 (r0 v0)+        add (r0 v0) (r2 v0) (r1 v0)+        restore 24 (r2 v0)+        add (r2 v0) (r1 v0) (r0 v0)+        restore 0 (r1 v0)+        add (r0 v0) (r1 v0) (r0 v0)+        return_    it "Inserts necessary saves and restores" $ asmTest 4     (label "entry" $ do@@ -320,18 +323,18 @@         return_) $      label "entry" $ do-        lc 0-        lc 1-        add 0 1 2-        add 2 1 3-        add 3 2 0-        save 1 0-        add 0 3 1-        add 2 3 2-        add 0 1 0-        add 2 0 0-        restore 0 1-        add 0 1 0+        lc (r0 v0)+        lc (r1 v0)+        add (r0 v0) (r1 v0) (r2 v0)+        add (r2 v0) (r1 v0) (r3 v0)+        add (r3 v0) (r2 v0) (r0 v0)+        save (r1 v0) 0+        add (r0 v0) (r3 v0) (r1 v0)+        add (r2 v0) (r3 v0) (r2 v0)+        add (r0 v0) (r1 v0) (r0 v0)+        add (r2 v0) (r0 v0) (r0 v0)+        restore 0 (r1 v0)+        add (r0 v0) (r1 v0) (r0 v0)         return_  blockTests :: SpecWith ()@@ -353,18 +356,18 @@             return_) $      do label "entry" $ do-           add 0 1 0+           add (r0 v0) (r1 v0) (r0 v0)            jump "L2"         label "L2" $ do-           add 0 2 1-           add 0 1 1+           add (r0 v0) (r2 v0) (r1 v0)+           add (r0 v0) (r1 v0) (r1 v0)            jump "L3"         label "L3" $ do-           add 0 1 1-           add 0 1 1-           add 0 1 0+           add (r0 v0) (r1 v0) (r1 v0)+           add (r0 v0) (r1 v0) (r1 v0)+           add (r0 v0) (r1 v0) (r0 v0)            return_    it "Inserts resolving moves" $ asmTest 3@@ -391,30 +394,30 @@             return_) $      do label "entry" $ do-           lc 0-           lc 1-           add 0 1 2-           branch Zero 2 "B2" "B3"+           lc (r0 v0)+           lc (r1 v0)+           add (r0 v0) (r1 v0) (r2 v0)+           branch Zero (r2 v0) "B2" "B3"         label "B2" $ do-           add 1 2 0-           move 0 1+           move (r1 v0) (r0 v0)+           add (r0 v0) (r2 v0) (r1 v0)            jump "B4"         label "B3" $ do-           save 0 0-           add 1 2 0-           restore 0 2-           add 2 0 1-           save 0 8-           add 2 1 0-           add 1 0 0-           restore 8 1-           add 0 1 0+           save (r0 v0) 0+           add (r1 v0) (r2 v0) (r0 v0)+           restore 0 (r2 v0)+           add (r2 v0) (r0 v0) (r1 v0)+           save (r0 v0) 8+           add (r2 v0) (r1 v0) (r0 v0)+           add (r1 v0) (r0 v0) (r0 v0)+           restore 8 (r1 v0)+           add (r0 v0) (r1 v0) (r0 v0)            jump "B4"         label "B4" $ do-           add 1 1 2+           add (r1 v0) (r1 v0) (r0 v0)            return_    it "When resolving moves are not needed" $ asmTest 4@@ -439,82 +442,104 @@             return_) $      do label "entry" $ do-           add 0 1 2-           branch Zero 2 "B2" "B3"+           add (r0 v0) (r1 v0) (r2 v0)+           branch Zero (r2 v0) "B2" "B3"         label "B2" $ do-           add 1 2 3-           add 0 0 1-           add 0 0 2-           add 0 1 1-           add 0 2 1+           add (r1 v0) (r2 v0) (r3 v0)+           add (r0 v0) (r0 v0) (r1 v0)+           add (r0 v0) (r0 v0) (r2 v0)+           add (r0 v0) (r1 v0) (r1 v0)+           add (r0 v0) (r2 v0) (r1 v0)            jump "B4"         label "B3" $ do-           add 1 2 3+           add (r1 v0) (r2 v0) (r3 v0)            jump "B4"         label "B4" $ do-           add 3 3 0+           add (r3 v0) (r3 v0) (r0 v0)            return_ -  -- it "Another resolution case" $ asmTest 4-  --   (do label "entry" $ do-  --           lc v3-  --           lc v4-  --           lc v15-  --           lc v20-  --           jump "L3"+  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 "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 "L6" $+            branch Zero v4 "L3" "L2" -  --       label "L2" $ do-  --           lc v21-  --           move v21 v18-  --           move v5 v4-  --           lc v19-  --           move v20 v17-  --           jump "L6") $+        label "L2" $ do+            lc v21+            move v21 v18+            move v5 v4+            lc v19+            move v20 v17+            jump "L6") $ -  --   do label "entry" $ do-  --          lc 0-  --          lc 1-  --          lc 2-  --          lc 3-  --          jump "L3"+    do label "entry" $ do+           lc (r0 v0)+           lc (r1 v0)+           lc (r2 v0)+           lc (r3 v0)+           save (r3 v0) 0+           jump "L3" -  --      label "L3" $ do-  --          move 0 3-  --          move 3 0-  --          move 0 3-  --          move 3 0-  --          move 0 3-  --          lc 0-  --          move 2 0-  --          jump "L6"+       label "L3" $ do+           move (r0 v0) (r3 v0)+           move (r3 v0) (r3 v0)+           move (r3 v0) (r3 v0)+           move (r3 v0) (r3 v0)+           move (r3 v0) (r3 v0)+           save (r0 v0) 8+           lc (r0 v0)+           save (r0 v0) 16+           move (r2 v0) (r0 v0)+           jump "L6" -  --      label "L6" $-  --          branch Zero 1 "L3" "L2"+       label "L2" $ do+           lc (r3 v0)+           save (r2 v0) 24+           move (r3 v0) (r2 v0)+           move (r0 v0) (r1 v0)+           save (r0 v0) 32+           lc (r0 v0)+           save (r1 v0) 48+           save (r0 v0) 40+           restore 0 (r1 v0)+           move (r1 v0) (r0 v0)+           save (r1 v0) 0+           restore 24 (r2 v0)+           restore 32 (r0 v0)+           restore 48 (r1 v0)+           jump "L6" -  --      label "L2" $ do-  --          lc 3-  --          move 3 2-  --          move 0 1-  --          lc 3-  --          move 1 0-  --          jump "L6"+       label "L6" $+           branch Zero (r1 v0) "L5" "L2" +       label "L5" $ do+           save (r1 v0) 48+           restore 0 (r1 v0)+           save (r2 v0) 24+           save (r1 v0) 0+           restore 24 (r2 v0)+           restore 48 (r1 v0)+           restore 8 (r0 v0)+           jump "L3"+ callTests :: SpecWith () callTests = do   it "Spills all registers at call" $ asmTest 4@@ -533,32 +558,32 @@         return_) $      label "entry" $ do-        lc 0-        lc 1-        add 0 1 2-        add 2 1 3-        add 3 2 0-        save 1 0-        add 0 3 1-        save 2 32-        save 3 24-        save 0 16-        save 1 8+        lc (r0 v0)+        lc (r1 v1)+        add (r0 v0) (r1 v1) (r2 v2)+        add (r2 v2) (r1 v1) (r3 v3)+        add (r3 v3) (r2 v2) (r0 v4)+        save (r1 v1) 0+        add (r0 v4) (r3 v3) (r1 v5)+        save (r2 v2) 32+        save (r3 v3) 24+        save (r0 v4) 16+        save (r1 v5) 8         call 1000-        restore 32 1-        restore 24 2-        add 1 2 0-        restore 16 2-        restore 8 3-        add 2 3 1-        add 0 1 0-        restore 0 1-        add 0 1 0+        restore 32 (r1 v2)+        restore 24 (r2 v3)+        add (r1 v2) (r2 v3) (r0 v6)+        restore 16 (r2 v4)+        restore 8 (r3 v5)+        add (r2 v4) (r3 v5) (r1 v7)+        add (r0 v6) (r1 v7) (r0 v8)+        restore 0 (r1 v1)+        add (r0 v8) (r1 v1) (r0 v0)         return_  loopTests :: SpecWith () loopTests = do-  it "Correctly orders loop blocks" $ asmTest 4+  it "Correctly orders loop blocks" $ asmTestLiteral 4     (do label "entry" $ do             trace "B0"             jump "B1"@@ -591,34 +616,29 @@             trace "B7"             jump "B1") $ -    do label "entry" $ do-           trace "B0"-           jump "B1"--       label "B1" $ do-           trace "B1"-           branch Zero 0 "B3" "B2"--       label "B2" $ do-           trace "B2"-           branch Zero 0 "B5" "B4"--       label "B3" $ do-           trace "B3"-           jump "B1"--       label "B4" $ do-           trace "B4"-           branch Zero 0 "B7" "B6"--       label "B5" $ do-           trace "B5"-           return_--       label "B6" $ do-           trace "B6"-           jump "B4"--       label "B7" $ do-           trace "B7"-           jump "B1"+    "L1:\n\+\\tTRACE  \"B0\"\n\+\\t@jmp L2\n\+\L2:\n\+\\tTRACE  \"B1\"\n\+\\t@bZero 0 L3; @jmp L4\n\+\L3:\n\+\\tTRACE  \"B3\"\n\+\\t@jmp L2\n\+\L4:\n\+\\tTRACE  \"B2\"\n\+\\t@bZero 0 L5; @jmp L9\n\+\L5:\n\+\\tTRACE  \"B5\"\n\+\\t@return [] nop\n\+\L6:\n\+\\tTRACE  \"B4\"\n\+\\t@bZero 0 L7; @jmp L8\n\+\L7:\n\+\\tTRACE  \"B7\"\n\+\\t@jmp L2\n\+\L8:\n\+\\tTRACE  \"B6\"\n\+\\t@jmp L6\n\+\L9:\n\+\\t@jmp L6\n"

@@ -0,0 +1,57 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Normal where++import Assembly+import Compiler.Hoopl as Hoopl hiding ((<*>))+import Control.DeepSeq++instance (NFData a, NFData b) => NFData (Assign a b) where+    rnf (Assign a b) = a `deepseq` b `deepseq` ()++instance NFData IRVar where+    rnf (PhysicalIV r) = r `deepseq` ()+    rnf (VirtualIV r) = r `deepseq` ()++instance NFData v => NFData (Instruction v) where+    rnf (Add x y z) = x `deepseq` y `deepseq` z `deepseq` ()+    rnf Nop = ()++instance NFData CConv where+    rnf InlineC = ()+    rnf (CConvC args results _) = args `deepseq` results `deepseq` ()++instance NFData Label where rnf _ = ()++instance NFData Test where rnf _ = ()++instance NFData v => NFData (Node v e x) where+    rnf (Alloc msrc dst)           = msrc `deepseq` dst `deepseq` ()+    rnf (Reclaim src)              = src `deepseq` ()+    rnf (Instr i)                  = i `deepseq` ()+    rnf (LoadConst c dst)          = c `deepseq` dst `deepseq` ()+    rnf (Move src dst)             = src `deepseq` dst `deepseq` ()+    rnf (Copy src dst)             = src `deepseq` dst `deepseq` ()+    rnf (Save src x)               = src `deepseq` x `deepseq` ()+    rnf (Restore x src)            = x `deepseq` src `deepseq` ()+    rnf (Trace str)                = str `deepseq` ()+    rnf (Branch x1 cond x2 x3)     = x1 `deepseq` cond `deepseq`+                                     x2 `deepseq` x3 `deepseq` ()+    rnf (Call cc i)                = cc `deepseq` i `deepseq` ()+    rnf (ReturnInstr liveInRegs i) = liveInRegs `deepseq` i `deepseq` ()+    rnf (Label x)                  = x `deepseq` ()+    rnf (Jump x)                   = x `deepseq` ()++instance NFData v => NFData (Block (Node v) e x) where+    rnf (BlockCO i b)   = i `deepseq` b `deepseq` ()+    rnf (BlockCC i b o) = i `deepseq` b `deepseq` o `deepseq` ()+    rnf (BlockOC b o)   = b `deepseq` o `deepseq` ()+    rnf BNil            = ()+    rnf (BMiddle n)     = n `deepseq` ()+    rnf (BCat n1 n2)    = n1 `deepseq` n2 `deepseq` ()+    rnf (BSnoc b n)     = b `deepseq` n `deepseq` ()+    rnf (BCons n b)     = n `deepseq` b `deepseq` ()