From d37b2cfec1cfcbc3b6cfcedc88a9c6775312f8eb Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Thu, 18 Apr 2019 23:24:56 +0200 Subject: Lower to isa WIP --- Compiler.hs | 6 +++-- Intermediate.hs | 9 +++++++ Lower.hs | 81 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Main.hs | 2 +- VM.hs | 1 - lisphs.cabal | 9 ++++++- stack.yaml | 4 +-- 7 files changed, 105 insertions(+), 7 deletions(-) create mode 100644 Lower.hs diff --git a/Compiler.hs b/Compiler.hs index 2e3b80b..8c32236 100644 --- a/Compiler.hs +++ b/Compiler.hs @@ -6,7 +6,6 @@ import Control.Monad.State.Strict import Data.List import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import Debug.Trace import AST import Intermediate @@ -160,7 +159,10 @@ compileProgram (Program values) = runCM $ do switchBlock bnext addIns (RNone, IDiscard ref) setTerm IExit - ([firstbb], otherbbs) <- liftM (partition ((== bstart) . bbId) . Map.elems) (gets csBlocks) + (bbs, otherbbs) <- liftM (partition ((== bstart) . bbId) . Map.elems) (gets csBlocks) + let firstbb = case bbs of + [bb] -> bb + _ -> error "Multiple bb's with the same ID!" funcs <- gets csFunctions datas <- gets csDatas return (IRProgram (firstbb : otherbbs) funcs datas) diff --git a/Intermediate.hs b/Intermediate.hs index c72e81c..c677ddd 100644 --- a/Intermediate.hs +++ b/Intermediate.hs @@ -28,12 +28,21 @@ data Ref deriving Eq data InsCode + -- | Get value of the ref = IAssign Ref + -- | Get i'th parameter to current function | IParam Int + -- | Get i'th closure entry for current function | IClosure Int + -- | Get i'th entry in global data table | IData Int + -- | | ICallC Ref [Ref] + -- | Allocate memory containing: + -- - Function pointer for function with the given name + -- - The values of each of the references | IAllocClo Name [Ref] + -- | Do nothing? | IDiscard Ref deriving Eq diff --git a/Lower.hs b/Lower.hs new file mode 100644 index 0000000..46aaad5 --- /dev/null +++ b/Lower.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TupleSections #-} +module Lower(lowerIR) where + +import AST (Name) +import Data.List +import qualified Data.Map.Strict as Map +import Intermediate + + +-- Not yet regalloc'd +data AsmProgram' = AsmProgram' [(Label, [AsmInstr'])] + +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 + +newtype Label = Label String + +data Arith = Add | Sub | Mul | Div | Lt | Lte | And | Or | Xor | Sll | Slr | Sar + +data CCond = CCZ | CCNZ + +type GFDMap = Map.Map Name GlobFuncDef + +type BId = Int + + +-- Calling convention: +-- Upon function entry, the stack should look as follows: +-- - Closure item 1 +-- - Closure item 2 +-- ... +-- - Closure item N +-- - Argument 1 +-- - Arugment 2 +-- ... +-- - Argument M +-- - Link register [pushed by callee] + + +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] + +lowerBB :: BB -> GFDMap -> Map.Map BId Int -> [AsmInstr'] +lowerBB (BB bid inss term) gfds argcmap = concatMap (\ins -> lowerIns ins gfds argcmap) inss + +lowerIns :: Instruction -> GFDMap -> Map.Map BId Int -> [AsmInstr'] +lowerIns (dest, instruction) gfds argcmap = case instruction of + IAssign src -> [Mv dest src] + IParam idx -> undefined + +floodArgCount :: GFDMap -> [BB] -> Map.Map BId Int +floodArgCount gfds bbs = go Map.empty [(bid, n) | GlobFuncDef bid n _ <- Map.elems gfds] + where + bbMap :: Map.Map Int 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' + + nexts :: BId -> [BId] + nexts bid = case let BB _ _ term = bbMap Map.! bid in term of + IBr _ a b -> [a, b] + IJmp a -> [a] + IRet _ -> [] + IExit -> [] + IUnknown -> [] diff --git a/Main.hs b/Main.hs index b56edfe..249436c 100644 --- a/Main.hs +++ b/Main.hs @@ -25,5 +25,5 @@ main = do prog <- parseProgram source >>= either (die . show) return irprog <- either die return (compileProgram prog) let opt = optimise irprog - -- print opt + print opt vmRun opt diff --git a/VM.hs b/VM.hs index b3b19e4..4b0a1e0 100644 --- a/VM.hs +++ b/VM.hs @@ -7,7 +7,6 @@ import qualified Data.Map.Strict as Map import Data.Map.Strict ((!)) import System.IO import qualified System.IO.Error as IO -import Debug.Trace import AST import Intermediate diff --git a/lisphs.cabal b/lisphs.cabal index 89ee3c4..c608571 100644 --- a/lisphs.cabal +++ b/lisphs.cabal @@ -13,4 +13,11 @@ executable lisp ghc-options: -Wall -O2 build-depends: base >= 4 && < 5, containers, mtl, parsec - other-modules: AST, Compiler, Intermediate, Optimiser, Parser, VM + other-modules: + AST + Compiler + Intermediate + Lower + Optimiser + Parser + VM diff --git a/stack.yaml b/stack.yaml index 5fd7976..95f0e91 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,7 +15,7 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-11.2 +resolver: lts-13.8 # User packages to be built. # Various formats can be used as shown in the example below. @@ -63,4 +63,4 @@ packages: # extra-lib-dirs: [/path/to/dir] # # Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file +# compiler-check: newer-minor -- cgit v1.2.3-54-g00ecf