X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgUtils.hs;h=0a8ac41628e1e08a408e2c55a68fa6b4a9964d28;hp=804aeabd13fe95c139ccc925afd877a0ef746b08;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=a2d78ebe0451484e20ad3dc4d7f662e8c1e9650e diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 804aeab..0a8ac41 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -6,35 +6,56 @@ -- ----------------------------------------------------------------------------- +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + 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, + callerSaveVolatileRegs, get_GlobalReg_addr, + cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, + cmmUGtWord, cmmOffsetExprW, cmmOffsetExprB, cmmRegOffW, cmmRegOffB, cmmLabelOffW, cmmLabelOffB, cmmOffsetW, cmmOffsetB, cmmOffsetLitW, cmmOffsetLitB, cmmLoadIndexW, + cmmConstrTag, cmmConstrTag1, + + tagForCon, tagCons, isSmallFamily, + cmmUntag, cmmIsTagged, cmmGetTag, addToMem, addToMemE, mkWordCLit, - mkStringCLit, + mkStringCLit, mkByteStringCLit, packHalfWordsCLit, - blankWord + blankWord, + + getSRTInfo ) where #include "HsVersions.h" +#include "MachRegs.h" import CgMonad import TyCon +import DataCon import Id import Constants import SMRep @@ -44,6 +65,8 @@ import CLabel import CmmUtils import MachOp import ForeignCall +import ClosureInfo +import StgSyn (SRT(..)) import Literal import Digraph import ListSetOps @@ -51,7 +74,9 @@ import Util import DynFlags import FastString import PackageConfig +#ifdef DEBUG import Outputable +#endif import Data.Char import Data.Bits @@ -154,6 +179,9 @@ cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2] cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] +--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] +--cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -162,6 +190,57 @@ cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e] blankWord :: CmmStatic blankWord = CmmUninitialised wORD_SIZE +-- Tagging -- +-- Tag bits mask +--cmmTagBits = CmmLit (mkIntCLit tAG_BITS) +cmmTagMask = CmmLit (mkIntCLit tAG_MASK) +cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK)) + +-- Used to untag a possibly tagged pointer +-- A static label need not be untagged +cmmUntag e@(CmmLit (CmmLabel _)) = e +-- Default case +cmmUntag e = (e `cmmAndWord` cmmPointerMask) + +cmmGetTag e = (e `cmmAndWord` cmmTagMask) + +-- Test if a closure pointer is untagged +cmmIsTagged e = (e `cmmAndWord` cmmTagMask) + `cmmNeWord` CmmLit zeroCLit + +cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1)) +-- Get constructor tag, but one based. +cmmConstrTag1 e = e `cmmAndWord` cmmTagMask + +{- + The family size of a data type (the number of constructors) + can be either: + * small, if the family size < 2**tag_bits + * big, otherwise. + + Small families can have the constructor tag in the tag + bits. + Big families only use the tag value 1 to represent + evaluatedness. +-} +isSmallFamily fam_size = fam_size <= mAX_PTR_TAG + +tagForCon con = tag + where + con_tag = dataConTagZ con + fam_size = tyConFamilySize (dataConTyCon con) + tag | isSmallFamily fam_size = con_tag + 1 + | otherwise = 1 + +--Tag an expression, to do: refactor, this appears in some other module. +tagCons con expr = cmmOffsetB expr (tagForCon con) + +-- Copied from CgInfoTbls.hs +-- We keep the *zero-indexed* tag in the srt_len field of the info +-- table of a data constructor. +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + ----------------------- -- Making literals @@ -209,11 +288,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr -tagToClosure this_pkg tycon tag +tagToClosure :: TyCon -> CmmExpr -> CmmExpr +tagToClosure tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel this_pkg (tyConName tycon) + lbl = mkClosureTableLabel (tyConName tycon) ------------------------------------------------------------------------- -- @@ -256,35 +335,225 @@ 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 CmmMayReturn) + stmtsC caller_load where - target = CmmForeignCall fun_expr CCallConv + (caller_save, caller_load) = callerSaveVolatileRegs vols + target = CmmCallee fun_expr CCallConv fun_expr = mkLblExpr (mkRtsCodeLabel fun) +----------------------------------------------------------------------------- +-- +-- Caller-Save Registers +-- +----------------------------------------------------------------------------- + +-- Here we generate the sequence of saves/restores required around a +-- foreign call instruction. + +-- TODO: reconcile with includes/Regs.h +-- * Regs.h claims that BaseReg should be saved last and loaded first +-- * This might not have been tickled before since BaseReg is callee save +-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim +callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt]) +callerSaveVolatileRegs vols = (caller_save, caller_load) + where + caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save) + caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save) + + system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery, + {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ] + + regs_to_save = system_regs ++ vol_list + + vol_list = case vols of Nothing -> all_of_em; Just regs -> regs + + all_of_em = [ VanillaReg n | n <- [0..mAX_Vanilla_REG] ] + ++ [ FloatReg n | n <- [0..mAX_Float_REG] ] + ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ] + ++ [ LongReg n | n <- [0..mAX_Long_REG] ] + + callerSaveGlobalReg reg next + | callerSaves reg = + CmmStore (get_GlobalReg_addr reg) + (CmmReg (CmmGlobal reg)) : next + | otherwise = next + + callerRestoreGlobalReg reg next + | callerSaves reg = + CmmAssign (CmmGlobal reg) + (CmmLoad (get_GlobalReg_addr reg) (globalRegRep reg)) + : next + | otherwise = next + +-- ----------------------------------------------------------------------------- +-- Global registers + +-- We map STG registers onto appropriate CmmExprs. Either they map +-- to real machine registers or stored as offsets from BaseReg. Given +-- a GlobalReg, get_GlobalReg_addr always produces the +-- register table address for it. +-- (See also get_GlobalReg_reg_or_addr in MachRegs) + +get_GlobalReg_addr :: GlobalReg -> CmmExpr +get_GlobalReg_addr BaseReg = regTableOffset 0 +get_GlobalReg_addr mid = get_Regtable_addr_from_offset + (globalRegRep mid) (baseRegOffset mid) + +-- Calculate a literal representing an offset into the register table. +-- Used when we don't have an actual BaseReg to offset from. +regTableOffset n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) + +get_Regtable_addr_from_offset :: MachRep -> Int -> CmmExpr +get_Regtable_addr_from_offset rep offset = +#ifdef REG_Base + CmmRegOff (CmmGlobal BaseReg) offset +#else + regTableOffset offset +#endif + + +-- | Returns 'True' if this global register is stored in a caller-saves +-- machine register. + +callerSaves :: GlobalReg -> Bool + +#ifdef CALLER_SAVES_Base +callerSaves BaseReg = True +#endif +#ifdef CALLER_SAVES_R1 +callerSaves (VanillaReg 1) = True +#endif +#ifdef CALLER_SAVES_R2 +callerSaves (VanillaReg 2) = True +#endif +#ifdef CALLER_SAVES_R3 +callerSaves (VanillaReg 3) = True +#endif +#ifdef CALLER_SAVES_R4 +callerSaves (VanillaReg 4) = True +#endif +#ifdef CALLER_SAVES_R5 +callerSaves (VanillaReg 5) = True +#endif +#ifdef CALLER_SAVES_R6 +callerSaves (VanillaReg 6) = True +#endif +#ifdef CALLER_SAVES_R7 +callerSaves (VanillaReg 7) = True +#endif +#ifdef CALLER_SAVES_R8 +callerSaves (VanillaReg 8) = True +#endif +#ifdef CALLER_SAVES_F1 +callerSaves (FloatReg 1) = True +#endif +#ifdef CALLER_SAVES_F2 +callerSaves (FloatReg 2) = True +#endif +#ifdef CALLER_SAVES_F3 +callerSaves (FloatReg 3) = True +#endif +#ifdef CALLER_SAVES_F4 +callerSaves (FloatReg 4) = True +#endif +#ifdef CALLER_SAVES_D1 +callerSaves (DoubleReg 1) = True +#endif +#ifdef CALLER_SAVES_D2 +callerSaves (DoubleReg 2) = True +#endif +#ifdef CALLER_SAVES_L1 +callerSaves (LongReg 1) = True +#endif +#ifdef CALLER_SAVES_Sp +callerSaves Sp = True +#endif +#ifdef CALLER_SAVES_SpLim +callerSaves SpLim = True +#endif +#ifdef CALLER_SAVES_Hp +callerSaves Hp = True +#endif +#ifdef CALLER_SAVES_HpLim +callerSaves HpLim = True +#endif +#ifdef CALLER_SAVES_CurrentTSO +callerSaves CurrentTSO = True +#endif +#ifdef CALLER_SAVES_CurrentNursery +callerSaves CurrentNursery = True +#endif +callerSaves _ = False + + +-- ----------------------------------------------------------------------------- +-- Information about global registers + +baseRegOffset :: GlobalReg -> Int + +baseRegOffset (VanillaReg 1) = oFFSET_StgRegTable_rR1 +baseRegOffset (VanillaReg 2) = oFFSET_StgRegTable_rR2 +baseRegOffset (VanillaReg 3) = oFFSET_StgRegTable_rR3 +baseRegOffset (VanillaReg 4) = oFFSET_StgRegTable_rR4 +baseRegOffset (VanillaReg 5) = oFFSET_StgRegTable_rR5 +baseRegOffset (VanillaReg 6) = oFFSET_StgRegTable_rR6 +baseRegOffset (VanillaReg 7) = oFFSET_StgRegTable_rR7 +baseRegOffset (VanillaReg 8) = oFFSET_StgRegTable_rR8 +baseRegOffset (VanillaReg 9) = oFFSET_StgRegTable_rR9 +baseRegOffset (VanillaReg 10) = oFFSET_StgRegTable_rR10 +baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1 +baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2 +baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3 +baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4 +baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1 +baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2 +baseRegOffset Sp = oFFSET_StgRegTable_rSp +baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim +baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1 +baseRegOffset Hp = oFFSET_StgRegTable_rHp +baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim +baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO +baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery +baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc +baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 +baseRegOffset GCFun = oFFSET_stgGCFun +#ifdef DEBUG +baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" +baseRegOffset _ = panic "baseRegOffset:other" +#endif + ------------------------------------------------------------------------- -- --- Strings gnerate a top-level data block +-- Strings generate a top-level data block -- ------------------------------------------------------------------------- @@ -293,6 +562,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 +577,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 +604,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 +assignNonPtrTemp e + | isTrivialCmmExpr e = return e + | 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 -assignTemp e +assignPtrTemp e | isTrivialCmmExpr e = return e - | otherwise = do { reg <- newTemp (cmmExprRep e) - ; stmtC (CmmAssign reg e) - ; return (CmmReg reg) } + | 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 +729,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 +738,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 +747,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 @@ -518,11 +812,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 @@ -537,7 +830,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 } @@ -629,13 +922,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 @@ -684,3 +977,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