X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=672ff6906efa2f935c94645b743a894bcbd385b9;hb=263a30f1db8fc4f5b6cecc26176c6f881807e348;hp=47c875c41df490e844892c68b42730f5bed3d6d0;hpb=001d6ffda6a509c6349f6644df10e8fcf270d218;p=ghc-hetmet.git diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 47c875c..672ff69 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -26,16 +26,12 @@ import CmmOpt ( cmmMiniInline, cmmMachOpFold ) import PprCmm ( pprStmt, pprCmms ) import MachOp import CLabel -#if powerpc_TARGET_ARCH -import CLabel ( mkRtsCodeLabel ) -#endif import UniqFM import Unique ( Unique, getUnique ) import UniqSupply import FastTypes import List ( groupBy, sortBy ) -import CLabel ( pprCLabel ) import ErrUtils ( dumpIfSet_dyn ) import DynFlags import StaticFlags ( opt_Static, opt_PIC ) @@ -112,12 +108,12 @@ The machine-dependent bits break down as follows: -- NB. We *lazilly* compile each block of code for space reasons. -nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc +nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc nativeCodeGen dflags cmms us = let (res, _) = initUs us $ cgCmm (concat (map add_split cmms)) - cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel]) + cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel]) cgCmm tops = lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results -> case unzip3 results of { (cmms,docs,imps) -> @@ -200,17 +196,17 @@ nativeCodeGen dflags cmms us -- Complete native code generation phase for a single top-level chunk -- of Cmm. -cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel]) +cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel]) cmmNativeGen dflags cmm = {-# SCC "fixAssigns" #-} fixAssignsTop cmm `thenUs` \ fixed_cmm -> {-# SCC "genericOpt" #-} - cmmToCmm fixed_cmm `bind` \ (cmm, imports) -> + cmmToCmm dflags fixed_cmm `bind` \ (cmm, imports) -> (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance then cmm else CmmData Text []) `bind` \ ppr_cmm -> {-# SCC "genMachCode" #-} - genMachCode cmm `thenUs` \ (pre_regalloc, lastMinuteImports) -> + genMachCode dflags cmm `thenUs` \ (pre_regalloc, lastMinuteImports) -> {-# SCC "regAlloc" #-} mapUs regAlloc pre_regalloc `thenUs` \ with_regs -> {-# SCC "shortcutBranches" #-} @@ -394,13 +390,12 @@ apply_mapping ufm (CmmProc info lbl params blocks) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel]) +genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel]) -genMachCode cmm_top +genMachCode dflags cmm_top = do { initial_us <- getUs - ; let initial_st = mkNatM_State initial_us 0 + ; let initial_st = mkNatM_State initial_us 0 dflags (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) - final_us = natm_us final_st final_delta = natm_delta final_st final_imports = natm_imports final_st ; if final_delta == 0 @@ -416,7 +411,7 @@ genMachCode cmm_top -- the generic optimiser below, to avoid having two separate passes -- over the Cmm. -fixAssignsTop :: CmmTop -> UniqSM CmmTop +fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop fixAssignsTop top@(CmmData _ _) = returnUs top fixAssignsTop (CmmProc info lbl params blocks) = mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> @@ -433,9 +428,6 @@ fixAssigns stmts = returnUs (concat stmtss) fixAssign :: CmmStmt -> UniqSM [CmmStmt] -fixAssign (CmmAssign (CmmGlobal BaseReg) src) - = panic "cmmStmtConFold: assignment to BaseReg"; - fixAssign (CmmAssign (CmmGlobal reg) src) | Left realreg <- reg_or_addr = returnUs [CmmAssign (CmmGlobal reg) src] @@ -448,27 +440,6 @@ fixAssign (CmmAssign (CmmGlobal reg) src) where reg_or_addr = get_GlobalReg_reg_or_addr reg -fixAssign (CmmCall target results args vols) - = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) -> - returnUs (caller_save ++ - CmmCall target results' args vols : - caller_restore ++ - concat stores) - where - -- we also save/restore any caller-saves STG registers here - (caller_save, caller_restore) = callerSaveVolatileRegs vols - - fixResult g@(CmmGlobal reg,hint) = - case get_GlobalReg_reg_or_addr reg of - Left realreg -> returnUs (g, []) - Right baseRegAddr -> - getUniqueUs `thenUs` \ uq -> - let local = CmmLocal (LocalReg uq (globalRegRep reg)) in - returnUs ((local,hint), - [CmmStore baseRegAddr (CmmReg local)]) - fixResult other = - returnUs (other,[]) - fixAssign other_stmt = returnUs [other_stmt] -- ----------------------------------------------------------------------------- @@ -497,28 +468,31 @@ Ideas for other things we could do (ToDo): temp assignments, and certain assigns to mem...) -} -cmmToCmm :: CmmTop -> (CmmTop, [CLabel]) -cmmToCmm top@(CmmData _ _) = (top, []) -cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do +cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) +cmmToCmm _ top@(CmmData _ _) = (top, []) +cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) return $ CmmProc info lbl params blocks' -newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #)) +newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) instance Monad CmmOptM where - return x = CmmOptM $ \imports -> (# x,imports #) + return x = CmmOptM $ \(imports, _) -> (# x,imports #) (CmmOptM f) >>= g = - CmmOptM $ \imports -> - case f imports of + CmmOptM $ \(imports, dflags) -> + case f (imports, dflags) of (# x, imports' #) -> case g x of - CmmOptM g' -> g' imports' + CmmOptM g' -> g' (imports', dflags) addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #) +addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #) + +getDynFlagsCmmOpt :: CmmOptM DynFlags +getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) -runCmmOpt :: CmmOptM a -> (a, [CLabel]) -runCmmOpt (CmmOptM f) = case f [] of +runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel]) +runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of (# result, imports #) -> (result, imports) cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock @@ -543,16 +517,16 @@ cmmStmtConFold stmt -> do addr' <- cmmExprConFold JumpReference addr return $ CmmJump addr' regs - CmmCall target regs args vols + CmmCall target regs args srt -> do target' <- case target of - CmmForeignCall e conv -> do + CmmCallee e conv -> do e' <- cmmExprConFold CallReference e - return $ CmmForeignCall e' conv + return $ CmmCallee e' conv other -> return other args' <- mapM (\(arg, hint) -> do arg' <- cmmExprConFold DataReference arg return (arg', hint)) args - return $ CmmCall target' regs args' vols + return $ CmmCall target' regs args' srt CmmCondBranch test dest -> do test' <- cmmExprConFold DataReference test @@ -585,9 +559,13 @@ cmmExprConFold referenceKind expr return $ cmmMachOpFold mop args' CmmLit (CmmLabel lbl) - -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl + -> do + dflags <- getDynFlagsCmmOpt + cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl CmmLit (CmmLabelOff lbl off) - -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl + -> do + dflags <- getDynFlagsCmmOpt + dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl return $ cmmMachOpFold (MO_Add wordRep) [ dynRef, (CmmLit $ CmmInt (fromIntegral off) wordRep)