diff options
author | Ian Lynagh <igloo@earth.li> | 2012-02-14 21:26:18 +0000 |
---|---|---|
committer | Ian Lynagh <igloo@earth.li> | 2012-02-14 23:08:26 +0000 |
commit | 7bfb7bfc6da981ef827b1a166c8cbfb5b29a25a4 (patch) | |
tree | 64f62969824858ce141d89bc52ffc7e71ed236f9 | |
parent | 8c0196b48d043fe16eb5b2d343f5544b7fdd5004 (diff) | |
download | haskell-7bfb7bfc6da981ef827b1a166c8cbfb5b29a25a4.tar.gz |
Define a quotRem CallishMachOp; fixes #5598
This means we no longer do a division twice when we are using quotRem
(on platforms on which the op is supported; currently only amd64).
-rw-r--r-- | compiler/cmm/CmmMachOp.hs | 5 | ||||
-rw-r--r-- | compiler/cmm/OldCmmUtils.hs | 11 | ||||
-rw-r--r-- | compiler/cmm/PprC.hs | 10 | ||||
-rw-r--r-- | compiler/codeGen/CgPrimOp.hs | 9 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
-rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 15 | ||||
-rw-r--r-- | compiler/nativeGen/PPC/CodeGen.hs | 14 | ||||
-rw-r--r-- | compiler/nativeGen/SPARC/CodeGen.hs | 499 | ||||
-rw-r--r-- | compiler/nativeGen/SPARC/CodeGen/CCall.hs | 343 | ||||
-rw-r--r-- | compiler/nativeGen/X86/CodeGen.hs | 31 | ||||
-rw-r--r-- | compiler/prelude/primops.txt.pp | 5 |
11 files changed, 495 insertions, 448 deletions
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 2effa3a45f..967f3289ff 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -439,9 +439,12 @@ data CallishMachOp | MO_F32_Log | MO_F32_Exp | MO_F32_Sqrt + + | MO_S_QuotRem Width + | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) - + -- Note that these three MachOps all take 1 extra parameter than the -- standard C lib versions. The extra (last) parameter contains -- alignment of the pointers. Used for optimisation in backends. diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index 14a17d7946..3fc6fd441a 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -12,6 +12,8 @@ module OldCmmUtils( maybeAssignTemp, loadArgsIntoTemps, + expandCallishMachOp, + module CmmUtils, ) where @@ -96,3 +98,12 @@ maybeAssignTemp uniques e | hasNoGlobalRegs e = (uniques, [], e) | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) + +expandCallishMachOp :: CallishMachOp -> [HintedCmmFormal] -> [HintedCmmActual] + -> Maybe [CmmStmt] +expandCallishMachOp (MO_S_QuotRem width) [CmmHinted res_q _, CmmHinted res_r _] args + = Just [CmmAssign (CmmLocal res_q) (CmmMachOp (MO_S_Quot width) args'), + CmmAssign (CmmLocal res_r) (CmmMachOp (MO_S_Rem width) args')] + where args' = map hintlessCmm args +expandCallishMachOp _ _ _ = Nothing + diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 658e3ca5d8..d636c41997 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -28,6 +28,7 @@ import BlockId import CLabel import ForeignCall import OldCmm +import OldCmmUtils import OldPprCmm () -- Utils @@ -237,6 +238,10 @@ pprStmt platform stmt = case stmt of pprCall platform cast_fn cconv results args <> semi) -- for a dynamic call, no declaration is necessary. + CmmCall (CmmPrim op) results args _ret + | Just stmts <- expandCallishMachOp op results args -> + vcat $ map (pprStmt platform) stmts + CmmCall (CmmPrim op) results args _ret -> pprCall platform ppr_fn CCallConv results args' where @@ -658,7 +663,10 @@ pprCallishMachOp_for_C mop MO_Memmove -> ptext (sLit "memmove") (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) - MO_Touch -> panic $ "pprCallishMachOp_for_C: MO_Touch not supported!" + MO_S_QuotRem {} -> unsupported + MO_Touch -> unsupported + where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop + ++ " not supported!") -- --------------------------------------------------------------------- -- Useful #defines diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index b0865d69d9..f169c0ce38 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -440,6 +440,15 @@ emitPrimOp [res] op args live = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt +emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ + = let stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt + emitPrimOp _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 3bb2f5cfc4..a9b85da5c0 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -527,7 +527,6 @@ Library SPARC.CodeGen SPARC.CodeGen.Amode SPARC.CodeGen.Base - SPARC.CodeGen.CCall SPARC.CodeGen.CondCode SPARC.CodeGen.Gen32 SPARC.CodeGen.Gen64 diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 059328f868..98fb8eb4e8 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -15,6 +15,7 @@ import BlockId import CgUtils ( activeStgRegs, callerSaves ) import CLabel import OldCmm +import OldCmmUtils import qualified OldPprCmm as PprCmm import DynFlags @@ -222,6 +223,10 @@ genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || `appOL` trashStmts `snocOL` call return (env2, stmts, top1 ++ top2) +genCall env (CmmPrim op) results args _ + | Just stmts <- expandCallishMachOp op results args + = stmtsToInstrs env stmts (nilOL, []) + -- Handle all other foreign calls and prim ops. genCall env target res args ret = do @@ -469,17 +474,17 @@ cmmPrimOpFunctions env mop (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w) - MO_WriteBarrier -> - panic $ "cmmPrimOpFunctions: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "cmmPrimOpFunctions: MO_Touch not supported here" + MO_S_QuotRem {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported where intrinTy1 = (if getLlvmVer env >= 28 then "p0i8.p0i8." else "") ++ show llvmWord intrinTy2 = (if getLlvmVer env >= 28 then "p0i8." else "") ++ show llvmWord - + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") -- | Tail function calls genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 7b704cbe8f..db97a8cc97 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -42,6 +42,7 @@ import Platform import BlockId import PprCmm ( pprExpr ) import OldCmm +import OldCmmUtils import CLabel -- The rest: @@ -901,6 +902,10 @@ genCCall' genCCall' _ (CmmPrim MO_WriteBarrier) _ _ = return $ unitOL LWSYNC +genCCall' _ (CmmPrim op) results args + | Just stmts <- expandCallishMachOp op results args + = stmtsToInstrs stmts + genCCall' gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen @@ -1142,10 +1147,11 @@ genCCall' gcp target dest_regs argsAndHints MO_PopCnt w -> (fsLit $ popCntLabel w, False) - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported" + MO_S_QuotRem {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported") -- ----------------------------------------------------------------------------- -- Generating a table-branch diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 4c295f11d5..f8e71f4aef 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -6,18 +6,11 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module SPARC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) +module SPARC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) where @@ -26,18 +19,19 @@ where #include "../includes/MachDeps.h" -- NCG stuff: +import SPARC.Base import SPARC.CodeGen.Sanity import SPARC.CodeGen.Amode import SPARC.CodeGen.CondCode import SPARC.CodeGen.Gen64 import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.CCall import SPARC.CodeGen.Base -import SPARC.Ppr () +import SPARC.Ppr () import SPARC.Instr import SPARC.Imm import SPARC.AddrMode import SPARC.Regs +import SPARC.Stack import Instruction import Size import NCGMonad @@ -45,17 +39,23 @@ import NCGMonad -- Our intermediate code: import BlockId import OldCmm +import OldCmmUtils +import PIC +import Reg import CLabel +import CPrim -- The rest: +import BasicTypes import DynFlags -import StaticFlags ( opt_PIC ) +import FastString +import StaticFlags ( opt_PIC ) import OrdList import Outputable import Platform import Unique -import Control.Monad ( mapAndUnzipM ) +import Control.Monad ( mapAndUnzipM ) -- | Top level code generation cmmTopCodeGen :: RawCmmDecl @@ -77,10 +77,10 @@ cmmTopCodeGen (CmmData sec dat) = do -- | Do code generation on a single block of CMM code. --- code generation may introduce new basic block boundaries, which --- are indicated by the NEWBLOCK instruction. We must split up the --- instruction stream into basic blocks again. Also, we extract --- LDATAs here too. +-- code generation may introduce new basic block boundaries, which +-- are indicated by the NEWBLOCK instruction. We must split up the +-- instruction stream into basic blocks again. Also, we extract +-- LDATAs here too. basicBlockCodeGen :: Platform -> CmmBasicBlock -> NatM ( [NatBasicBlock Instr] @@ -89,22 +89,22 @@ basicBlockCodeGen :: Platform basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) + (top,other_blocks,statics) + = foldrOL mkBlocks ([],[],[]) instrs - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) - -- do intra-block sanity checking - blocksChecked - = map (checkBlock platform cmm) - $ BasicBlock id top : other_blocks + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + + -- do intra-block sanity checking + blocksChecked + = map (checkBlock platform cmm) + $ BasicBlock id top : other_blocks return (blocksChecked, statics) @@ -118,32 +118,32 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = case stmt of - CmmNop -> return nilOL + CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src - | isFloatType ty -> assignReg_FltCode size reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg - size = cmmTypeSize ty + | isFloatType ty -> assignReg_FltCode size reg src + | isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType reg + size = cmmTypeSize ty CmmStore addr src - | isFloatType ty -> assignMem_FltCode size addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src - size = cmmTypeSize ty + | isFloatType ty -> assignMem_FltCode size addr src + | isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType src + size = cmmTypeSize ty CmmCall target result_regs args _ -> genCCall target result_regs args - CmmBranch id -> genBranch id - CmmCondBranch arg id -> genCondJump id arg - CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg _ -> genJump arg + CmmBranch id -> genBranch id + CmmCondBranch arg id -> genCondJump id arg + CmmSwitch arg ids -> genSwitch arg ids + CmmJump arg _ -> genJump arg - CmmReturn + CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" @@ -198,8 +198,8 @@ assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_IntCode _ reg src = do r <- getRegister src return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst where dst = getRegisterReg reg @@ -212,23 +212,23 @@ assignMem_FltCode pk addr src = do (src__2, code2) <- getSomeReg src tmp1 <- getNewRegNat pk let - pk__2 = cmmExprType src - code__2 = code1 `appOL` code2 `appOL` - if sizeToWidth pk == typeWidth pk__2 + pk__2 = cmmExprType src + code__2 = code1 `appOL` code2 `appOL` + if sizeToWidth pk == typeWidth pk__2 then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] + else toOL [ FxTOy (cmmTypeSize pk__2) pk src__2 tmp1 + , ST pk tmp1 dst__2] return code__2 -- Floating point assignment to a register/temporary assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock assignReg_FltCode pk dstCmmReg srcCmmExpr = do srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg dstCmmReg + let dstReg = getRegisterReg dstCmmReg return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg + Any _ code -> code dstReg + Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg @@ -243,7 +243,7 @@ genJump (CmmLit (CmmLabel lbl)) genJump tree = do (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) + return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) -- ----------------------------------------------------------------------------- -- Unconditional branches @@ -272,7 +272,7 @@ allocator. genCondJump - :: BlockId -- the branch target + :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock @@ -281,7 +281,7 @@ genCondJump genCondJump bid bool = do CondCode is_float cond code <- getCondCode bool return ( - code `appOL` + code `appOL` toOL ( if is_float then [NOP, BF cond False bid, NOP] @@ -296,34 +296,355 @@ genCondJump bid bool = do genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock genSwitch expr ids - | opt_PIC - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg expr - - base_reg <- getNewRegNat II32 - offset_reg <- getNewRegNat II32 - dst <- getNewRegNat II32 - - label <- getNewLabelNat - - return $ e_code `appOL` - toOL - [ -- load base of jump table - SETHI (HI (ImmCLbl label)) base_reg - , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg - - -- the addrs in the table are 32 bits wide.. - , SLL e_reg (RIImm $ ImmInt 2) offset_reg - - -- load and jump to the destination - , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label - , NOP ] + | opt_PIC + = error "MachCodeGen: sparc genSwitch PIC not finished\n" + + | otherwise + = do (e_reg, e_code) <- getSomeReg expr + + base_reg <- getNewRegNat II32 + offset_reg <- getNewRegNat II32 + dst <- getNewRegNat II32 + + label <- getNewLabelNat + + return $ e_code `appOL` + toOL + [ -- load base of jump table + SETHI (HI (ImmCLbl label)) base_reg + , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg + + -- the addrs in the table are 32 bits wide.. + , SLL e_reg (RIImm $ ImmInt 2) offset_reg + + -- load and jump to the destination + , LD II32 (AddrRegReg base_reg offset_reg) dst + , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label + , NOP ] generateJumpTableForInstr :: Instr -> Maybe (NatCmmDecl CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = - let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (Statics label jumpTable)) + let jumpTable = map jumpTableEntry ids + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing + + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +{- + Now the biggest nightmare---calls. Most of the nastiness is buried in + @get_arg@, which moves the arguments to the correct registers/stack + locations. Apart from that, the code is easy. + + The SPARC calling convention is an absolute + nightmare. The first 6x32 bits of arguments are mapped into + %o0 through %o5, and the remaining arguments are dumped to the + stack, beginning at [%sp+92]. (Note that %o6 == %sp.) + + If we have to put args on the stack, move %o6==%sp down by + the number of words to go on the stack, to ensure there's enough space. + + According to Fraser and Hanson's lcc book, page 478, fig 17.2, + 16 words above the stack pointer is a word for the address of + a structure return value. I use this as a temporary location + for moving values from float to int regs. Certainly it isn't + safe to put anything in the 16 words starting at %sp, since + this area can get trashed at any time due to window overflows + caused by signal handlers. + + A final complication (if the above isn't enough) is that + we can't blithely calculate the arguments one by one into + %o0 .. %o5. Consider the following nested calls: + + fff a (fff b c) + + Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately + the inner call will itself use %o0, which trashes the value put there + in preparation for the outer call. Upshot: we need to calculate the + args into temporary regs, and move those to arg regs or onto the + stack only immediately prior to the call proper. Sigh. +-} + +genCCall + :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + + + +-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream +-- are guaranteed to take place before writes afterwards (unlike on PowerPC). +-- Ref: Section 8.4 of the SPARC V9 Architecture manual. +-- +-- In the SPARC case we don't need a barrier. +-- +genCCall (CmmPrim (MO_WriteBarrier)) _ _ + = do return nilOL + +genCCall (CmmPrim op) results args + | Just stmts <- expandCallishMachOp op results args + = stmtsToInstrs stmts + +genCCall target dest_regs argsAndHints + = do + -- need to remove alignment information + let argsAndHints' | (CmmPrim mop) <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + = init argsAndHints + + | otherwise + = argsAndHints + + -- strip hints from the arg regs + let args :: [CmmExpr] + args = map hintlessCmm argsAndHints' + + + -- work out the arguments, and assign them to integer regs + argcode_and_vregs <- mapM arg_to_int_vregs args + let (argcodes, vregss) = unzip argcode_and_vregs + let vregs = concat vregss + + let n_argRegs = length allArgRegs + let n_argRegs_used = min (length vregs) n_argRegs + + + -- deal with static vs dynamic call targets + callinsns <- case target of + CmmCallee (CmmLit (CmmLabel lbl)) _ -> + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + CmmCallee expr _ + -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + CmmPrim mop + -> do res <- outOfLineMachOp mop + lblOrMopExpr <- case res of + Left lbl -> do + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + Right mopExpr -> do + (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + + return lblOrMopExpr + + let argcode = concatOL argcodes + + let (move_sp_down, move_sp_up) + = let diff = length vregs - n_argRegs + nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment + in if nn <= 0 + then (nilOL, nilOL) + else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) + + let transfer_code + = toOL (move_final vregs allArgRegs extraStackArgsHere) + + dflags <- getDynFlags + return + $ argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` + move_sp_up `appOL` + assign_code (targetPlatform dflags) dest_regs + + +-- | Generate code to calculate an argument, and move it into one +-- or two integer vregs. +arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs arg + + -- If the expr produces a 64 bit int, then we can just use iselExpr64 + | isWord64 (cmmExprType arg) + = do (ChildCode64 code r_lo) <- iselExpr64 arg + let r_hi = getHiVRegFromLo r_lo + return (code, [r_hi, r_lo]) + + | otherwise + = do (src, code) <- getSomeReg arg + let pk = cmmExprType arg + + case cmmTypeSize pk of + + -- Load a 64 bit float return value into two integer regs. + FF64 -> do + v1 <- getNewRegNat II32 + v2 <- getNewRegNat II32 + + let code2 = + code `snocOL` + FMOV FF64 src f0 `snocOL` + ST FF32 f0 (spRel 16) `snocOL` + LD II32 (spRel 16) v1 `snocOL` + ST FF32 f1 (spRel 16) `snocOL` + LD II32 (spRel 16) v2 + + return (code2, [v1,v2]) + + -- Load a 32 bit float return value into an integer reg + FF32 -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + ST FF32 src (spRel 16) `snocOL` + LD II32 (spRel 16) v1 + + return (code2, [v1]) + + -- Move an integer return value into its destination reg. + _ -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + OR False g0 (RIReg src) v1 + + return (code2, [v1]) + + +-- | Move args from the integer vregs into which they have been +-- marshalled, into %o0 .. %o5, and the rest onto the stack. +-- +move_final :: [Reg] -> [Reg] -> Int -> [Instr] + +-- all args done +move_final [] _ _ + = [] + +-- out of aregs; move to stack +move_final (v:vs) [] offset + = ST II32 v (spRel offset) + : move_final vs [] (offset+1) + +-- move into an arg (%o[0..5]) reg +move_final (v:vs) (a:az) offset + = OR False g0 (RIReg v) a + : move_final vs az offset + + +-- | Assign results returned from the call into their +-- desination regs. +-- +assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr + +assign_code _ [] = nilOL + +assign_code platform [CmmHinted dest _hint] + = let rep = localRegType dest + width = typeWidth rep + r_dest = getRegisterReg (CmmLocal dest) + + result + | isFloatType rep + , W32 <- width + = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest + + | isFloatType rep + , W64 <- width + = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest + + | not $ isFloatType rep + , W32 <- width + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest + + | not $ isFloatType rep + , W64 <- width + , r_dest_hi <- getHiVRegFromLo r_dest + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] + + | otherwise + = panic "SPARC.CodeGen.GenCCall: no match" + + in result + +assign_code _ _ + = panic "SPARC.CodeGen.GenCCall: no match" + + + +-- | Generate a call to implement an out-of-line floating point operation +outOfLineMachOp + :: CallishMachOp + -> NatM (Either CLabel CmmExpr) + +outOfLineMachOp mop + = do let functionName + = outOfLineMachOp_table mop + + dflags <- getDynFlags + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference + $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction + + let mopLabelOrExpr + = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + + return mopLabelOrExpr + + +-- | Decide what C function to use to implement a CallishMachOp +-- +outOfLineMachOp_table + :: CallishMachOp + -> FastString + +outOfLineMachOp_table mop + = case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Pwr -> fsLit "powf" + + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Pwr -> fsLit "pow" + + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + + MO_PopCnt w -> fsLit $ popCntLabel w + + MO_S_QuotRem {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + where unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs deleted file mode 100644 index 91351a2e18..0000000000 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ /dev/null @@ -1,343 +0,0 @@ --- | Generating C calls - -module SPARC.CodeGen.CCall ( - genCCall -) - -where - -import SPARC.CodeGen.Gen64 -import SPARC.CodeGen.Gen32 -import SPARC.CodeGen.Base -import SPARC.Stack -import SPARC.Instr -import SPARC.Imm -import SPARC.Regs -import SPARC.Base -import CPrim -import NCGMonad -import PIC -import Instruction -import Size -import Reg - -import OldCmm -import CLabel -import BasicTypes - -import OrdList -import DynFlags -import FastString -import Outputable -import Platform - -{- - Now the biggest nightmare---calls. Most of the nastiness is buried in - @get_arg@, which moves the arguments to the correct registers/stack - locations. Apart from that, the code is easy. - - The SPARC calling convention is an absolute - nightmare. The first 6x32 bits of arguments are mapped into - %o0 through %o5, and the remaining arguments are dumped to the - stack, beginning at [%sp+92]. (Note that %o6 == %sp.) - - If we have to put args on the stack, move %o6==%sp down by - the number of words to go on the stack, to ensure there's enough space. - - According to Fraser and Hanson's lcc book, page 478, fig 17.2, - 16 words above the stack pointer is a word for the address of - a structure return value. I use this as a temporary location - for moving values from float to int regs. Certainly it isn't - safe to put anything in the 16 words starting at %sp, since - this area can get trashed at any time due to window overflows - caused by signal handlers. - - A final complication (if the above isn't enough) is that - we can't blithely calculate the arguments one by one into - %o0 .. %o5. Consider the following nested calls: - - fff a (fff b c) - - Naive code moves a into %o0, and (fff b c) into %o1. Unfortunately - the inner call will itself use %o0, which trashes the value put there - in preparation for the outer call. Upshot: we need to calculate the - args into temporary regs, and move those to arg regs or onto the - stack only immediately prior to the call proper. Sigh. --} - -genCCall - :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) - -> NatM InstrBlock - - - --- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream --- are guaranteed to take place before writes afterwards (unlike on PowerPC). --- Ref: Section 8.4 of the SPARC V9 Architecture manual. --- --- In the SPARC case we don't need a barrier. --- -genCCall (CmmPrim (MO_WriteBarrier)) _ _ - = do return nilOL - -genCCall target dest_regs argsAndHints - = do - -- need to remove alignment information - let argsAndHints' | (CmmPrim mop) <- target, - (mop == MO_Memcpy || - mop == MO_Memset || - mop == MO_Memmove) - = init argsAndHints - - | otherwise - = argsAndHints - - -- strip hints from the arg regs - let args :: [CmmExpr] - args = map hintlessCmm argsAndHints' - - - -- work out the arguments, and assign them to integer regs - argcode_and_vregs <- mapM arg_to_int_vregs args - let (argcodes, vregss) = unzip argcode_and_vregs - let vregs = concat vregss - - let n_argRegs = length allArgRegs - let n_argRegs_used = min (length vregs) n_argRegs - - - -- deal with static vs dynamic call targets - callinsns <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - CmmCallee expr _ - -> do (dyn_c, [dyn_r]) <- arg_to_int_vregs expr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - CmmPrim mop - -> do res <- outOfLineMachOp mop - lblOrMopExpr <- case res of - Left lbl -> do - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - Right mopExpr -> do - (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - return lblOrMopExpr - - let argcode = concatOL argcodes - - let (move_sp_down, move_sp_up) - = let diff = length vregs - n_argRegs - nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment - in if nn <= 0 - then (nilOL, nilOL) - else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) - - let transfer_code - = toOL (move_final vregs allArgRegs extraStackArgsHere) - - dflags <- getDynFlags - return - $ argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up `appOL` - assign_code (targetPlatform dflags) dest_regs - - --- | Generate code to calculate an argument, and move it into one --- or two integer vregs. -arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType arg) - = do (ChildCode64 code r_lo) <- iselExpr64 arg - let r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - - | otherwise - = do (src, code) <- getSomeReg arg - let pk = cmmExprType arg - - case cmmTypeSize pk of - - -- Load a 64 bit float return value into two integer regs. - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - - let code2 = - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f1 (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - - return (code2, [v1,v2]) - - -- Load a 32 bit float return value into an integer reg - FF32 -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - - return (code2, [v1]) - - -- Move an integer return value into its destination reg. - _ -> do - v1 <- getNewRegNat II32 - - let code2 = - code `snocOL` - OR False g0 (RIReg src) v1 - - return (code2, [v1]) - - --- | Move args from the integer vregs into which they have been --- marshalled, into %o0 .. %o5, and the rest onto the stack. --- -move_final :: [Reg] -> [Reg] -> Int -> [Instr] - --- all args done -move_final [] _ _ - = [] - --- out of aregs; move to stack -move_final (v:vs) [] offset - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - --- move into an arg (%o[0..5]) reg -move_final (v:vs) (a:az) offset - = OR False g0 (RIReg v) a - : move_final vs az offset - - --- | Assign results returned from the call into their --- desination regs. --- -assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [CmmHinted dest _hint] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg (CmmLocal dest) - - result - | isFloatType rep - , W32 <- width - = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest - - | isFloatType rep - , W64 <- width - = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest - - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] - - | otherwise - = panic "SPARC.CodeGen.GenCCall: no match" - - in result - -assign_code _ _ - = panic "SPARC.CodeGen.GenCCall: no match" - - - --- | Generate a call to implement an out-of-line floating point operation -outOfLineMachOp - :: CallishMachOp - -> NatM (Either CLabel CmmExpr) - -outOfLineMachOp mop - = do let functionName - = outOfLineMachOp_table mop - - dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference - $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction - - let mopLabelOrExpr - = case mopExpr of - CmmLit (CmmLabel lbl) -> Left lbl - _ -> Right mopExpr - - return mopLabelOrExpr - - --- | Decide what C function to use to implement a CallishMachOp --- -outOfLineMachOp_table - :: CallishMachOp - -> FastString - -outOfLineMachOp_table mop - = case mop of - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Pwr -> fsLit "powf" - - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Pwr -> fsLit "pow" - - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - - MO_Memcpy -> fsLit "memcpy" - MO_Memset -> fsLit "memset" - MO_Memmove -> fsLit "memmove" - - MO_PopCnt w -> fsLit $ popCntLabel w - - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported here" - diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index c68519522d..b45ea1e1b0 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -41,6 +41,7 @@ import BlockId import Module ( primPackageId ) import PprCmm () import OldCmm +import OldCmmUtils import OldPprCmm () import CLabel @@ -1675,6 +1676,11 @@ genCCall32 target dest_regs args = actuallyInlineFloatOp _ _ args = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" ++ show (length args) ++ ")" + + (CmmPrim op, results) + | Just stmts <- expandCallishMachOp op results args -> + stmtsToInstrs stmts + _ -> do let -- Align stack to 16n for calls, assuming a starting stack @@ -1835,6 +1841,22 @@ genCCall64 target dest_regs args = -- we only cope with a single result for foreign calls outOfLineCmmOp op (Just res) args + (CmmPrim (MO_S_QuotRem width), [CmmHinted res_q _, CmmHinted res_r _]) -> + case args of + [CmmHinted arg_x _, CmmHinted arg_y _] -> + do let size = intSize width + reg_q = getRegisterReg True (CmmLocal res_q) + reg_r = getRegisterReg True (CmmLocal res_r) + (y_reg, y_code) <- getRegOrMem arg_y + x_code <- getAnyReg arg_x + return $ y_code `appOL` + x_code rax `appOL` + toOL [CLTD size, + IDIV size y_reg, + MOV size (OpReg rax) (OpReg reg_q), + MOV size (OpReg rdx) (OpReg reg_r)] + _ -> panic "genCCall64: Wrong number of arguments for MO_S_QuotRem" + _ -> do -- load up the register arguments (stack_args, aregs, fregs, load_args_code) @@ -2051,10 +2073,11 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" - MO_WriteBarrier -> - panic $ "outOfLineCmmOp: MO_WriteBarrier not supported here" - MO_Touch -> - panic $ "outOfLineCmmOp: MO_Touch not supported here" + MO_S_QuotRem {} -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + unsupported = panic ("outOfLineCmmOp: " ++ show mop + ++ "not supported here") -- ----------------------------------------------------------------------------- -- Generating a table-branch diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 48dd76873a..183bd35db4 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -210,6 +210,11 @@ primop IntRemOp "remInt#" Dyadic {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.} with can_fail = True +primop IntQuotRemOp "quotRemInt#" GenPrimOp + Int# -> Int# -> (# Int#, Int# #) + {Rounds towards zero.} + with can_fail = True + primop IntNegOp "negateInt#" Monadic Int# -> Int# primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Add with carry. First member of result is (wrapped) sum; |