[Git][ghc/ghc][wip/supersven/riscv-ncg] Implement simple C call
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Wed Apr 26 17:00:15 UTC 2023
Sven Tennie pushed to branch wip/supersven/riscv-ncg at Glasgow Haskell Compiler / GHC
Commits:
4481208a by Sven Tennie at 2023-04-26T16:59:48+00:00
Implement simple C call
- - - - -
3 changed files:
- compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RISCV64/Instr.hs
- compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
Changes:
=====================================
compiler/GHC/CmmToAsm/RISCV64/CodeGen.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.Platform.Regs
import GHC.Utils.Panic
import GHC.Cmm.BlockId
import GHC.Utils.Trace
+import Debug.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.
@@ -226,6 +227,7 @@ 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
@@ -251,9 +253,10 @@ genCCall target dest_regs arg_regs = do
(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)
+ e -> trace ("genCCall - target : " ++ show e ++ " - " ++ showPprUnsafe (pdoc platform 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
@@ -287,15 +290,20 @@ genCCall target dest_regs arg_regs = do
-- , 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
+ traceM $ "genCCall - call_target : " ++ show call_target
+
+ let code = call_target_code -- compute the label (possibly into a register)
+ `appOL` passArgumentsCode -- put the arguments into a0, ...
+ `appOL` mkCall 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
+ mkCall :: Target -> OrdList Instr
+ mkCall (TLabel label) = unitOL $ CALL label
+ mkCall (TReg reg) = unitOL $ JALR reg
+ mkCall t = error $ "mkCall - " ++ show t
+
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
=====================================
compiler/GHC/CmmToAsm/RISCV64/Instr.hs
=====================================
@@ -42,6 +42,9 @@ data Instr
LA Reg CLabel
| -- jump pseudo-instruction
J Target
+ | -- call pseudo-instruction
+ CALL CLabel
+ | JALR Reg
| -- copy register
MV Reg Reg
@@ -49,6 +52,7 @@ data Target
= TBlock BlockId
| TReg Reg
| TLabel CLabel
+ deriving Show
allocMoreStack ::
Int ->
@@ -104,6 +108,8 @@ regUsageOfInstr platform instr = case instr of
-- Looks like J doesn't change registers (beside PC)
-- This might be wrong.
J {} -> none
+ CALL {} -> usage([],[(RegReal . realRegSingle) 1]) -- call sets register x1 (ra)
+ JALR reg -> usage([reg],[(RegReal . realRegSingle) 1]) -- call sets register x1 (ra)
where
none = usage ([], [])
-- filtering the usage is necessary, otherwise the register
@@ -138,6 +144,8 @@ patchRegsOfInstr instr env = case instr of
-- Looks like J doesn't change registers (beside PC)
-- This might be wrong.
J {} -> instr
+ CALL {} -> instr
+ JALR reg -> JALR (env reg)
MV dst src -> MV (env dst) (env src)
-- | Checks whether this instruction is a jump/branch instruction.
@@ -150,8 +158,12 @@ isJumpishInstr ANN {} = False
isJumpishInstr DELTA {} = False
isJumpishInstr LDATA {} = False
isJumpishInstr NEWBLOCK {} = False
+isJumpishInstr MV {} = False
+isJumpishInstr LA {} = False
isJumpishInstr LI {} = False
isJumpishInstr J {} = True
+isJumpishInstr CALL {} = True
+isJumpishInstr JALR {} = True
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
@@ -224,6 +236,8 @@ isMetaInstr instr =
LA {} -> False
J {} -> False
MV {} -> False
+ CALL {} -> False
+ JALR {} -> False
-- | Copy the value in a register to another one.
-- Must work for all register classes.
@@ -251,6 +265,8 @@ takeRegRegMoveInstr LI {} = Nothing
takeRegRegMoveInstr LA {} = Nothing
takeRegRegMoveInstr J {} = Nothing
takeRegRegMoveInstr (MV dst src) = Just (src, dst)
+takeRegRegMoveInstr CALL {} = Nothing
+takeRegRegMoveInstr JALR {} = Nothing
-- | Make an unconditional jump instruction.
-- For architectures with branch delay slots, its ok to put
=====================================
compiler/GHC/CmmToAsm/RISCV64/Ppr.hs
=====================================
@@ -142,9 +142,11 @@ pprInstr platform instr = case instr of
PUSH_STACK_FRAME -> error "pprInstr: PUSH_STACK_FRAME"
POP_STACK_FRAME -> error "pprInstr: POP_STACK_FRAME"
J label -> line $ pprJ label
+ CALL label -> line $ text "\tcall" <+> pprAsmLabel platform label
+ JALR reg -> line $ text "\tjalr" <+> text "ra" <> char ',' <+> pprReg reg <> char ',' <+> char '0'
LI reg immediate -> line $ pprLI reg immediate
- LA reg label -> error $ "pprInstr: LA " ++ show reg ++ " " ++ show label
- MV dst src -> error $ "pprInstr: MV " ++ show dst ++ " " ++ show src
+ LA reg label -> line $ text "\tla" <+> pprReg reg <> char ',' <+> pprAsmLabel platform label
+ MV dst src -> line $ text "\tmv" <+> pprReg dst <> char ',' <+> pprReg src
where
pprLI :: IsLine doc => Reg -> Integer -> doc
pprLI reg immediate = text "\tli" <+> pprReg reg <> char ',' <+> (text.show) immediate
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4481208a93ddfe0a1d7ba979aff80928b2955354
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4481208a93ddfe0a1d7ba979aff80928b2955354
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/20230426/9e41b608/attachment-0001.html>
More information about the ghc-commits
mailing list