diff --git a/LinearScan/Hoopl.hs b/LinearScan/Hoopl.hs --- a/LinearScan/Hoopl.hs +++ b/LinearScan/Hoopl.hs @@ -11,12 +11,14 @@ import Control.Applicative import Control.Arrow import Control.Monad.Trans.Class -import Control.Monad.Trans.State (State, get, put, modify) +import Control.Monad.Trans.State (evalStateT, modify) +import Data.Foldable import qualified Data.Map as M import Data.Monoid import Debug.Trace import LinearScan import LinearScan.Hoopl.DSL +import Unsafe.Coerce class HooplNode (n v) => NodeAlloc n v r | n -> v, n -> r where fromVar :: v -> Either PhysReg VarId @@ -106,3 +108,33 @@ NodeOO n -> op1ToString n NodeOC n -> op1ToString n } + +newtype SimpleUniqueMonad' a = SUM' { unSUM' :: [Int] -> (a, [Int]) } + +runSimpleUniqueMonad' :: Int -> SimpleUniqueMonad a -> a +runSimpleUniqueMonad' start m = fst (unSUM' (unsafeCoerce m) [start..]) + +allocateHoopl :: (NonLocal (n v), NonLocal (n r), NodeAlloc n v r) + => Int -- ^ Number of machine registers + -> Int -- ^ Offset of the spill stack + -> Int -- ^ Size of spilled register in bytes + -> Label -- ^ Label of graph entry block + -> Graph (n v) C C -- ^ Program graph + -> Either String (Graph (n r) C C) +allocateHoopl regs offset slotSize entry graph = + newGraph <$> runSimpleUniqueMonad' (1 + length blocks) go + where + newGraph xs = GMany NothingO (newBody xs) NothingO + where + newBody = Data.Foldable.foldl' (flip addBlock) emptyBody + + blocks = postorder_dfs_from body entry + where + GMany NothingO body NothingO = graph + + go = evalStateT alloc (newEnvState offset slotSize) + where + alloc = allocate regs (blockInfo getBlockId) opInfo blocks + where + getBlockId :: Hoopl.Label -> Env Int + getBlockId = return . unsafeCoerce diff --git a/LinearScan/Hoopl/DSL.hs b/LinearScan/Hoopl/DSL.hs --- a/LinearScan/Hoopl/DSL.hs +++ b/LinearScan/Hoopl/DSL.hs @@ -39,11 +39,11 @@ , stackSlots = mempty } -newEnvState :: EnvState -newEnvState = EnvState +newEnvState :: Int -> Int -> EnvState +newEnvState offset slotSize = EnvState { envLabels = mempty , envBlockIds = mempty - , envSpillStack = newSpillStack 0 8 + , envSpillStack = newSpillStack offset slotSize , envAssignments = mempty } diff --git a/linearscan-hoopl.cabal b/linearscan-hoopl.cabal --- a/linearscan-hoopl.cabal +++ b/linearscan-hoopl.cabal @@ -1,5 +1,5 @@ name: linearscan-hoopl -version: 0.5.0.0 +version: 0.5.1.0 synopsis: Makes it easy to use the linearscan register allocator with Hoopl homepage: http://github.com/jwiegley/linearscan-hoopl license: BSD3 @@ -45,9 +45,9 @@ , linearscan , hspec >= 1.4.4 , hspec-expectations >= 0.3 - , hoopl >= 3.10.0.1 - , linearscan >= 0.4.0.0 - , linearscan-hoopl + , hoopl >= 3.10.0.1 && < 3.11 + , linearscan >= 0.5.0.0 + , linearscan-hoopl >= 0.5.0.0 , containers >= 0.5.5 , transformers >= 0.3.0.0 , lens-family-core diff --git a/test/AsmTest.hs b/test/AsmTest.hs --- a/test/AsmTest.hs +++ b/test/AsmTest.hs @@ -2,65 +2,36 @@ module AsmTest where -import Assembly -import Compiler.Hoopl as Hoopl hiding ((<*>)) -import Control.DeepSeq -import Control.Exception -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 +import Assembly +import Compiler.Hoopl as Hoopl hiding ((<*>)) +import Control.Exception +import LinearScan +import LinearScan.Hoopl +import LinearScan.Hoopl.DSL +import Normal () +import Test.Hspec 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 + let (graph, entry) = runSimpleUniqueMonad $ compile "entry" program + case allocateHoopl regs 0 8 entry graph of Left err -> error $ "Allocation failed: " ++ err - Right blks -> do - let graph' = newGraph $!! blks + Right graph' -> do 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 $ "---- Parsed ----\n" ++ showGraph show graph 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 - 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 +asmTest regs program = asmTestLiteral regs program - $ showGraph show - $ fst - $ runSimpleUniqueMonad - $ compile "entry" expected + . showGraph show + . fst + . runSimpleUniqueMonad + . compile "entry" diff --git a/test/Assembly.hs b/test/Assembly.hs --- a/test/Assembly.hs +++ b/test/Assembly.hs @@ -157,7 +157,7 @@ instance Show a => Show (Assign a PhysReg) where show (Assign v (-1)) = "<>" -- show (Assign v r) = "r" ++ show r ++ "|v" ++ show v - show (Assign v r) = show r + show (Assign _ r) = show r data IRVar = PhysicalIV PhysReg | VirtualIV Int deriving Eq