Lower to isa WIP

7 files changed, 105 insertions, 7 deletions

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