X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmUtils.hs;h=558b7fdeaa82188ff88e59cc4671183fe160a3da;hp=6cfca5f05f8bea44d9545f19921471698de8258c;hb=d9a655dad8e013e41c74dca98fb86c4ed6f29879;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 6cfca5f..558b7fd 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -20,10 +20,10 @@ module StgCmmUtils ( tagToClosure, mkTaggedObjectLoad, - callerSaveVolatileRegs, get_GlobalReg_addr, + callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, - cmmUGtWord, + cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, cmmOffsetExprW, cmmOffsetExprB, cmmRegOffW, cmmRegOffB, cmmLabelOffW, cmmLabelOffB, @@ -44,17 +44,16 @@ module StgCmmUtils ( ) where #include "HsVersions.h" -#include "MachRegs.h" +#include "../includes/stg/MachRegs.h" import StgCmmMonad import StgCmmClosure import BlockId -import Cmm -import CmmExpr -import MkZipCfgCmm +import CmmDecl +import CmmExpr hiding (regUsedIn) +import MkGraph import CLabel import CmmUtils -import PprCmm ( {- instances -} ) import ForeignCall import IdInfo @@ -63,6 +62,7 @@ import TyCon import Constants import SMRep import StgSyn ( SRT(..) ) +import Module import Literal import Digraph import ListSetOps @@ -98,9 +98,11 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth mkSimpleLit (MachWord64 i) = CmmInt i W64 mkSimpleLit (MachFloat r) = CmmFloat r W32 mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn) - where - is_dyn = False -- ToDo: fix me +mkSimpleLit (MachLabel fs ms fod) + = CmmLabel (mkForeignLabel fs ms labelSrc fod) + where + -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) mkLtOp :: Literal -> MachOp @@ -158,7 +160,8 @@ cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, - cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord + cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, + cmmUShrWord, cmmAddWord, cmmMulWord :: CmmExpr -> CmmExpr -> CmmExpr cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] @@ -168,8 +171,10 @@ 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] +cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2] cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] +cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -284,42 +289,45 @@ tagToClosure tycon tag -- ------------------------------------------------------------------------- -emitRtsCall :: LitString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe +emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode () -emitRtsCallWithVols fun args vols safe - = emitRtsCall' [] fun args (Just vols) safe +emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode () +emitRtsCallWithVols pkg fun args vols safe + = emitRtsCall' [] pkg fun args (Just vols) safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString +emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCallWithResult res hint fun args safe - = emitRtsCall' [(res,hint)] fun args Nothing safe +emitRtsCallWithResult res hint pkg fun args safe + = emitRtsCall' [(res,hint)] pkg fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' :: [(LocalReg,ForeignHint)] - -> LitString + -> PackageId + -> FastString -> [(CmmExpr,ForeignHint)] -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> FCode () -emitRtsCall' res fun args _vols safe +emitRtsCall' res pkg fun args _vols safe = --error "emitRtsCall'" - do { emit caller_save - ; emit call + do { updfr_off <- getUpdFrameOff + ; emit caller_save + ; emit $ call updfr_off ; emit caller_load } where - call = if safe then - mkCall fun_expr CCallConv res' args' undefined - else - mkUnsafeCall (ForeignTarget fun_expr - (ForeignConvention CCallConv arg_hints res_hints)) res' args' + call updfr_off = + if safe then + mkCmmCall fun_expr res' args' updfr_off + else + mkUnsafeCall (ForeignTarget fun_expr + (ForeignConvention CCallConv arg_hints res_hints)) res' args' (args', arg_hints) = unzip args (res', res_hints) = unzip res (caller_save, caller_load) = callerSaveVolatileRegs - fun_expr = mkLblExpr (mkRtsCodeLabel fun) + fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) ----------------------------------------------------------------------------- @@ -335,6 +343,23 @@ emitRtsCall' res fun args _vols safe -- * 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 +-- +-- This code isn't actually used right now, because callerSaves +-- only ever returns true in the current universe for registers NOT in +-- system_regs (just do a grep for CALLER_SAVES in +-- includes/stg/MachRegs.h). It's all one giant no-op, and for +-- good reason: having to save system registers on every foreign call +-- would be very expensive, so we avoid assigning them to those +-- registers when we add support for an architecture. +-- +-- Note that the old code generator actually does more work here: it +-- also saves other global registers. We can't (nor want) to do that +-- here, as we don't have liveness information. And really, we +-- shouldn't be doing the workaround at this point in the pipeline, see +-- Note [Register parameter passing] and the ToDo on CmmCall in +-- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across +-- unsafe foreign calls in rewriteAssignments, but this is strictly +-- temporary. callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph) callerSaveVolatileRegs = (caller_save, caller_load) where @@ -391,6 +416,51 @@ 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 @@ -483,7 +553,13 @@ mkByteStringCLit bytes ------------------------------------------------------------------------- assignTemp :: CmmExpr -> FCode LocalReg --- Make sure the argument is in a local register +-- Make sure the argument is in a local register. +-- We don't bother being particularly aggressive with avoiding +-- unnecessary local registers, since we can rely on a later +-- optimization pass to inline as necessary (and skipping out +-- on things like global registers can be a little dangerous +-- due to them being trashed on foreign calls--though it means +-- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg assignTemp e = do { uniq <- newUnique ; let reg = LocalReg uniq (cmmExprType e) @@ -497,7 +573,7 @@ newTemp rep = do { uniq <- newUnique newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) -- Choose suitable local regs to use for the components -- of an unboxed tuple that we are about to return to --- the Sequel. If the Sequel is a joint point, using the +-- the Sequel. If the Sequel is a join point, using the -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty = ASSERT( isUnboxedTupleType res_ty ) @@ -591,7 +667,6 @@ reg `regUsedIn` CmmRegOff (CmmLocal reg') _ = reg == reg' reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es _reg `regUsedIn` _other = False -- The CmmGlobal cases - ------------------------------------------------------------------------- -- mkSwitch ------------------------------------------------------------------------- @@ -633,7 +708,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag mk_switch tag_expr' (sortLe le branches) mb_deflt lo_tag hi_tag via_C -- Sort the branches before calling mk_switch - <*> mkLabel join_lbl Nothing + <*> mkLabel join_lbl where (t1,_) `le` (t2,_) = t1 <= t2 @@ -706,9 +781,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches = mkCmmIfThenElse (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch))) + (mkBranch deflt) (mk_switch tag_expr branches mb_deflt lo_tag highest_branch via_C) - (mkBranch deflt) | otherwise -- Use an if-tree = mkCmmIfThenElse @@ -788,6 +863,7 @@ mkCmmLitSwitch scrut branches deflt label_code join_lbl deflt $ \ deflt -> label_branches join_lbl branches $ \ branches -> mk_lit_switch scrut' deflt (sortLe le branches) + <*> mkLabel join_lbl where le (t1,_) (t2,_) = t1 <= t2 @@ -795,12 +871,12 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,BlockId)] -> CmmAGraph mk_lit_switch scrut deflt [(lit,blk)] - = mkCbranch - (CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]) - deflt blk + = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk where cmm_lit = mkSimpleLit lit - rep = typeWidth (cmmLitType cmm_lit) + cmm_ty = cmmLitType cmm_lit + rep = typeWidth cmm_ty + ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep mk_lit_switch scrut deflt_blk_id branches = mkCmmIfThenElse cond @@ -846,7 +922,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph -- [L: code; goto J] fun L label_code join_lbl code thing_inside = withFreshLabel "switch" $ \lbl -> - outOfLine (mkLabel lbl Nothing <*> code <*> mkBranch join_lbl) + outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl) <*> thing_inside lbl @@ -879,12 +955,14 @@ getSRTInfo (SRTEntries {}) = panic "getSRTInfo" getSRTInfo (SRT off len bmp) | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape] = do { id <- newUnique - ; top_srt <- getSRTLabel + -- ; top_srt <- getSRTLabel ; let srt_desc_lbl = mkLargeSRTLabel id - ; emitRODataLits srt_desc_lbl - ( cmmLabelOffW top_srt off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + -- JD: We're not constructing and emitting SRTs in the back end, + -- which renders this code wrong (it now names a now-non-existent label). + -- ; emitRODataLits srt_desc_lbl + -- ( cmmLabelOffW top_srt off + -- : mkWordCLit (fromIntegral len) + -- : map mkWordCLit bmp) ; return (C_SRT srt_desc_lbl 0 srt_escape) } | otherwise