Begin to implement c calling convention

5 files changed, 215 insertions, 63 deletions

diff --git a/compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs b/compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
index 2234ab6fda..3aa2a6c6f7 100644
--- a/compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
@@ -4,7 +4,7 @@ module GHC.CmmToAsm.RISCV64.CodeGen where
 import GHC.CmmToAsm.Types
 import GHC.CmmToAsm.Monad
 import GHC.CmmToAsm.RISCV64.Instr
-import Prelude
+import Prelude hiding ((<>))
 import GHC.Cmm
 import GHC.Cmm.Utils
 import Control.Monad
@@ -22,6 +22,7 @@ import GHC.CmmToAsm.RISCV64.Regs
 import GHC.Platform.Regs
 import GHC.Utils.Panic
 import GHC.Cmm.BlockId
+import GHC.Utils.Trace
 
 -- | Don't try to compile all GHC Cmm files in the beginning.
 -- Ignore them. There's a flag to decide we really want to emit something.
@@ -94,6 +95,8 @@ stmtToInstrs :: CmmNode e x -> NatM InstrBlock
 stmtToInstrs stmt = do
   platform <- getPlatform
   case stmt of
+    CmmUnsafeForeignCall target result_regs args
+       -> genCCall target result_regs args
     CmmComment s   -> return (unitOL (COMMENT (ftext s)))
     -- TODO: Maybe, it would be nice to see the tick comment in assembly?
     CmmTick {}     -> return nilOL
@@ -129,6 +132,21 @@ getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _))
         Just reg -> RegReal reg
         Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg)
 
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- | The dual to getAnyReg: compute an expression into a register, but
+--      we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, rep, code tmp)
+    Fixed rep reg code ->
+        return (reg, rep, code)
+
 getRegister :: CmmExpr -> NatM Register
 getRegister e = do
   config <- getConfig
@@ -140,13 +158,20 @@ getRegister' config plat expr
   = case expr of
     CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))
       -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg)
+    CmmReg reg
+      -> return (Fixed (cmmTypeFormat (cmmRegType reg))
+                       (getRegisterReg plat reg)
+                       nilOL)
     CmmLit lit
       -> case lit of
-        CmmInt i W64 -> do
-          return (Any (intFormat W64) (\dst -> unitOL $ annExpr expr (LI dst i)))
+        CmmInt i W64 ->
+          return (Any II64 (\dst -> unitOL $ annExpr expr (LI dst i)))
         CmmInt i w -> error ("TODO: getRegister' CmmInt " ++ show i ++ show w ++ " " ++show expr)
+        CmmLabel lbl ->
+          return (Any II64 (\dst -> unitOL $ annExpr expr (LA dst lbl)))
         e -> error ("TODO: getRegister' other " ++ show e)
-    e -> error ("TODO: getRegister'" ++ show e)
+    CmmRegOff reg off -> error $ "TODO: getRegister' : " ++ show reg ++ " , " ++ show off
+    e -> error ("TODO: getRegister' " ++ show e ++ " -- " ++ showPprUnsafe (pdoc plat e))
 
 -- -----------------------------------------------------------------------------
 -- Jumps
@@ -201,3 +226,88 @@ annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr
 generateJumpTableForInstr :: Instr
                           -> Maybe (NatCmmDecl RawCmmStatics Instr)
 generateJumpTableForInstr _ = Nothing
+genCCall
+    :: ForeignTarget      -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
+    -> NatM InstrBlock
+-- TODO: Specialize where we can.
+-- Generic impl
+genCCall target dest_regs arg_regs = do
+  -- we want to pass arg_regs into allArgRegs
+  -- pprTraceM "genCCall target" (ppr target)
+  -- pprTraceM "genCCall formal" (ppr dest_regs)
+  -- pprTraceM "genCCall actual" (ppr arg_regs)
+
+  platform <- getPlatform
+  case target of
+    -- The target :: ForeignTarget call can either
+    -- be a foreign procedure with an address expr
+    -- and a calling convention.
+    ForeignTarget expr _cconv -> do
+      (call_target, call_target_code) <- case expr of
+        -- if this is a label, let's just directly to it.  This will produce the
+        -- correct CALL relocation for BL...
+        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
+        -- ... if it's not a label--well--let's compute the expression into a
+        -- register and jump to that. See Note [PLT vs GOT relocations]
+        e ->  do
+          (reg, _format, reg_code) <- getSomeReg expr
+          pure (TReg reg, reg_code)
+      -- compute the code and register logic for all arg_regs.
+      -- this will give us the format information to match on.
+      arg_regs' <- mapM getSomeReg arg_regs
+
+      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes
+      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
+      -- STG; this thenn breaks packing of stack arguments, if we need to pack
+      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type
+      -- in Cmm proper. Option two, which we choose here is to use extended Hint
+      -- information to contain the size information and use that when packing
+      -- arguments, spilled onto the stack.
+      let (_res_hints, arg_hints) = foreignTargetHints target
+          arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
+
+      (stackSpace, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
+
+      (returnRegs, readResultsCode) <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
+
+      let moveStackDown 0 = toOL [ PUSH_STACK_FRAME
+                                 , DELTA (-16) ]
+          moveStackDown i = error $ "TODO: moveStackDown " ++ show i
+--          moveStackDown i | odd i = moveStackDown (i + 1)
+--          moveStackDown i = toOL [ PUSH_STACK_FRAME
+--                                 , SUB (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))
+--                                 , DELTA (-8 * i - 16) ]
+          moveStackUp 0 = toOL [ POP_STACK_FRAME
+                               , DELTA 0 ]
+          moveStackUp i = error $ "TODO: moveStackUp " ++ show i
+--          moveStackUp i | odd i = moveStackUp (i + 1)
+--          moveStackUp i = toOL [ ADD (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))
+--                               , POP_STACK_FRAME
+--                               , DELTA 0 ]
+
+      let code =    call_target_code          -- compute the label (possibly into a register)
+            `appOL` moveStackDown (stackSpace `div` 8)
+            `appOL` passArgumentsCode         -- put the arguments into x0, ...
+            `appOL` (unitOL $ J call_target) -- jump
+            `appOL` readResultsCode           -- parse the results into registers
+            `appOL` moveStackUp (stackSpace `div` 8)
+      return code
+    e -> error $ "TODO genCCall" ++ showSDocUnsafe (pdoc platform e)
+  where
+    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
+    passArguments _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode)
+    passArguments (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
+      let w = formatToWidth format
+          mov = MV gpReg r
+          accumCode' = accumCode `appOL`
+                       code_r `snocOL`
+                       ann (text "Pass gp argument: " <> ppr r) mov
+      passArguments gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'
+    passArguments _ _ _ _ _ _ = error $ "TODO: passArguments"
+
+
+    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock)
+    readResults _ _ [] accumRegs accumCode = return (accumRegs, accumCode)
+    readResults _ _ _ _ _ = error $ "TODO: readResults"
diff --git a/compiler/GHC/CmmToAsm/RISCV64/Instr.hs b/compiler/GHC/CmmToAsm/RISCV64/Instr.hs
index 5ade3b5c61..8e53f429c3 100644
--- a/compiler/GHC/CmmToAsm/RISCV64/Instr.hs
+++ b/compiler/GHC/CmmToAsm/RISCV64/Instr.hs
@@ -1,19 +1,20 @@
 {-# LANGUAGE EmptyCase #-}
+
 module GHC.CmmToAsm.RISCV64.Instr where
 
 import GHC.Cmm
 import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
 import GHC.Cmm.Dataflow.Label
 import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Instr hiding (patchRegsOfInstr, takeDeltaInstr, regUsageOfInstr, isMetaInstr, jumpDestsOfInstr)
+import GHC.CmmToAsm.Instr hiding (isMetaInstr, jumpDestsOfInstr, patchRegsOfInstr, regUsageOfInstr, takeDeltaInstr)
 import GHC.CmmToAsm.Types
 import GHC.Platform
 import GHC.Platform.Reg
+import GHC.Platform.Regs (freeReg)
 import GHC.Types.Unique.Supply
 import GHC.Utils.Outputable
 import Prelude
-import GHC.Platform.Regs (freeReg)
-import GHC.Cmm.CLabel
 
 data Instr
   = -- comment pseudo-op
@@ -21,10 +22,11 @@ data Instr
   | MULTILINE_COMMENT SDoc
   | -- Annotated instruction. Should print <instr> # <doc>
     ANN SDoc Instr
-    -- specify current stack offset for
+  | -- specify current stack offset for
     -- benefit of subsequent passes
-  | DELTA   Int
-
+    DELTA Int
+  | PUSH_STACK_FRAME
+  | POP_STACK_FRAME
   | -- some static data spat out during code
     -- generation.  Will be extracted before
     -- pretty-printing.
@@ -36,12 +38,17 @@ data Instr
     NEWBLOCK BlockId
   | -- load immediate pseudo-instruction
     LI Reg Integer
+  | -- load address (label)
+    LA Reg CLabel
   | -- jump pseudo-instruction
     J Target
+  | -- copy register
+    MV Reg Reg
 
 data Target
-    = TBlock BlockId
-    | TLabel CLabel
+  = TBlock BlockId
+  | TReg Reg
+  | TLabel CLabel
 
 allocMoreStack ::
   Int ->
@@ -60,10 +67,12 @@ spillSlotSize = 8
 
 -- | The number of spill slots available without allocating more.
 maxSpillSlots :: NCGConfig -> Int
-maxSpillSlots config
---  = 0 -- set to zero, to see when allocMoreStack has to fire.
-    = ((ncgSpillPreallocSize config - stackFrameHeaderSize)
-         `div` spillSlotSize) - 1
+maxSpillSlots config =
+  --  = 0 -- set to zero, to see when allocMoreStack has to fire.
+  ( (ncgSpillPreallocSize config - stackFrameHeaderSize)
+      `div` spillSlotSize
+  )
+    - 1
 
 makeFarBranches ::
   LabelMap RawCmmStatics ->
@@ -81,27 +90,33 @@ regUsageOfInstr ::
   Instr ->
   RegUsage
 regUsageOfInstr platform instr = case instr of
-    ANN _ i                  -> regUsageOfInstr platform i
-    COMMENT{}                -> usage ([], [])
-    MULTILINE_COMMENT{}      -> usage ([], [])
-    LDATA{}                  -> usage ([], [])
-    DELTA{}                  -> usage ([], [])
-    NEWBLOCK{}               -> usage ([], [])
-    LI reg _                 -> usage ([], [reg])
-    -- Looks like J doesn't change registers (beside PC)
-    -- This might be wrong.
-    J{}                      -> usage ([], [])
+  ANN _ i -> regUsageOfInstr platform i
+  COMMENT {} -> none
+  MULTILINE_COMMENT {} -> none
+  LDATA {} -> none
+  DELTA {} -> none
+  NEWBLOCK {} -> none
+  PUSH_STACK_FRAME -> none
+  POP_STACK_FRAME -> none
+  LI dst _ -> usage ([], [dst])
+  LA dst _ -> usage ([], [dst])
+  MV dst src -> usage ([src], [dst])
+  -- Looks like J doesn't change registers (beside PC)
+  -- This might be wrong.
+  J {} -> none
   where
-        -- filtering the usage is necessary, otherwise the register
-        -- allocator will try to allocate pre-defined fixed stg
-        -- registers as well, as they show up.
-        usage (src, dst) = RU (filter (interesting platform) src)
-                              (filter (interesting platform) dst)
-
-        interesting :: Platform -> Reg -> Bool
-        interesting _        (RegVirtual _)              = True
-        interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+    none = usage ([], [])
+    -- filtering the usage is necessary, otherwise the register
+    -- allocator will try to allocate pre-defined fixed stg
+    -- registers as well, as they show up.
+    usage (src, dst) =
+      RU
+        (filter (interesting platform) src)
+        (filter (interesting platform) dst)
 
+    interesting :: Platform -> Reg -> Bool
+    interesting _ (RegVirtual _) = True
+    interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
 
 -- | Apply a given mapping to all the register references in this
 --      instruction.
@@ -110,22 +125,25 @@ patchRegsOfInstr ::
   (Reg -> Reg) ->
   Instr
 patchRegsOfInstr instr env = case instr of
-    ANN _ i                  -> patchRegsOfInstr i env
-    COMMENT{}                -> instr
-    MULTILINE_COMMENT{}      -> instr
-    LDATA{}                  -> instr
-    DELTA{}                  -> instr
-    NEWBLOCK{}               -> instr
-    LI reg i                 -> LI (env reg) i
-    -- Looks like J doesn't change registers (beside PC)
-    -- This might be wrong.
-    J{}                      -> instr
-
+  ANN _ i -> patchRegsOfInstr i env
+  COMMENT {} -> instr
+  MULTILINE_COMMENT {} -> instr
+  LDATA {} -> instr
+  DELTA {} -> instr
+  NEWBLOCK {} -> instr
+  PUSH_STACK_FRAME {} -> instr
+  POP_STACK_FRAME {} -> instr
+  LI reg i -> LI (env reg) i
+  LA reg i -> LA (env reg) i
+  -- Looks like J doesn't change registers (beside PC)
+  -- This might be wrong.
+  J {} -> instr
+  MV dst src -> MV (env dst) (env src)
 
 -- | Checks whether this instruction is a jump/branch instruction.
 --      One that can change the flow of control in a way that the
 --      register allocator needs to worry about.
-isJumpishInstr ::  Instr -> Bool
+isJumpishInstr :: Instr -> Bool
 isJumpishInstr COMMENT {} = False
 isJumpishInstr MULTILINE_COMMENT {} = False
 isJumpishInstr ANN {} = False
@@ -135,7 +153,6 @@ isJumpishInstr NEWBLOCK {} = False
 isJumpishInstr LI {} = False
 isJumpishInstr J {} = True
 
-
 -- | Checks whether this instruction is a jump/branch instruction.
 -- One that can change the flow of control in a way that the
 -- register allocator needs to worry about.
@@ -183,8 +200,7 @@ mkLoadInstr _ _ _ _ = error "TODO: mkLoadInstr"
 takeDeltaInstr :: Instr -> Maybe Int
 takeDeltaInstr (ANN _ i) = takeDeltaInstr i
 takeDeltaInstr (DELTA i) = Just i
-takeDeltaInstr _         = Nothing
-
+takeDeltaInstr _ = Nothing
 
 -- | Check whether this instruction is some meta thing inserted into
 --      the instruction stream for other purposes.
@@ -194,16 +210,20 @@ takeDeltaInstr _         = Nothing
 --
 --      eg, comments, delta, ldata, etc.
 isMetaInstr :: Instr -> Bool
-isMetaInstr instr
- = case instr of
-    ANN _ i     -> isMetaInstr i
-    COMMENT{}   -> True
-    MULTILINE_COMMENT{} -> True
-    LDATA{}     -> True
-    NEWBLOCK{}  -> True
-    LI{}        -> False
-    J{}        -> False
-
+isMetaInstr instr =
+  case instr of
+    ANN _ i -> isMetaInstr i
+    COMMENT {} -> True
+    MULTILINE_COMMENT {} -> True
+    LDATA {} -> True
+    NEWBLOCK {} -> True
+    DELTA {} -> True
+    PUSH_STACK_FRAME -> True
+    POP_STACK_FRAME -> True
+    LI {} -> False
+    LA {} -> False
+    J {} -> False
+    MV {} -> False
 
 -- | Copy the value in a register to another one.
 --      Must work for all register classes.
@@ -225,8 +245,12 @@ takeRegRegMoveInstr ANN {} = Nothing
 takeRegRegMoveInstr DELTA {} = Nothing
 takeRegRegMoveInstr LDATA {} = Nothing
 takeRegRegMoveInstr NEWBLOCK {} = Nothing
+takeRegRegMoveInstr PUSH_STACK_FRAME {} = Nothing
+takeRegRegMoveInstr POP_STACK_FRAME {} = Nothing
 takeRegRegMoveInstr LI {} = Nothing
+takeRegRegMoveInstr LA {} = Nothing
 takeRegRegMoveInstr J {} = Nothing
+takeRegRegMoveInstr (MV dst src) = Just (src, dst)
 
 -- | Make an unconditional jump instruction.
 --      For architectures with branch delay slots, its ok to put
diff --git a/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs b/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
index f42f44ea46..4bed676801 100644
--- a/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
@@ -21,8 +21,8 @@ import GHC.Utils.Panic
 import GHC.Types.Unique
 
 pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
-pprNatCmmDecl config (CmmData _ _) = error "TODO: pprNatCmmDecl "
-
+pprNatCmmDecl config (CmmData section dats) =
+  pprSectionAlign config section $$ pprDatas config dats
 pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
   let platform = ncgPlatform config
    in pprProcAlignment config
@@ -116,6 +116,18 @@ pprBasicBlock config info_env (BasicBlock blockid instrs) =
       Nothing -> c
       Just (CmmStaticsRaw info_lbl info) -> error "pprBasicBlock"
 
+pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc
+-- TODO: Adhere to Note [emit-time elimination of static indirections]
+-- See AArch64/Ppr.hs
+pprDatas config (CmmStaticsRaw lbl dats)
+  = vcat (pprLabel platform lbl : map (pprData config) dats)
+   where
+      platform = ncgPlatform config
+
+pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc
+pprData _config (CmmString str) = line (pprString str)
+pprData _ _ = error $ "TODO: pprData"
+
 pprInstr :: IsDoc doc => Platform -> Instr -> doc
 pprInstr platform instr = case instr of
   -- Meta Instructions ---------------------------------------------------------
diff --git a/compiler/GHC/CmmToAsm/RISCV64/Regs.hs b/compiler/GHC/CmmToAsm/RISCV64/Regs.hs
index c817610a9b..4996991347 100644
--- a/compiler/GHC/CmmToAsm/RISCV64/Regs.hs
+++ b/compiler/GHC/CmmToAsm/RISCV64/Regs.hs
@@ -10,6 +10,12 @@ import GHC.Platform.Regs
 allMachRegNos   :: [RegNo]
 allMachRegNos   = [1..31] ++ [32..63]
 
+-- argRegs is the set of regs which are read for an n-argument call to C.
+allGpArgRegs :: [Reg]
+allGpArgRegs = map regSingle [10..17] -- a0..a7
+allFpArgRegs :: [Reg]
+allFpArgRegs = map regSingle [42..49] -- fa0..fa7
+
 -- allocatableRegs is allMachRegNos with the fixed-use regs removed.
 -- i.e., these are the regs for which we are prepared to allow the
 -- register allocator to attempt to map VRegs to.
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/RISCV64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/RISCV64.hs
index 205eaac252..66e4d1f46a 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/RISCV64.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Linear/RISCV64.hs
@@ -64,6 +64,6 @@ initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs pla
 releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
 releaseReg (RealRegSingle r) (FreeRegs g f)
   | r > 31 && testBit f (r - 32) = pprPanic "Linear.RISCV64.releaseReg" (text  "can't release non-allocated reg v" <> int (r - 32))
-  | r < 32 && testBit g r = pprPanic "Linear.RISCV64.releaseReg" (text "can't release non-allocated reg x" <> int r)
+  | r < 32 && testBit g r = pprPanic "Linear.RISCV64.releaseReg" (text "can't release non-allocated reg x" <> int r <+> text (showBits g))
   | r > 31 = FreeRegs g (setBit f (r - 32))
   | otherwise = FreeRegs (setBit g r) f