From 607d918e9645cb9ea101515aae003a8d1d9fe8a7 Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Mon, 22 Apr 2019 18:35:21 +0200 Subject: Initial lowering code --- Intermediate.hs | 2 +- Lower.hs | 293 +++++++++++++++++++++++++++++++++++++++++++++++++------- Main.hs | 5 +- 3 files changed, 263 insertions(+), 37 deletions(-) diff --git a/Intermediate.hs b/Intermediate.hs index c677ddd..8c07980 100644 --- a/Intermediate.hs +++ b/Intermediate.hs @@ -36,7 +36,7 @@ data InsCode | IClosure Int -- | Get i'th entry in global data table | IData Int - -- | + -- | Call the closure with the given arguments | ICallC Ref [Ref] -- | Allocate memory containing: -- - Function pointer for function with the given name diff --git a/Lower.hs b/Lower.hs index 46aaad5..34b5285 100644 --- a/Lower.hs +++ b/Lower.hs @@ -1,76 +1,299 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, MultiWayIf, GeneralizedNewtypeDeriving #-} module Lower(lowerIR) where import AST (Name) -import Data.List +import Control.Monad.State.Strict import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import Intermediate -- Not yet regalloc'd data AsmProgram' = AsmProgram' [(Label, [AsmInstr'])] + deriving (Show) data AsmInstr' - = Li Ref Int - | Mv Ref Ref - | Arith Arith Ref Ref Ref - | Not Ref Ref - | Call Ref Label - | Jcc CCond Ref Label - | JccR CCond Ref Ref - | Load Int Ref Ref - | Store Int Ref Ref + = Li ARef Int + | Mv ARef ARef + | Arith Arith ARef ARef ARef + | Not ARef ARef + | Call Label + | Jcc CCond ARef Label + | JccR CCond ARef ARef + -- Load/Store: 'Int' is number of BYTES. + | Load Int ARef ARef + | Store Int ARef ARef + -- Allocate n r: Allocate n bytes of memory, pointer in r + | Alloc Int ARef + -- Memcpy d s n: Copy n bytes from s to d + | Memcpy ARef ARef ARef + | SysExit + deriving (Show) + +data ARef + = ASysReg Int -- System register + | AReg Int -- Virtual register + | ALabel Name -- Function pointer for the label + | ASClo Name -- Static closure object of function + | ANone + deriving (Show) newtype Label = Label String + deriving (Show) data Arith = Add | Sub | Mul | Div | Lt | Lte | And | Or | Xor | Sll | Slr | Sar + deriving (Show) data CCond = CCZ | CCNZ + deriving (Show) type GFDMap = Map.Map Name GlobFuncDef type BId = Int +data LowerState = LowerState + { lsNextId :: Int } + deriving (Show) + +newtype LM a = LM {unLM :: State LowerState a} + deriving (Functor, Applicative, Monad, MonadState LowerState) + +initState :: IRProgram -> LowerState +initState (IRProgram bbs _ _) = LowerState (maxTemp + 1) + where + maxTemp = maximum (map maxTempB bbs) + maxTempB (BB _ inss term) = max (maximum (map maxTempI inss)) (maxTempT term) + maxTempI (r, ins) = max (maxTempR r) (maxTempI' ins) + maxTempI' ins = case ins of + IAssign r -> maxTempR r + IParam _ -> 0 + IClosure _ -> 0 + IData _ -> 0 + ICallC r rs -> max (maxTempR r) (maximum (map maxTempR rs)) + IAllocClo _ rs -> maximum (map maxTempR rs) + IDiscard r -> maxTempR r + maxTempT term = case term of + IBr r _ _ -> maxTempR r + IJmp _ -> 0 + IRet r -> maxTempR r + IExit -> 0 + IUnknown -> 0 + maxTempR r = case r of + RConst _ -> 0 + RTemp n -> n + RSClo _ -> 0 + RNone -> 0 + +runLM :: IRProgram -> LM a -> a +runLM initIR act = evalState (unLM act) (initState initIR) + +genId :: LM Int +genId = state $ \s -> (lsNextId s, s {lsNextId = lsNextId s + 1}) + +genTemp :: LM ARef +genTemp = liftM AReg genId + + + -- Calling convention: -- Upon function entry, the stack should look as follows: +-- - Closure item N-1 +-- ... -- - Closure item 1 --- - Closure item 2 +-- - Closure item 0 +-- - Argument M-1 -- ... --- - Closure item N -- - Argument 1 --- - Arugment 2 --- ... --- - Argument M +-- - Argument 0 -- - Link register [pushed by callee] +-- Thus, the stack pointer is at the link entry. +-- +-- A closure object is laid out as follows: +-- - Function pointer +-- - Number of closure items (N) +-- - Closure item 0 +-- - Closure item 1 +-- ... +-- - Closure item N-1 lowerIR :: IRProgram -> AsmProgram' -lowerIR (IRProgram bbs gfds datatbl) = - let argcmap = floodArgCount gfds bbs - in AsmProgram' [(Label ("BB" ++ show bid), lowerBB bb gfds argcmap) - | bb@(BB bid _ _) <- bbs] +lowerIR origProgram = + -- TODO: For each function, push and pop the link register + let res1 = closuresAreParams origProgram + IRProgram bbs gfds _ = res1 + + blocks = sequence [(lab,) <$> lowerBB bb gfds + | bb@(BB bid _ _) <- bbs + , let lab = Label ("BB" ++ show bid)] + in AsmProgram' (runLM origProgram blocks) + +lowerBB :: BB -> GFDMap -> LM [AsmInstr'] +lowerBB (BB _bid inss term) gfds = do + res1 <- concat <$> mapM (\ins -> lowerIns ins gfds) inss + res2 <- lowerTerm term + return (res1 ++ res2) + +lowerIns :: Instruction -> GFDMap -> LM [AsmInstr'] +lowerIns (dest, instruction) gfds = case instruction of + IAssign src -> do + (inss, srcr) <- toARef src + return $ inss ++ [Mv (toARefStore dest) srcr] + + IParam idx -> do + offsetr <- genTemp + return [Li offsetr (8 * (idx + 1)) + ,Arith Add offsetr offsetr (ASysReg 15) + ,Load 8 (toARefStore dest) offsetr] + + IClosure _ -> error "Unexpected IClosure, why didn't closuresAreParams run?" + + IData _ -> error "Unsupported IData in Lower" + + ICallC closure args | Just act <- lowerBuiltin closure args -> act + | otherwise -> do + (inss1, closurer) <- toARef closure + (inss2, argrs) <- toARefs args + eightr <- genTemp + numitemsr <- genTemp + numbytesr <- genTemp + stackshiftr <- genTemp + walkr <- genTemp + funptrr <- genTemp + return $ + inss1 ++ inss2 ++ + [Li eightr 8 + -- Copy the closure parameters + ,Arith Add walkr closurer eightr + ,Load 8 numitemsr walkr + ,Arith Add walkr walkr eightr + ,Arith Mul numbytesr numitemsr eightr + ,Arith Sub (ASysReg 15) (ASysReg 15) numbytesr + ,Memcpy (ASysReg 15) walkr numbytesr] ++ + -- Copy the function parameters + concat [[Arith Sub (ASysReg 15) (ASysReg 15) eightr + ,Store 8 (ASysReg 15) 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 + -- Clean up the stack + ,Li stackshiftr (8 * length argrs) + ,Arith Add stackshiftr stackshiftr numbytesr + ,Arith Add (ASysReg 15) (ASysReg 15) stackshiftr + ,Mv (toARefStore dest) (ASysReg 13)] + + IAllocClo name refs -> + let GlobFuncDef _startBId _nargs closureSlots = gfds Map.! name + in if | length refs /= length closureSlots -> + error $ "INTERNAL: Call to function '" ++ name ++ "' with " ++ + show (length refs) ++ " closure params, while it expects " ++ + show (length closureSlots) + | otherwise -> do + let destr = toARefStore dest + GlobFuncDef initBId _ _ = gfds Map.! name + itemr <- genTemp + numitemsr <- genTemp + eightr <- genTemp + (inss, refs') <- toARefs refs + return $ + inss ++ + [Alloc (16 + 8 * length refs) destr + ,Store 8 destr (ALabel ("BB" ++ show initBId)) + ,Li eightr 8 + ,Arith Add itemr destr eightr + ,Li numitemsr (length refs') + ,Store 8 itemr numitemsr] ++ + concat [[Arith Add itemr itemr eightr, Store 8 itemr ref] + | ref <- refs'] + + IDiscard _ -> return [] + +lowerTerm :: Terminator -> LM [AsmInstr'] +lowerTerm terminator = case terminator of + IBr cond tg1 tg2 -> do + (inss, condr) <- toARef cond + return $ + inss ++ + [Jcc CCNZ condr (Label ("BB" ++ show tg1)) + ,Jcc CCNZ (ASysReg 0) (Label ("BB" ++ show tg2))] + + IJmp bid -> + return [Jcc CCNZ (ASysReg 0) (Label ("BB" ++ show bid))] + + IRet val -> do + (inss, valr) <- toARef val + ptrr <- genTemp + eightr <- genTemp + return $ + inss ++ + [Mv (ASysReg 13) valr + ,Load 8 ptrr (ASysReg 15) + ,Li eightr 8 + ,Arith Add (ASysReg 15) (ASysReg 15) eightr + ,JccR CCNZ (ASysReg 0) ptrr] + + IExit -> + return [SysExit] + + IUnknown -> + error "Unexpected IUnknown" + +-- Currently useless because Compiler puts the RSClo in a temporary before +-- calling it. +lowerBuiltin :: Ref -> [Ref] -> Maybe (LM [AsmInstr']) +lowerBuiltin (RSClo "+") [arg1, arg2] = Just $ do + (inss1, r1) <- toARef arg1 + (inss2, r2) <- toARef arg2 + return $ inss1 ++ inss2 ++ [Arith Add (ASysReg 13) r1 r2] +lowerBuiltin _ _ = Nothing + +toARef :: Ref -> LM ([AsmInstr'], ARef) +toARef (RConst val) = genTemp >>= \r -> return ([Li r val], r) +toARef ref = return ([], toARefStore ref) + +toARefs :: [Ref] -> LM ([AsmInstr'], [ARef]) +toARefs refs = + foldr (\(i, r) (inss, rs) -> (i ++ inss, r : rs)) ([], []) + <$> mapM toARef refs + +toARefStore :: Ref -> ARef +toARefStore (RConst _) = error "Cannot store to a constant immediate value" +toARefStore (RTemp r) = AReg r +toARefStore (RSClo name) = ASClo name +toARefStore RNone = ANone + +closuresAreParams :: IRProgram -> IRProgram +closuresAreParams (IRProgram bbs gfds datatbl) = + IRProgram (map convertBB bbs) gfds datatbl + where + argccount = floodArgCountAll gfds bbs + + convertBB (BB bid inss term) = BB bid (map (convert bid) inss) term -lowerBB :: BB -> GFDMap -> Map.Map BId Int -> [AsmInstr'] -lowerBB (BB bid inss term) gfds argcmap = concatMap (\ins -> lowerIns ins gfds argcmap) inss + convert bid (dest, IClosure n) = (dest, IParam (n + argccount Map.! bid)) + convert _ i = i -lowerIns :: Instruction -> GFDMap -> Map.Map BId Int -> [AsmInstr'] -lowerIns (dest, instruction) gfds argcmap = case instruction of - IAssign src -> [Mv dest src] - IParam idx -> undefined +floodArgCountAll :: GFDMap -> [BB] -> Map.Map BId Int +floodArgCountAll gfds bbs = Map.unions [floodArgCount gfd bbs | gfd <- Map.elems gfds] -floodArgCount :: GFDMap -> [BB] -> Map.Map BId Int -floodArgCount gfds bbs = go Map.empty [(bid, n) | GlobFuncDef bid n _ <- Map.elems gfds] +floodArgCount :: GlobFuncDef -> [BB] -> Map.Map BId Int +floodArgCount (GlobFuncDef initBId nargs _) bbs = + Map.fromList [(bid, nargs) | bid <- Set.toList (reachable initBId)] where - bbMap :: Map.Map Int BB + bbMap :: Map.Map BId BB bbMap = Map.fromList [(bid, bb) | bb@(BB bid _ _) <- bbs] - go :: Map.Map BId Int -> [(Int, Int)] -> Map.Map BId Int - go result frontier = - let result' = foldl' (\mp (bid, n) -> Map.insert bid n mp) result frontier - frontier' = concat [map (,n) (nexts bid \\ Map.keys result') - | (bid, n) <- frontier] - in go result' frontier' + reachable :: BId -> Set.Set BId + reachable bid = go Set.empty [bid] + where + go :: Set.Set BId -> [BId] -> Set.Set BId + go accum [] = accum + go accum front = + let front' = Set.fromList (concatMap nexts front) Set.\\ accum + 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 diff --git a/Main.hs b/Main.hs index 249436c..3fc7aeb 100644 --- a/Main.hs +++ b/Main.hs @@ -4,6 +4,7 @@ import System.Environment import System.Exit import Compiler +import Lower import Optimiser import Parser import VM @@ -26,4 +27,6 @@ main = do irprog <- either die return (compileProgram prog) let opt = optimise irprog print opt - vmRun opt + -- vmRun opt + let asmprog = lowerIR opt + print asmprog -- cgit v1.2.3-54-g00ecf