diff options
Diffstat (limited to 'compiler/nativeGen/PPC/CodeGen.hs')
| -rw-r--r-- | compiler/nativeGen/PPC/CodeGen.hs | 72 |
1 files changed, 40 insertions, 32 deletions
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 848c7f933c..5e05047f34 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -12,6 +12,7 @@ -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. +{-# LANGUAGE GADTs #-} module PPC.CodeGen ( cmmTopCodeGen, generateJumpTableForInstr, @@ -42,8 +43,10 @@ import Platform -- Our intermediate code: import BlockId import PprCmm ( pprExpr ) -import OldCmm +import Cmm +import CmmUtils import CLabel +import Hoopl -- The rest: import OrdList @@ -71,7 +74,8 @@ cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl CmmStatics Instr] -cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat dflags <- getDynFlags @@ -86,12 +90,16 @@ cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic basicBlockCodeGen - :: CmmBasicBlock + :: Block CmmNode C C -> NatM ( [NatBasicBlock Instr] , [NatCmmDecl CmmStatics Instr]) -basicBlockCodeGen (BasicBlock id stmts) = do - instrs <- stmtsToInstrs stmts +basicBlockCodeGen block = do + let (CmmEntry id, nodes, tail) = blockSplit block + stmts = blockToList nodes + mid_instrs <- stmtsToInstrs stmts + tail_instrs <- stmtToInstrs tail + let instrs = mid_instrs `appOL` tail_instrs -- 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 @@ -107,16 +115,15 @@ basicBlockCodeGen (BasicBlock id stmts) = do = (instr:instrs, blocks, statics) return (BasicBlock id top : other_blocks, statics) -stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock +stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock stmtsToInstrs stmts = do instrss <- mapM stmtToInstrs stmts return (concatOL instrss) -stmtToInstrs :: CmmStmt -> NatM InstrBlock +stmtToInstrs :: CmmNode e x -> NatM InstrBlock stmtToInstrs stmt = do dflags <- getDynFlags case stmt of - CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src @@ -135,16 +142,18 @@ stmtToInstrs stmt = do where ty = cmmExprType dflags src size = cmmTypeSize ty - CmmCall target result_regs args _ + CmmUnsafeForeignCall target result_regs args -> genCCall target result_regs args CmmBranch id -> genBranch id - CmmCondBranch arg id -> genCondJump id arg + 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 - CmmJump arg _ -> genJump arg - CmmReturn -> - panic "stmtToInstrs: return statement should have been cps'd away" + CmmCall { cml_target = arg } -> genJump arg + _ -> + panic "stmtToInstrs: statement should have been cps'd away" -------------------------------------------------------------------------------- @@ -837,9 +846,9 @@ genCondJump id bool = do -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. -genCCall :: CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) +genCCall :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock genCCall target dest_regs argsAndHints = do dflags <- getDynFlags @@ -854,9 +863,9 @@ data GenCCallPlatform = GCPLinux | GCPDarwin genCCall' :: DynFlags -> GenCCallPlatform - -> CmmCallTarget -- function to call - -> [HintedCmmFormal] -- where to put the result - -> [HintedCmmActual] -- arguments (of mixed type) + -> ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock {- @@ -897,13 +906,13 @@ genCCall' -} -genCCall' _ _ (CmmPrim MO_WriteBarrier _) _ _ +genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ = return $ unitOL LWSYNC -genCCall' _ _ (CmmPrim _ (Just stmts)) _ _ - = stmtsToInstrs stmts +genCCall' _ _ (PrimTarget MO_Touch) _ _ + = return $ nilOL -genCCall' dflags gcp target dest_regs argsAndHints +genCCall' dflags gcp target dest_regs args0 = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do @@ -915,9 +924,9 @@ genCCall' dflags gcp target dest_regs argsAndHints (toOL []) [] (labelOrExpr, reduceToFF32) <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) - CmmCallee expr _ -> return (Right expr, False) - CmmPrim mop _ -> outOfLineMachOp mop + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) + ForeignTarget expr _ -> return (Right expr, False) + PrimTarget mop -> outOfLineMachOp mop let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 @@ -948,17 +957,16 @@ genCCall' dflags gcp target dest_regs argsAndHints GCPLinux -> roundTo 16 finalStack -- need to remove alignment information - argsAndHints' | CmmPrim mop _ <- target, + args | PrimTarget mop <- target, (mop == MO_Memcpy || mop == MO_Memset || mop == MO_Memmove) - = init argsAndHints + = init args0 | otherwise - = argsAndHints + = args0 - args = map hintlessCmm argsAndHints' - argReps = map (cmmExprType dflags) args + argReps = map (cmmExprType dflags) args0 roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) @@ -1086,7 +1094,7 @@ genCCall' dflags gcp target dest_regs argsAndHints moveResult reduceToFF32 = case dest_regs of [] -> nilOL - [CmmHinted dest _hint] + [dest] | reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1) | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1) | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3, |