From b2320404202ad3296480bd472a6a79f5e5427de8 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Sun, 28 Apr 2019 16:49:32 +0200 Subject: Preliminary finish of lowering That is to say, there is no register allocation yet, but I think the currently generated code can be regalloc'd without much trouble. --- Compiler.hs | 1 + Intermediate.hs | 3 ++ Lower.hs | 123 ++++++++++++++++++++++++++++++++++++++++++-------------- VM.hs | 1 + 4 files changed, 98 insertions(+), 30 deletions(-) diff --git a/Compiler.hs b/Compiler.hs index d190565..d8c4675 100644 --- a/Compiler.hs +++ b/Compiler.hs @@ -153,6 +153,7 @@ withScope sc act = do compileProgram :: Program -> Either String IRProgram compileProgram (Program values) = runCM $ do bstart <- newBlockSwitch + addIns (RNone, IApplicationEntry) forM_ values $ \value -> do bnext <- newBlock ref <- genTValue (analyseValue value) bnext diff --git a/Intermediate.hs b/Intermediate.hs index 2729493..8c4a5dc 100644 --- a/Intermediate.hs +++ b/Intermediate.hs @@ -46,6 +46,8 @@ data InsCode | IDiscard Ref -- | Do stuff on function entry | IFunctionEntry + -- | Do stuff on application entry + | IApplicationEntry deriving Eq data Terminator @@ -98,6 +100,7 @@ instance Show InsCode where show (IAllocClo name vs) = "alloc-closure \"" ++ name ++ "\" " ++ show vs show (IDiscard r) = "discard " ++ show r show IFunctionEntry = "function-entry" + show IApplicationEntry = "application-entry" instance Show Terminator where show (IBr r b1 b2) = "br " ++ show r ++ " " ++ show b1 ++ " " ++ show b2 diff --git a/Lower.hs b/Lower.hs index 778193b..8fbe0da 100644 --- a/Lower.hs +++ b/Lower.hs @@ -3,6 +3,7 @@ module Lower(lowerIR) where import AST (Name) import Control.Monad.State.Strict +import Data.List import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Intermediate @@ -23,10 +24,34 @@ data AsmInstr' -- Load/Store: 'Int' is number of BYTES. | Load Int ARef ARef | Store Int ARef ARef + -- Macro's that will be instantiated with code to set up and clean up -- the register spill space. Will use R14 as temporary. | SetupSpill | CleanupSpill + + -- Semantics: CallR rFun r8 =^= add R14, R0, r8; jnzr R0, rFun + -- r8 should contain the integer 8, rFun the function pointer + | CallR ARef ARef + + -- Memcpy8 rDEST rSRC rNUM rTEMP + -- Destroys all four registers, and requires that they have a PreventSpill annotation + -- + -- jz rNUM, Lfinish + -- Lloop: + -- l64 rTEMP, rSRC + -- s64 rDEST, rTEMP + -- li rTEMP, 8 + -- add rDEST, rDEST, rTEMP + -- add rSRC, rSRC, rTEMP + -- li rTEMP, 1 + -- sub rNUM, rNUM, rTEMP + -- jnz rNUM, Lloop + -- Lfinish: + | Memcpy8 ARef ARef ARef ARef + + -- Marks the virtual register as non-spillable. Should be an AReg. + | PreventSpill ARef deriving (Show) data ARef @@ -78,6 +103,7 @@ initState (IRProgram bbs _ _) = LowerState (maxTemp + 1) IAllocClo _ rs -> maximum (map maxTempR rs) IDiscard r -> maxTempR r IFunctionEntry -> 0 + IApplicationEntry -> 0 maxTempT term = case term of IBr r _ _ -> maxTempR r IJmp _ -> 0 @@ -121,6 +147,15 @@ genTemp = liftM AReg genId -- - Closure item 1 -- ... -- - Closure item N-1 +-- +-- Register usage: +-- - R15 = stack pointer +-- - R14 = link register +-- - R13 = return register +-- - R12 = administration-temporary (TODO can this be eliminated) +-- - Further registers: available for allocation +-- R13 and R14 can also be used as administration-temporary if they are not +-- otherwise occupied. lowerIR :: IRProgram -> AsmProgram' @@ -134,7 +169,7 @@ lowerIR origProgram = in AsmProgram' (runLM origProgram blocks) lowerBB :: BB -> GFDMap -> LM [AsmInstr'] -lowerBB (BB _bid inss term) gfds = do +lowerBB (BB _ inss term) gfds = do res1 <- concat <$> mapM (\ins -> lowerIns ins gfds) inss res2 <- lowerTerm term return (res1 ++ res2) @@ -161,13 +196,16 @@ lowerIns (dest, instruction) gfds = case instruction of (inss2, argrs) <- toARefs args eightr <- genTemp - twentyfourr <- genTemp numitemsr <- genTemp numbytesr <- genTemp closurebufr <- genTemp stackshiftr <- genTemp walkr <- genTemp funptrr <- genTemp + memcpyTargetr <- genTemp + memcpySourcer <- genTemp + memcpyNumr <- genTemp + memcpyTempr <- genTemp -- mov qword rcx, [closurer + 8] -- shl rcx, 3 @@ -191,27 +229,34 @@ lowerIns (dest, instruction) gfds = case instruction of ,Load 8 numitemsr walkr ,Arith Add walkr walkr eightr ,Arith Mul numbytesr numitemsr eightr - ,Arith Sub (ASysReg 15) (ASysReg 15) numbytesr - ,Mv closurebufr (ASysReg 15)] ++ - -- Now do the copy by calling out to an intrinsic function ._. - [Arith Sub (ASysReg 15) (ASysReg 15) eightr - ,Store 8 (ASysReg 15) numbytesr - ,Arith Sub (ASysReg 15) (ASysReg 15) eightr - ,Store 8 (ASysReg 15) walkr - ,Arith Sub (ASysReg 15) (ASysReg 15) eightr - ,Store 8 (ASysReg 15) closurebufr - ,Jcc CCNZ (ASysReg 0) (Label "__builtin_memcpy") - ,Li twentyfourr (Imm 24) - ,Arith Add (ASysReg 15) (ASysReg 15) twentyfourr] ++ + ,Arith Sub closurebufr (ASysReg 15) numbytesr + -- Now do the copy + ,Mv memcpyTargetr closurebufr + ,Mv memcpySourcer walkr + ,Mv memcpyNumr numitemsr + ,PreventSpill memcpyTargetr + ,PreventSpill memcpySourcer + ,PreventSpill memcpyNumr + ,PreventSpill memcpyTempr + ,Memcpy8 memcpyTargetr memcpySourcer memcpyNumr memcpyTempr + -- We're using R14 as temporary stack pointer here, so that the + -- actual R15 doesn't move just yet + ,Mv (ASysReg 14) closurebufr] ++ -- Copy the function parameters - concat [[Arith Sub (ASysReg 15) (ASysReg 15) eightr - ,Store 8 (ASysReg 15) ref] + concat [[Arith Sub (ASysReg 14) (ASysReg 14) eightr + ,Store 8 (ASysReg 14) ref] | ref <- reverse argrs] ++ [Load 8 funptrr closurer - -- Do the call; don't separate these two instructions! - ,Arith Add (ASysReg 14) (ASysReg 0) eightr - ,JccR CCNZ (ASysReg 0) funptrr + -- Do the call; these registers must not spill, since the + -- stack references resulting from retrieval from the spill + -- area would be invalid with the shifted stack pointer + ,PreventSpill funptrr + ,PreventSpill eightr + ,Mv (ASysReg 15) (ASysReg 14) + ,CallR funptrr eightr -- Clean up the stack + ,PreventSpill stackshiftr + ,PreventSpill numbytesr ,Li stackshiftr (Imm (8 * length argrs)) ,Arith Add stackshiftr stackshiftr numbytesr ,Arith Add (ASysReg 15) (ASysReg 15) stackshiftr @@ -253,13 +298,17 @@ lowerIns (dest, instruction) gfds = case instruction of IFunctionEntry -> do -- We need to push the link register and set up the spill space - eightr <- genTemp + -- Note that the return register isn't used at this point, so we + -- can abuse it as an 8 register return - [Li eightr (Imm 8) - ,Arith Sub (ASysReg 15) (ASysReg 15) eightr + [Li (ASysReg 13) (Imm 8) + ,Arith Sub (ASysReg 15) (ASysReg 15) (ASysReg 13) ,Store 8 (ASysReg 15) (ASysReg 14) ,SetupSpill] + IApplicationEntry -> + return [SetupSpill] + lowerTerm :: Terminator -> LM [AsmInstr'] lowerTerm terminator = case terminator of IBr cond tg1 tg2 -> do @@ -319,23 +368,37 @@ closuresAreParams :: IRProgram -> IRProgram closuresAreParams (IRProgram bbs gfds datatbl) = IRProgram (map convertBB bbs) gfds datatbl where - argccount = floodArgCountAll gfds bbs + argccount = floodArgCount gfds bbs convertBB (BB bid inss term) = BB bid (map (convert bid) inss) term convert bid (dest, IClosure n) = (dest, IParam (n + argccount Map.! bid)) convert _ i = i -floodArgCountAll :: GFDMap -> [BB] -> Map.Map BId Int -floodArgCountAll gfds bbs = Map.unions [floodArgCount gfd bbs | gfd <- Map.elems gfds] - -floodArgCount :: GlobFuncDef -> [BB] -> Map.Map BId Int -floodArgCount (GlobFuncDef initBId nargs _) bbs = - Map.fromList [(bid, nargs) | bid <- Set.toList (reachable initBId)] +floodArgCount :: GFDMap -> [BB] -> Map.Map BId Int +floodArgCount gfds bbs = + Map.fromList [(bid, nargs) + | (name, bids) <- Map.assocs (snd $ funcBBPartition gfds bbs) + , bid <- bids + , let GlobFuncDef _ nargs _ = gfds Map.! name] + +funcBBPartition :: GFDMap -> [BB] -> ([BId], Map.Map Name [BId]) +funcBBPartition gfds bbs = + let regions = toplevelCode : map snd spreads + in if length (concat regions) /= length (nub $ concat regions) + then error "Basic blocks belong to multiple functions in Lower" + else (toplevelCode, Map.fromList spreads) where bbMap :: Map.Map BId BB bbMap = Map.fromList [(bid, bb) | bb@(BB bid _ _) <- bbs] + toplevelCode :: [BId] + toplevelCode = Set.toList (reachable 0) + + spreads :: [(Name, [BId])] + spreads = [(name, Set.toList (reachable initBId)) + | (name, GlobFuncDef initBId _ _) <- Map.assocs gfds] + reachable :: BId -> Set.Set BId reachable bid = go Set.empty [bid] where @@ -346,7 +409,7 @@ floodArgCount (GlobFuncDef initBId nargs _) bbs = in go (Set.union accum (Set.fromList front)) (Set.toList front') nexts :: BId -> [BId] - nexts bid = case let BB _ _ term = bbMap Map.! bid in term of + nexts bid = case termOf (bbMap Map.! bid) of IBr _ a b -> [a, b] IJmp a -> [a] IRet _ -> [] diff --git a/VM.hs b/VM.hs index dfa4c74..33251fe 100644 --- a/VM.hs +++ b/VM.hs @@ -78,6 +78,7 @@ vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs))) IDiscard _ -> return state IFunctionEntry -> return state + IApplicationEntry -> return state vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State) vmRunTerm info@(Info bbmap _ _) state@(State tmap _) term = case term of -- cgit v1.2.3-54-g00ecf