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.

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