X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgUtils.hs;h=c48b584fda43ada42ee937ccfc5e6d9de72e7268;hb=bf2f000a552e025ec156010d52aee282bdfcf7a4;hp=29b972ce62ee705ef3a733e0c6b5faaba28a31c6;hpb=a32098431939d2411798312b11f18cf99e9f724b;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 29b972c..c48b584 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -9,9 +9,12 @@ module CgUtils ( addIdReps, cgLit, - emitDataLits, emitRODataLits, emitIf, emitIfThenElse, + emitDataLits, mkDataLits, + emitRODataLits, mkRODataLits, + emitIf, emitIfThenElse, emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, - assignTemp, newTemp, + assignNonPtrTemp, newNonPtrTemp, + assignPtrTemp, newPtrTemp, emitSimultaneously, emitSwitch, emitLitSwitch, tagToClosure, @@ -26,9 +29,11 @@ module CgUtils ( addToMem, addToMemE, mkWordCLit, - mkStringCLit, + mkStringCLit, mkByteStringCLit, packHalfWordsCLit, - blankWord + blankWord, + + getSRTInfo ) where #include "HsVersions.h" @@ -44,6 +49,8 @@ import CLabel import CmmUtils import MachOp import ForeignCall +import ClosureInfo +import StgSyn (SRT(..)) import Literal import Digraph import ListSetOps @@ -53,6 +60,12 @@ import FastString import PackageConfig import Outputable +import MachRegs (callerSaveVolatileRegs) + -- HACK: this is part of the NCG so we shouldn't use this, but we need + -- it for now to eliminate the need for saved regs to be in CmmCall. + -- The long term solution is to factor callerSaveVolatileRegs + -- from nativeGen into codeGen + import Data.Char import Data.Bits import Data.Word @@ -256,28 +269,36 @@ emitIfThenElse cond then_part else_part ; labelC join_id } -emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code -emitRtsCall fun args = emitRtsCall' [] fun args Nothing +emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code +emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code -emitRtsCallWithVols fun args vols - = emitRtsCall' [] fun args (Just vols) +emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code +emitRtsCallWithVols fun args vols safe + = emitRtsCall' [] fun args (Just vols) safe -emitRtsCallWithResult :: CmmReg -> MachHint -> LitString - -> [(CmmExpr,MachHint)] -> Code -emitRtsCallWithResult res hint fun args - = emitRtsCall' [(res,hint)] fun args Nothing +emitRtsCallWithResult :: LocalReg -> MachHint -> LitString + -> [(CmmExpr,MachHint)] -> Bool -> Code +emitRtsCallWithResult res hint fun args safe + = emitRtsCall' [(res,hint)] fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' - :: [(CmmReg,MachHint)] + :: CmmHintFormals -> LitString -> [(CmmExpr,MachHint)] -> Maybe [GlobalReg] + -> Bool -- True <=> CmmSafe call -> Code -emitRtsCall' res fun args vols = stmtC (CmmCall target res args vols) +emitRtsCall' res fun args vols safe = do + safety <- if safe + then getSRTInfo >>= (return . CmmSafe) + else return CmmUnsafe + stmtsC caller_save + stmtC (CmmCall target res args safety) + stmtsC caller_load where + (caller_save, caller_load) = callerSaveVolatileRegs vols target = CmmForeignCall fun_expr CCallConv fun_expr = mkLblExpr (mkRtsCodeLabel fun) @@ -293,6 +314,11 @@ emitDataLits :: CLabel -> [CmmLit] -> Code emitDataLits lbl lits = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +-- Emit a data-segment data block +mkDataLits lbl lits + = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + emitRODataLits :: CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits lbl lits @@ -303,6 +329,15 @@ emitRODataLits lbl lits needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits lbl lits + = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + where section | any needsRelocation lits = RelocatableReadOnlyData + | otherwise = ReadOnlyData + needsRelocation (CmmLabel _) = True + needsRelocation (CmmLabelOff _ _) = True + needsRelocation _ = False + mkStringCLit :: String -> FCode CmmLit -- Make a global definition for the string, -- and return its label @@ -321,18 +356,29 @@ mkByteStringCLit bytes -- ------------------------------------------------------------------------- -assignTemp :: CmmExpr -> FCode CmmExpr +assignNonPtrTemp :: CmmExpr -> FCode CmmExpr -- For a non-trivial expression, e, create a local -- variable and assign the expression to it -assignTemp e +assignNonPtrTemp e | isTrivialCmmExpr e = return e - | otherwise = do { reg <- newTemp (cmmExprRep e) - ; stmtC (CmmAssign reg e) - ; return (CmmReg reg) } + | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e) + ; stmtC (CmmAssign (CmmLocal reg) e) + ; return (CmmReg (CmmLocal reg)) } +assignPtrTemp :: CmmExpr -> FCode CmmExpr +-- For a non-trivial expression, e, create a local +-- variable and assign the expression to it +assignPtrTemp e + | isTrivialCmmExpr e = return e + | otherwise = do { reg <- newPtrTemp (cmmExprRep e) + ; stmtC (CmmAssign (CmmLocal reg) e) + ; return (CmmReg (CmmLocal reg)) } + +newNonPtrTemp :: MachRep -> FCode LocalReg +newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) } -newTemp :: MachRep -> FCode CmmReg -newTemp rep = do { uniq <- newUnique; return (CmmLocal (LocalReg uniq rep)) } +newPtrTemp :: MachRep -> FCode LocalReg +newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) } ------------------------------------------------------------------------- @@ -435,7 +481,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt @@ -444,7 +490,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt @@ -453,7 +499,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | otherwise -- Use an if-tree - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr -- To avoid duplication ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1) via_C @@ -474,11 +520,12 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C where use_switch = {- pprTrace "mk_switch" ( ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> + text "branches:" <+> ppr (map fst branches) <+> text "n_branches:" <+> int n_branches <+> - text "lo_tag: " <+> int lo_tag <+> - text "hi_tag: " <+> int hi_tag <+> - text "real_lo_tag: " <+> int real_lo_tag <+> - text "real_hi_tag: " <+> int real_hi_tag) $ -} + text "lo_tag:" <+> int lo_tag <+> + text "hi_tag:" <+> int hi_tag <+> + text "real_lo_tag:" <+> int real_lo_tag <+> + text "real_hi_tag:" <+> int real_hi_tag) $ -} ASSERT( n_branches > 1 && n_tags > 1 ) n_tags > 2 && (via_C || (dense && big_enough)) -- up to 4 branches we use a decision tree, otherwise @@ -517,11 +564,10 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C is_lo (t,_) = t < mid_tag -assignTemp' e +assignNonPtrTemp' e | isTrivialCmmExpr e = return (CmmNop, e) - | otherwise = do { reg <- newTemp (cmmExprRep e) - ; return (CmmAssign reg e, CmmReg reg) } - + | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e) + ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) } emitLitSwitch :: CmmExpr -- Tag to switch on -> [(Literal, CgStmts)] -- Tagged branches @@ -536,7 +582,7 @@ emitLitSwitch :: CmmExpr -- Tag to switch on emitLitSwitch scrut [] deflt = emitCgStmts deflt emitLitSwitch scrut branches deflt_blk - = do { scrut' <- assignTemp scrut + = do { scrut' <- assignNonPtrTemp scrut ; deflt_blk_id <- forkCgStmts deflt_blk ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches) ; emitCgStmts blk } @@ -628,13 +674,13 @@ doSimultaneously1 vertices ; stmtC from_temp } go_via_temp (CmmAssign dest src) - = do { tmp <- newTemp (cmmRegRep dest) - ; stmtC (CmmAssign tmp src) - ; return (CmmAssign dest (CmmReg tmp)) } + = do { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong + ; stmtC (CmmAssign (CmmLocal tmp) src) + ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) } go_via_temp (CmmStore dest src) - = do { tmp <- newTemp (cmmExprRep src) - ; stmtC (CmmAssign tmp src) - ; return (CmmStore dest (CmmReg tmp)) } + = do { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong + ; stmtC (CmmAssign (CmmLocal tmp) src) + ; return (CmmStore dest (CmmReg (CmmLocal tmp))) } in mapCs do_component components @@ -683,3 +729,38 @@ possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative + +------------------------------------------------------------------------- +-- +-- Static Reference Tables +-- +------------------------------------------------------------------------- + +-- There is just one SRT for each top level binding; all the nested +-- bindings use sub-sections of this SRT. The label is passed down to +-- the nested bindings via the monad. + +getSRTInfo :: FCode C_SRT +getSRTInfo = do + srt_lbl <- getSRTLabel + srt <- getSRT + case srt of + -- TODO: Should we panic in this case? + -- Someone obviously thinks there should be an SRT + NoSRT -> return NoC_SRT + SRT off len bmp + | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape] + -> do id <- newUnique + let srt_desc_lbl = mkLargeSRTLabel id + emitRODataLits srt_desc_lbl + ( cmmLabelOffW srt_lbl off + : mkWordCLit (fromIntegral len) + : map mkWordCLit bmp) + return (C_SRT srt_desc_lbl 0 srt_escape) + + SRT off len bmp + | otherwise + -> return (C_SRT srt_lbl off (fromIntegral (head bmp))) + -- The fromIntegral converts to StgHalfWord + +srt_escape = (-1) :: StgHalfWord