diff options
Diffstat (limited to 'compiler/nativeGen/SPARC/CodeGen.hs')
| -rw-r--r-- | compiler/nativeGen/SPARC/CodeGen.hs | 700 |
1 files changed, 0 insertions, 700 deletions
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs deleted file mode 100644 index b9f79a6b9f..0000000000 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ /dev/null @@ -1,700 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- --- Generating machine code (instruction selection) --- --- (c) The University of Glasgow 1996-2013 --- ------------------------------------------------------------------------------ - -{-# LANGUAGE GADTs #-} -module SPARC.CodeGen ( - cmmTopCodeGen, - generateJumpTableForInstr, - InstrBlock -) - -where - -#include "HsVersions.h" - --- NCG stuff: -import GhcPrelude - -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.Base -import SPARC.Instr -import SPARC.Imm -import SPARC.AddrMode -import SPARC.Regs -import SPARC.Stack -import Instruction -import Format -import NCGMonad ( NatM, getNewRegNat, getNewLabelNat ) - --- Our intermediate code: -import GHC.Cmm.BlockId -import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Switch -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Graph -import PIC -import Reg -import GHC.Cmm.CLabel -import CPrim - --- The rest: -import BasicTypes -import GHC.Driver.Session -import FastString -import OrdList -import Outputable -import GHC.Platform - -import Control.Monad ( mapAndUnzipM ) - --- | Top level code generation -cmmTopCodeGen :: RawCmmDecl - -> NatM [NatCmmDecl RawCmmStatics Instr] - -cmmTopCodeGen (CmmProc info lab live graph) - = do let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - let tops = proc : concat statics - - return tops - -cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic - - --- | 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. -basicBlockCodeGen :: CmmBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmDecl RawCmmStatics Instr]) - -basicBlockCodeGen block = do - let (_, nodes, tail) = blockSplit block - id = entryLabel block - stmts = blockToList nodes - mid_instrs <- stmtsToInstrs stmts - tail_instrs <- stmtToInstrs tail - let instrs = mid_instrs `appOL` tail_instrs - let - (top,other_blocks,statics) - = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) - - -- do intra-block sanity checking - blocksChecked - = map (checkBlock block) - $ BasicBlock id top : other_blocks - - return (blocksChecked, statics) - - --- | Convert some Cmm statements to SPARC instructions. -stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock -stmtsToInstrs stmts - = do instrss <- mapM stmtToInstrs stmts - return (concatOL instrss) - - -stmtToInstrs :: CmmNode e x -> NatM InstrBlock -stmtToInstrs stmt = do - dflags <- getDynFlags - case stmt of - CmmComment s -> return (unitOL (COMMENT s)) - CmmTick {} -> return nilOL - CmmUnwind {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | isWord64 ty -> assignReg_I64Code reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType dflags reg - format = cmmTypeFormat ty - - CmmStore addr src - | isFloatType ty -> assignMem_FltCode format addr src - | isWord64 ty -> assignMem_I64Code addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType dflags src - format = cmmTypeFormat ty - - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args - - CmmBranch id -> genBranch id - CmmCondBranch arg true false _ -> do - b1 <- genCondJump true arg - b2 <- genBranch false - return (b1 `appOL` b2) - CmmSwitch arg ids -> do dflags <- getDynFlags - genSwitch dflags arg ids - CmmCall { cml_target = arg } -> genJump arg - - _ - -> panic "stmtToInstrs: statement should have been cps'd away" - - -{- -Now, given a tree (the argument to a CmmLoad) that references memory, -produce a suitable addressing mode. - -A Rule of the Game (tm) for Amodes: use of the addr bit must -immediately follow use of the code part, since the code part puts -values in registers which the addr then refers to. So you can't put -anything in between, lest it overwrite some of those registers. If -you need to do some other computation between the code part and use of -the addr bit, first store the effective address from the amode in a -temporary, then do the other computation, and then use the temporary: - - code - LEA amode, tmp - ... other computation ... - ... (tmp) ... --} - - - --- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic -jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) -jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = blockLbl blockid - - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_IntCode pk addr src = do - (srcReg, code) <- getSomeReg src - Amode dstAddr addr_code <- getAmode addr - return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr - - -assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_IntCode _ reg src = do - dflags <- getDynFlags - r <- getRegister src - let dst = getRegisterReg (targetPlatform dflags) reg - return $ case r of - Any _ code -> code dst - Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst - - - --- Floating point assignment to memory -assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignMem_FltCode pk addr src = do - dflags <- getDynFlags - Amode dst__2 code1 <- getAmode addr - (src__2, code2) <- getSomeReg src - tmp1 <- getNewRegNat pk - let - pk__2 = cmmExprType dflags src - code__2 = code1 `appOL` code2 `appOL` - if formatToWidth pk == typeWidth pk__2 - then unitOL (ST pk src__2 dst__2) - else toOL [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1 - , ST pk tmp1 dst__2] - return code__2 - --- Floating point assignment to a register/temporary -assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_FltCode pk dstCmmReg srcCmmExpr = do - dflags <- getDynFlags - let platform = targetPlatform dflags - srcRegister <- getRegister srcCmmExpr - let dstReg = getRegisterReg platform dstCmmReg - - return $ case srcRegister of - Any _ code -> code dstReg - Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg - - - - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - -genJump (CmmLit (CmmLabel lbl)) - = return (toOL [CALL (Left target) 0 True, NOP]) - where - target = ImmCLbl lbl - -genJump tree - = do - (target, code) <- getSomeReg tree - return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -SPARC: First, we have to ensure that the condition codes are set -according to the supplied comparison operation. We generate slightly -different code for floating point comparisons, because a floating -point operation cannot directly precede a @BF@. We assume the worst -and fill that slot with a @NOP@. - -SPARC: Do not fill the delay slots here; you will confuse the register -allocator. --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - - - -genCondJump bid bool = do - CondCode is_float cond code <- getCondCode bool - return ( - code `appOL` - toOL ( - if is_float - then [NOP, BF cond False bid, NOP] - else [BI cond False bid, NOP] - ) - ) - - - --- ----------------------------------------------------------------------------- --- Generating a table-branch - -genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch dflags expr targets - | positionIndependent dflags - = error "MachCodeGen: sparc genSwitch PIC not finished\n" - - | otherwise - = do (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset) - - 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 ] - where (offset, ids) = switchTargetsToTable targets - -generateJumpTableForInstr :: DynFlags -> Instr - -> Maybe (NatCmmDecl RawCmmStatics Instr) -generateJumpTableForInstr dflags (JMP_TBL _ ids label) = - let jumpTable = map (jumpTableEntry dflags) ids - in Just (CmmData (Section ReadOnlyData label) (RawCmmStatics 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 - :: ForeignTarget -- function to call - -> [CmmFormal] -- where to put the result - -> [CmmActual] -- 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 (PrimTarget MO_ReadBarrier) _ _ - = return $ nilOL -genCCall (PrimTarget MO_WriteBarrier) _ _ - = return $ nilOL - -genCCall (PrimTarget (MO_Prefetch_Data _)) _ _ - = return $ nilOL - -genCCall target dest_regs args - = do -- 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 - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - - ForeignTarget expr _ - -> do (dyn_c, dyn_rs) <- arg_to_int_vregs expr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - - PrimTarget 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_rs) <- arg_to_int_vregs mopExpr - let dyn_r = case dyn_rs of - [dyn_r'] -> dyn_r' - _ -> panic "SPARC.CodeGen.genCCall: arg_to_int" - 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 = do dflags <- getDynFlags - arg_to_int_vregs' dflags arg - -arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs' dflags arg - - -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType dflags 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 dflags arg - - case cmmTypeFormat 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 --- destination regs. --- -assign_code :: Platform -> [LocalReg] -> OrdList Instr - -assign_code _ [] = nilOL - -assign_code platform [dest] - = let rep = localRegType dest - width = typeWidth rep - r_dest = getRegisterReg platform (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 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_ExpM1 -> fsLit "expm1f" - MO_F32_Log -> fsLit "logf" - MO_F32_Log1P -> fsLit "log1pf" - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Fabs -> unsupported - 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_F32_Asinh -> fsLit "asinhf" - MO_F32_Acosh -> fsLit "acoshf" - MO_F32_Atanh -> fsLit "atanhf" - - MO_F64_Exp -> fsLit "exp" - MO_F64_ExpM1 -> fsLit "expm1" - MO_F64_Log -> fsLit "log" - MO_F64_Log1P -> fsLit "log1p" - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Fabs -> unsupported - 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_F64_Asinh -> fsLit "asinh" - MO_F64_Acosh -> fsLit "acosh" - MO_F64_Atanh -> fsLit "atanh" - - MO_UF_Conv w -> fsLit $ word2FloatLabel w - - MO_Memcpy _ -> fsLit "memcpy" - MO_Memset _ -> fsLit "memset" - MO_Memmove _ -> fsLit "memmove" - MO_Memcmp _ -> fsLit "memcmp" - - MO_BSwap w -> fsLit $ bSwapLabel w - MO_BRev w -> fsLit $ bRevLabel w - MO_PopCnt w -> fsLit $ popCntLabel w - MO_Pdep w -> fsLit $ pdepLabel w - MO_Pext w -> fsLit $ pextLabel w - MO_Clz w -> fsLit $ clzLabel w - MO_Ctz w -> fsLit $ ctzLabel w - MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop - MO_Cmpxchg w -> fsLit $ cmpxchgLabel w - MO_AtomicRead w -> fsLit $ atomicReadLabel w - MO_AtomicWrite w -> fsLit $ atomicWriteLabel w - - MO_S_Mul2 {} -> unsupported - MO_S_QuotRem {} -> unsupported - MO_U_QuotRem {} -> unsupported - MO_U_QuotRem2 {} -> unsupported - MO_Add2 {} -> unsupported - MO_AddWordC {} -> unsupported - MO_SubWordC {} -> unsupported - MO_AddIntC {} -> unsupported - MO_SubIntC {} -> unsupported - MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported - MO_Touch -> unsupported - (MO_Prefetch_Data _) -> unsupported - where unsupported = panic ("outOfLineCmmOp: " ++ show mop - ++ " not supported here") - |