[Git][ghc/ghc][wip/supersven/riscv-ncg] Begin to implement c calling convention
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Apr 23 17:41:33 UTC 2023
Sven Tennie pushed to branch wip/supersven/riscv-ncg at Glasgow Haskell Compiler / GHC
Commits:
fef76fa5 by Sven Tennie at 2023-04-23T17:40:39+00:00
Begin to implement c calling convention
- - - - -
5 changed files:
- compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RISCV64/Instr.hs
- compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
- compiler/GHC/CmmToAsm/RISCV64/Regs.hs
- compiler/GHC/CmmToAsm/Reg/Linear/RISCV64.hs
Changes:
=====================================
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"
=====================================
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
=====================================
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 ---------------------------------------------------------
=====================================
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.
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fef76fa57edb5f6e6929e457a1834c092ffd8004
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fef76fa57edb5f6e6929e457a1834c092ffd8004
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230423/40a9a46e/attachment-0001.html>
More information about the ghc-commits
mailing list