X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FcodeGen%2FStgCmmUtils.hs;h=a9532e5effe625483fc90d9c208fdfd7966bc415;hb=a02e7f40afc1aab7fe466f949f505c1d7250713d;hp=6cfca5f05f8bea44d9545f19921471698de8258c;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69;p=ghc-hetmet.git diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 6cfca5f..a9532e5 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -44,13 +44,12 @@ 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 CLabel import CmmUtils @@ -63,6 +62,7 @@ import TyCon import Constants import SMRep import StgSyn ( SRT(..) ) +import Module import Literal import Digraph import ListSetOps @@ -98,7 +98,7 @@ 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) +mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod) where is_dyn = False -- ToDo: fix me mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) @@ -284,42 +284,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) ----------------------------------------------------------------------------- @@ -633,7 +636,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 +709,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 +791,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 +799,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 +850,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 +883,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