X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmUtils.hs;h=d9178116840129bc1fa9d7673d5e802ed51b4974;hp=6cfca5f05f8bea44d9545f19921471698de8258c;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 6cfca5f..d917811 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -20,7 +20,7 @@ module StgCmmUtils ( tagToClosure, mkTaggedObjectLoad, - callerSaveVolatileRegs, get_GlobalReg_addr, + callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, cmmUGtWord, @@ -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 @@ -284,42 +286,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 +340,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 +413,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 @@ -497,7 +564,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 +658,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 +699,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 +772,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 +854,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 +862,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 +913,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 +946,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