diff options
Diffstat (limited to 'compiler/codeGen')
32 files changed, 460 insertions, 258 deletions
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 198e192f5c..0efc99d370 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -146,10 +146,10 @@ data StableLoc -- be saved, so it makes sense to treat treat them as -- having a stable location -instance PlatformOutputable CgIdInfo where - pprPlatform platform (CgIdInfo id _ vol stb _ _) +instance Outputable CgIdInfo where + ppr (CgIdInfo id _ vol stb _ _) -- TODO, pretty pring the tag info - = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, pprPlatform platform stb] + = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb] instance Outputable VolatileLoc where ppr NoVolatileLoc = empty @@ -157,12 +157,12 @@ instance Outputable VolatileLoc where ppr (VirHpLoc v) = ptext (sLit "vh") <+> ppr v ppr (VirNodeLoc v) = ptext (sLit "vn") <+> ppr v -instance PlatformOutputable StableLoc where - pprPlatform _ NoStableLoc = empty - pprPlatform _ VoidLoc = ptext (sLit "void") - pprPlatform _ (VirStkLoc v) = ptext (sLit "vs") <+> ppr v - pprPlatform _ (VirStkLNE v) = ptext (sLit "lne") <+> ppr v - pprPlatform platform (StableLoc a) = ptext (sLit "amode") <+> pprPlatform platform a +instance Outputable StableLoc where + ppr NoStableLoc = empty + ppr VoidLoc = ptext (sLit "void") + ppr (VirStkLoc v) = ptext (sLit "vs") <+> ppr v + ppr (VirStkLNE v) = ptext (sLit "lne") <+> ppr v + ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a \end{code} %************************************************************************ @@ -411,15 +411,12 @@ getArgAmode (StgLitArg lit) = do { cmm_lit <- cgLit lit ; return (typeCgRep (literalType lit), CmmLit cmm_lit) } -getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" - getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)] getArgAmodes [] = returnFC [] getArgAmodes (atom:atoms) - | isStgTypeArg atom = getArgAmodes atoms - | otherwise = do { amode <- getArgAmode atom - ; amodes <- getArgAmodes atoms - ; return ( amode : amodes ) } + = do { amode <- getArgAmode atom + ; amodes <- getArgAmodes atoms + ; return ( amode : amodes ) } \end{code} %************************************************************************ diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index dd607de1fc..745bf47710 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -520,7 +520,6 @@ cgAlgAlts gc_flag cc_slot alt_type alts branches = [(dataConTagZ con, blks) | (DataAlt con, blks) <- alts] - -- in return (branches, mb_deflt) diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index d6537c27e5..8f98a5f764 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -81,7 +81,8 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args ; srt_info <- getSRTInfo ; mod_name <- getModuleName - ; let descr = closureDescription mod_name name + ; dflags <- getDynFlags + ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr closure_label = mkLocalClosureLabel name $ idCafInfo id cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info @@ -120,10 +121,11 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload { -- LAY OUT THE OBJECT amodes <- getArgAmodes payload ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets (isLFThunk lf_info) amodes - descr = closureDescription mod_name (idName bndr) + descr = closureDescription dflags mod_name (idName bndr) closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds NoC_SRT -- No SRT for a std-form closure @@ -169,13 +171,14 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do ; fv_infos <- mapFCs getCgIdInfo reduced_fvs ; srt_info <- getSRTInfo ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let bind_details :: [(CgIdInfo, VirtualHpOffset)] (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos) add_rep info = (cgIdInfoArgRep info, info) - descr = closureDescription mod_name name + descr = closureDescription dflags mod_name name closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds srt_info descr @@ -485,7 +488,7 @@ emitBlackHoleCode is_single_entry = do stmtsC [ CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)), - CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmMayReturn, + CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) ] \end{code} @@ -506,9 +509,10 @@ setupUpdate closure_info code else do tickyPushUpdateFrame dflags <- getDynFlags - if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags - then pushBHUpdateFrame (CmmReg nodeReg) code - else pushUpdateFrame (CmmReg nodeReg) code + if blackHoleOnEntry closure_info && + not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags + then pushBHUpdateFrame (CmmReg nodeReg) code + else pushUpdateFrame (CmmReg nodeReg) code | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -612,13 +616,14 @@ name of the data constructor itself. Otherwise it is determined by @closureDescription@ from the let binding information. \begin{code} -closureDescription :: Module -- Module - -> Name -- Id of closure binding - -> String +closureDescription :: DynFlags + -> Module -- Module + -> Name -- Id of closure binding + -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.lhs with a description generated from the data constructor -closureDescription mod_name name - = showSDocDumpOneLine (char '<' <> +closureDescription dflags mod_name name + = showSDocDumpOneLine dflags (char '<' <> (if isExternalName name then ppr name -- ppr will include the module name prefix else pprModule mod_name <> char '.' <> ppr name) <> diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 9049504dca..aff5e468ca 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -72,13 +72,12 @@ cgTopRhsCon id con args ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags con args) ) return () - ; ASSERT( args `lengthIs` dataConRepArity con ) return () + ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT ; amodes <- getArgAmodes args ; let - platform = targetPlatform dflags name = idName id lf_info = mkConLFInfo con closure_label = mkClosureLabel name $ idCafInfo id @@ -92,7 +91,7 @@ cgTopRhsCon id con args payload = map get_lit amodes_w_offsets get_lit (CmmLit lit, _offset) = lit - get_lit other = pprPanic "CgCon.get_lit" (pprPlatform platform other) + get_lit other = pprPanic "CgCon.get_lit" (ppr other) -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs -- NB2: all the amodes should be Lits! @@ -324,7 +323,7 @@ cgReturnDataCon con amodes -- for it to be marked as "used" for LDV profiling. | opt_SccProfilingOn = build_it_then enter_it | otherwise - = ASSERT( amodes `lengthIs` dataConRepArity con ) + = ASSERT( amodes `lengthIs` dataConRepRepArity con ) do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ; case sequel of CaseAlts _ (Just (alts, deflt_lbl)) bndr @@ -466,8 +465,8 @@ cgDataCon data_con ; ldvEnter (CmmReg nodeReg) ; body_code } - arg_reps :: [(CgRep, Type)] - arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con] + arg_reps :: [(CgRep, UnaryType)] + arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] body_code = do { -- NB: We don't set CC when entering data (WDP 94/06) diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index cb3a86ef7f..f935f95726 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -480,7 +480,7 @@ Little helper for primitives that return unboxed tuples. newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint]) newUnboxedTupleRegs res_ty = let - ty_args = tyConAppArgs (repType res_ty) + UbxTupleRep ty_args = repType res_ty (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 09636bc6b2..e957b90b20 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -59,7 +59,6 @@ cgForeignCall results fcall stg_args live arg_hints = zipWith CmmHinted arg_exprs (map (typeForeignHint.stgArgType) stg_args) - -- in emitForeignCall results fcall arg_hints live @@ -78,9 +77,11 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live where (call_args, cmm_target) = case target of + StaticTarget _ _ False -> + panic "emitForeignCall: unexpected FFI value import" -- If the packageId is Nothing then the label is taken to be in the -- package currently being compiled. - StaticTarget lbl mPkgId + StaticTarget lbl mPkgId True -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage @@ -309,4 +310,5 @@ shimForeignCallArg arg expr | otherwise = expr where -- should be a tycon app, since this is a foreign call - tycon = tyConAppTyCon (repType (stgArgType arg)) + UnaryRep rep_ty = repType (stgArgType arg) + tycon = tyConAppTyCon rep_ty diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index f98d579e62..7cdb1b6f7e 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -45,7 +45,6 @@ import Unique import StaticFlags import Constants -import DynFlags import Util import Outputable @@ -150,8 +149,6 @@ is not present in the list (it is always assumed). -} mkStackLayout :: FCode [Maybe LocalReg] mkStackLayout = do - dflags <- getDynFlags - let platform = targetPlatform dflags StackUsage { realSp = real_sp, frameSp = frame_sp } <- getStkUsage binds <- getLiveStackBindings @@ -161,7 +158,7 @@ mkStackLayout = do | (offset, b) <- binds] WARN( not (all (\bind -> fst bind >= 0) rel_binds), - pprPlatform platform binds $$ pprPlatform platform rel_binds $$ + ppr binds $$ ppr rel_binds $$ ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) return $ stack_layout rel_binds frame_size diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index dff54f3bf5..71da9e9ae0 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -77,6 +77,7 @@ import VarEnv import OrdList import Unique import UniqSupply +import Util import Outputable import Control.Monad diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs index 2804104708..c86ef9e34a 100644 --- a/compiler/codeGen/CgParallel.hs +++ b/compiler/codeGen/CgParallel.hs @@ -3,78 +3,73 @@ -- (c) The University of Glasgow -2006 -- -- Code generation relaed to GpH --- (a) parallel --- (b) GranSim +-- (a) parallel +-- (b) GranSim -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CgParallel( - staticGranHdr,staticParHdr, - granFetchAndReschedule, granYield, - doGranAllocate + staticGranHdr,staticParHdr, + granFetchAndReschedule, granYield, + doGranAllocate ) where import CgMonad import CgCallConv +import DynFlags import Id import OldCmm -import StaticFlags import Outputable import SMRep +import Control.Monad + staticParHdr :: [CmmLit] -- Parallel header words in a static closure staticParHdr = [] -------------------------------------------------------- --- GranSim stuff +-- GranSim stuff -------------------------------------------------------- staticGranHdr :: [CmmLit] -- Gransim header words in a static closure staticGranHdr = [] -doGranAllocate :: CmmExpr -> Code +doGranAllocate :: CmmExpr -> Code -- macro DO_GRAN_ALLOCATE doGranAllocate _hp - | not opt_GranMacros = nopC - | otherwise = panic "doGranAllocate" + = do dflags <- getDynFlags + when (dopt Opt_GranMacros dflags) $ panic "doGranAllocate" ------------------------- granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code + -> Bool -- Node reqd? + -> Code -- Emit code for simulating a fetch and then reschedule. granFetchAndReschedule regs node_reqd - | opt_GranMacros && (node `elem` map snd regs || node_reqd) - = do { fetch - ; reschedule liveness node_reqd } - | otherwise - = nopC + = do dflags <- getDynFlags + when (dopt Opt_GranMacros dflags && + (node `elem` map snd regs || node_reqd)) $ + do fetch + reschedule liveness node_reqd where liveness = mkRegLiveness regs 0 0 fetch :: FCode () fetch = panic "granFetch" - -- Was: absC (CMacroStmt GRAN_FETCH []) - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai + -- Was: absC (CMacroStmt GRAN_FETCH []) + --HWL: generate GRAN_FETCH macro for GrAnSim + -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai reschedule :: StgWord -> Bool -> Code reschedule _liveness _node_reqd = panic "granReschedule" - -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ - -- mkIntCLit (I# (word2Int# liveness_mask)), - -- mkIntCLit (if node_reqd then 1 else 0)]) - + -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ + -- mkIntCLit (I# (word2Int# liveness_mask)), + -- mkIntCLit (if node_reqd then 1 else 0)]) + ------------------------- -- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It @@ -82,26 +77,26 @@ reschedule _liveness _node_reqd = panic "granReschedule" -- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit -- this kind of macro at the beginning of the following kinds of basic bocks: -- \begin{itemize} --- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally +-- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally -- we use @fetchAndReschedule@ at a slow entry code. -- \item Fast entry code (see @CgClosure.lhs@). -- \item Alternatives in case expressions (@CLabelledCode@ structures), provided --- that they are not inlined (see @CgCases.lhs@). These alternatives will +-- that they are not inlined (see @CgCases.lhs@). These alternatives will -- be turned into separate functions. granYield :: [(Id,GlobalReg)] -- Live registers -> Bool -- Node reqd? - -> Code + -> Code granYield regs node_reqd - | opt_GranMacros && node_reqd = yield liveness - | otherwise = nopC + = do dflags <- getDynFlags + when (dopt Opt_GranMacros dflags && node_reqd) $ yield liveness where liveness = mkRegLiveness regs 0 0 yield :: StgWord -> Code yield _liveness = panic "granYield" - -- Was : absC (CMacroStmt GRAN_YIELD + -- Was : absC (CMacroStmt GRAN_YIELD -- [mkIntCLit (I# (word2Int# liveness_mask))]) diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index b0865d69d9..641cd5d1dc 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -33,6 +33,8 @@ import Outputable import FastString import StaticFlags +import Control.Monad + -- --------------------------------------------------------------------------- -- Code generation for PrimOps @@ -402,12 +404,14 @@ emitPrimOp res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just mo_W emitPrimOp res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args emitPrimOp res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args --- Copying byte arrays +-- Copying and setting byte arrays emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyByteArrayOp src src_off dst dst_off n live emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableByteArrayOp src src_off dst dst_off n live +emitPrimOp [] SetByteArrayOp [ba,off,len,c] live = + doSetByteArrayOp ba off len c live -- Population count emitPrimOp [res] PopCnt8Op [w] live = emitPopCntCall res w W8 live @@ -430,7 +434,7 @@ emitPrimOp [res] op args live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim prim) + (CmmPrim prim Nothing) [CmmHinted a NoHint | a<-args] -- ToDo: hints? (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky @@ -440,9 +444,167 @@ emitPrimOp [res] op args live = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt +emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ + = let genericImpl + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt +emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ + = let genericImpl + = [CmmAssign (CmmLocal res_q) + (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), + CmmAssign (CmmLocal res_r) + (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + in stmtC stmt +emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ + = do let ty = cmmExprType arg_x_high + shl x i = CmmMachOp (MO_Shl wordWidth) [x, i] + shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] + ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] + minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] + times x y = CmmMachOp (MO_Mul wordWidth) [x, y] + zero = lit 0 + one = lit 1 + negone = lit (fromIntegral (widthInBits wordWidth) - 1) + lit i = CmmLit (CmmInt i wordWidth) + f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt] + f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc, + CmmAssign (CmmLocal res_r) high] + f i acc high low = + do roverflowedBit <- newLocalReg ty + rhigh' <- newLocalReg ty + rhigh'' <- newLocalReg ty + rlow' <- newLocalReg ty + risge <- newLocalReg ty + racc' <- newLocalReg ty + let high' = CmmReg (CmmLocal rhigh') + isge = CmmReg (CmmLocal risge) + overflowedBit = CmmReg (CmmLocal roverflowedBit) + let this = [CmmAssign (CmmLocal roverflowedBit) + (shr high negone), + CmmAssign (CmmLocal rhigh') + (or (shl high one) (shr low negone)), + CmmAssign (CmmLocal rlow') + (shl low one), + CmmAssign (CmmLocal risge) + (or (overflowedBit `ne` zero) + (high' `ge` arg_y)), + CmmAssign (CmmLocal rhigh'') + (high' `minus` (arg_y `times` isge)), + CmmAssign (CmmLocal racc') + (or (shl acc one) isge)] + rest <- f (i - 1) (CmmReg (CmmLocal racc')) + (CmmReg (CmmLocal rhigh'')) + (CmmReg (CmmLocal rlow')) + return (this ++ rest) + genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low + let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl)) + [CmmHinted res_q NoHint, + CmmHinted res_r NoHint] + [CmmHinted arg_x_high NoHint, + CmmHinted arg_x_low NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt + +emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ + = do r1 <- newLocalReg (cmmExprType arg_x) + r2 <- newLocalReg (cmmExprType arg_x) + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let genericImpl + = [CmmAssign (CmmLocal r1) + (add (bottomHalf arg_x) (bottomHalf arg_y)), + CmmAssign (CmmLocal r2) + (add (topHalf (CmmReg (CmmLocal r1))) + (add (topHalf arg_x) (topHalf arg_y))), + CmmAssign (CmmLocal res_h) + (topHalf (CmmReg (CmmLocal r2))), + CmmAssign (CmmLocal res_l) + (or (toTopHalf (CmmReg (CmmLocal r2))) + (bottomHalf (CmmReg (CmmLocal r1))))] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) + stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) + [CmmHinted res_h NoHint, + CmmHinted res_l NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt +emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ + = do let t = cmmExprType arg_x + xlyl <- liftM CmmLocal $ newLocalReg t + xlyh <- liftM CmmLocal $ newLocalReg t + xhyl <- liftM CmmLocal $ newLocalReg t + r <- liftM CmmLocal $ newLocalReg t + -- This generic implementation is very simple and slow. We might + -- well be able to do better, but for now this at least works. + let genericImpl + = [CmmAssign xlyl + (mul (bottomHalf arg_x) (bottomHalf arg_y)), + CmmAssign xlyh + (mul (bottomHalf arg_x) (topHalf arg_y)), + CmmAssign xhyl + (mul (topHalf arg_x) (bottomHalf arg_y)), + CmmAssign r + (sum [topHalf (CmmReg xlyl), + bottomHalf (CmmReg xhyl), + bottomHalf (CmmReg xlyh)]), + CmmAssign (CmmLocal res_l) + (or (bottomHalf (CmmReg xlyl)) + (toTopHalf (CmmReg r))), + CmmAssign (CmmLocal res_h) + (sum [mul (topHalf arg_x) (topHalf arg_y), + topHalf (CmmReg xhyl), + topHalf (CmmReg xlyh), + topHalf (CmmReg r)])] + where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] + bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] + add x y = CmmMachOp (MO_Add wordWidth) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] + or x y = CmmMachOp (MO_Or wordWidth) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) + wordWidth) + hwm = CmmLit (CmmInt halfWordMask wordWidth) + stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl)) + [CmmHinted res_h NoHint, + CmmHinted res_l NoHint] + [CmmHinted arg_x NoHint, + CmmHinted arg_y NoHint] + CmmMayReturn + stmtC stmt + emitPrimOp _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) +newLocalReg :: CmmType -> FCode LocalReg +newLocalReg t = do u <- newUnique + return $ LocalReg u t -- These PrimOps are NOPs in Cmm @@ -748,6 +910,18 @@ emitCopyByteArray copy src src_off dst dst_off n live = do copy src dst dst_p src_p n live -- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- character. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doSetByteArrayOp ba off len c live + = do p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off + emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live + +-- ---------------------------------------------------------------------------- -- Copying pointer arrays -- EZY: This code has an unusually high amount of assignTemp calls, seen @@ -889,7 +1063,7 @@ emitMemcpyCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memcpy) + (CmmPrim MO_Memcpy Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -906,7 +1080,7 @@ emitMemmoveCall dst src n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memmove) + (CmmPrim MO_Memmove Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted src AddrHint) , (CmmHinted n NoHint) @@ -924,7 +1098,7 @@ emitMemsetCall dst c n align live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmPrim MO_Memset) + (CmmPrim MO_Memset Nothing) [ (CmmHinted dst AddrHint) , (CmmHinted c NoHint) , (CmmHinted n NoHint) @@ -956,7 +1130,7 @@ emitPopCntCall res x width live = do vols <- getVolatileRegs live emitForeignCall' PlayRisky [CmmHinted res NoHint] - (CmmPrim (MO_PopCnt width)) + (CmmPrim (MO_PopCnt width) Nothing) [(CmmHinted x NoHint)] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 296dd62818..1a5f916dbe 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -170,8 +170,9 @@ emitCostCentreDecl cc = do -- All cost centres will be in the main package, since we -- don't normally use -auto-all or add SCCs to other packages. -- Hence don't emit the package name in the module here. + ; dflags <- getDynFlags ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ - showSDoc (ppr (costCentreSrcSpan cc)) + showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let lits = [ zero, -- StgInt ccID, diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index 2628760183..a869795caa 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -43,6 +43,7 @@ import OrdList import Outputable import Control.Monad +import Data.List \end{code} %************************************************************************ @@ -333,7 +334,7 @@ Explicitly free some stack space. freeStackSlots :: [VirtualSpOffset] -> Code freeStackSlots extra_free = do { stk_usg <- getStkUsage - ; let all_free = addFreeSlots (freeStk stk_usg) (sortLe (<=) extra_free) + ; let all_free = addFreeSlots (freeStk stk_usg) (sort extra_free) ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) } diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 499529d841..e933fedb5b 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -43,6 +43,7 @@ import StgSyn import PrimOp import Outputable import StaticFlags +import Util import Control.Monad import Data.Maybe diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 0ff440e6bf..021b0e4fd9 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -91,7 +91,8 @@ emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code emitTickyCounter cl_info args on_stk = ifTicky $ do { mod_name <- getModuleName - ; fun_descr_lit <- newStringCLit (fun_descr mod_name) + ; dflags <- getDynFlags + ; fun_descr_lit <- newStringCLit (fun_descr dflags mod_name) ; arg_descr_lit <- newStringCLit arg_descr ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter -- krc: note that all the fields are I32 now; some were I16 before, @@ -110,15 +111,15 @@ emitTickyCounter cl_info args on_stk name = closureName cl_info ticky_ctr_label = mkRednCountsLabel name NoCafRefs arg_descr = map (showTypeCategory . idType) args - fun_descr mod_name = ppr_for_ticky_name mod_name name + fun_descr dflags mod_name = ppr_for_ticky_name dflags mod_name name -- When printing the name of a thing in a ticky file, we want to -- give the module name even for *local* things. We print -- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name :: Module -> Name -> String -ppr_for_ticky_name mod_name name - | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug (ppr name) +ppr_for_ticky_name :: DynFlags -> Module -> Name -> String +ppr_for_ticky_name dflags mod_name name + | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name))) + | otherwise = showSDocDebug dflags (ppr name) -- ----------------------------------------------------------------------------- -- Ticky stack frames diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 2bd35c8796..e7d17c1f03 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -72,7 +72,9 @@ import Outputable import Data.Char import Data.Word +import Data.List import Data.Maybe +import Data.Ord ------------------------------------------------------------------------- -- @@ -527,12 +529,10 @@ emitSwitch tag_expr branches mb_deflt lo_tag hi_tag ; let via_C | HscC <- hscTarget dflags = True | otherwise = False - ; stmts <- mk_switch tag_expr (sortLe le branches) + ; stmts <- mk_switch tag_expr (sortBy (comparing fst) branches) mb_deflt_id lo_tag hi_tag via_C ; emitCgStmts stmts } - where - (t1,_) `le` (t2,_) = t1 <= t2 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)] @@ -699,10 +699,8 @@ emitLitSwitch _ [] deflt = emitCgStmts deflt emitLitSwitch scrut branches deflt_blk = do { scrut' <- assignTemp scrut ; deflt_blk_id <- forkCgStmts deflt_blk - ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches) + ; blk <- mk_lit_switch scrut' deflt_blk_id (sortBy (comparing fst) branches) ; emitCgStmts blk } - where - le (t1,_) (t2,_) = t1 <= t2 mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,CgStmts)] @@ -1011,7 +1009,8 @@ fixStgRegStmt stmt CmmCall target regs args returns -> let target' = case target of CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv - other -> other + CmmPrim op mStmts -> + CmmPrim op (fmap (map fixStgRegStmt) mStmts) args' = map (\(CmmHinted arg hint) -> (CmmHinted (fixStgRegExpr arg) hint)) args in CmmCall target' regs args' returns diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 34746984c2..7a91a5e2a1 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -20,6 +20,8 @@ the STG paper. -- for details module ClosureInfo ( + idRepArity, + ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but StandardFormInfo(..), -- mkCmmInfo looks inside SMRep, @@ -96,6 +98,7 @@ import Outputable import FastString import Constants import DynFlags +import Util \end{code} @@ -156,7 +159,7 @@ ClosureInfo contains a LambdaFormInfo. data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity. Invariant: always > 0 + !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should reall be in ClosureInfo) @@ -180,7 +183,7 @@ data LambdaFormInfo | LFLetNoEscape -- See LetNoEscape module for precise description of -- these "lets". - !Int -- arity; + !RepArity -- arity; | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to @@ -211,7 +214,7 @@ data StandardFormInfo -- The code for the thunk just pushes x2..xn on the stack and enters x1. -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled -- in the RTS to save space. - Int -- Arity, n + RepArity -- Arity, n \end{code} @@ -288,7 +291,7 @@ idCgRep x = typeCgRep . idType $ x tyConCgRep :: TyCon -> CgRep tyConCgRep = primRepToCgRep . tyConPrimRep -typeCgRep :: Type -> CgRep +typeCgRep :: UnaryType -> CgRep typeCgRep = primRepToCgRep . typePrimRep \end{code} @@ -384,9 +387,12 @@ might_be_a_function :: Type -> Bool -- Return False only if we are *sure* it's a data type -- Look through newtypes etc as much as poss might_be_a_function ty - = case tyConAppTyCon_maybe (repType ty) of - Just tc -> not (isDataTyCon tc) - Nothing -> True + | UnaryRep rep <- repType ty + , Just tc <- tyConAppTyCon_maybe rep + , isDataTyCon tc + = False + | otherwise + = True \end{code} @mkConLFInfo@ is similar, for constructors. @@ -404,7 +410,7 @@ mkSelectorLFInfo id offset updatable = LFThunk NotTopLevel False updatable (SelectorThunk offset) (might_be_a_function (idType id)) -mkApLFInfo :: Id -> UpdateFlag -> Int -> LambdaFormInfo +mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) (might_be_a_function (idType id)) @@ -416,12 +422,12 @@ Miscellaneous LF-infos. mkLFArgument :: Id -> LambdaFormInfo mkLFArgument id = LFUnknown (might_be_a_function (idType id)) -mkLFLetNoEscape :: Int -> LambdaFormInfo +mkLFLetNoEscape :: RepArity -> LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id - = case idArity id of + = case idRepArity id of n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0 _ -> mkLFArgument id -- Not sure of exact arity \end{code} @@ -634,17 +640,17 @@ data CallMethod | DirectEntry -- Jump directly, with args in regs CLabel -- The code label - Int -- Its arity + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info - -> Int -- Number of available arguments + -> RepArity -- Number of available arguments -> CallMethod -getCallMethod _ _ _ lf_info _ - | nodeMustPointToIt lf_info && opt_Parallel +getCallMethod dflags _ _ lf_info _ + | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. @@ -725,7 +731,7 @@ blackHoleOnEntry cl_info = case closureLFInfo cl_info of LFReEntrant _ _ _ _ -> False LFLetNoEscape _ -> False - LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks. + LFThunk _ _no_fvs _updatable _ _ -> True _other -> panic "blackHoleOnEntry" -- Should never happen isKnownFun :: LambdaFormInfo -> Bool @@ -911,11 +917,11 @@ isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con isConstrClosure_maybe _ = Nothing -closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info closureFunInfo _ = Nothing -lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr) +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing @@ -935,7 +941,7 @@ funTagLFInfo lf | otherwise = 0 -tagForArity :: Int -> Maybe Int +tagForArity :: RepArity -> Maybe Int tagForArity i | i <= mAX_PTR_TAG = Just i | otherwise = Nothing @@ -1097,8 +1103,16 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other + + +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n \end{code} diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index f8898450ef..9c936d3281 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -75,8 +75,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info st <- readIORef cgref let (a,st') = runC dflags this_mod st fcode - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ - pprPlatform (targetPlatform dflags) a + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" $ ppr a -- NB. stub-out cgs_tops and cgs_stmts. This fixes -- a big space leak. DO NOT REMOVE! diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 933aeb9d45..696af8107e 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -53,6 +53,7 @@ import MkGraph import Data.IORef import Control.Monad (when) +import Util codeGen :: DynFlags -> Module @@ -246,8 +247,8 @@ cgDataCon data_con (tagForCon data_con)] } -- The case continuation code expects a tagged pointer - arg_reps :: [(PrimRep, Type)] - arg_reps = [(typePrimRep ty, ty) | ty <- dataConRepArgTys data_con] + arg_reps :: [(PrimRep, UnaryType)] + arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)] -- Dynamic closure code for non-nullary constructors only ; whenC (not (isNullaryRepDataCon data_con)) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 5838628fca..f98283f737 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -79,9 +79,10 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args ; has_srt <- getSRTInfo srt ; mod_name <- getModuleName - ; let descr = closureDescription mod_name name + ; dflags <- getDynFlags + ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo True id lf_info 0 0 descr - closure_label = mkLocalClosureLabel name (idCafInfo id) + closure_label = mkLocalClosureLabel name (idCafInfo id) cg_id_info = litIdInfo id lf_info (CmmLabel closure_label) caffy = idCafInfo id info_tbl = mkCmmInfo closure_info -- XXX short-cut @@ -285,9 +286,10 @@ mkRhsClosure bndr cc _ fvs upd_flag args body -- MAKE CLOSURE INFO FOR THIS CLOSURE ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let name = idName bndr - descr = closureDescription mod_name name - fv_details :: [(NonVoid Id, VirtualHpOffset)] + descr = closureDescription dflags mod_name name + fv_details :: [(NonVoid Id, VirtualHpOffset)] (tot_wds, ptr_wds, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) (addIdReps (map stripNV reduced_fvs)) @@ -333,10 +335,11 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload = do -- AHA! A STANDARD-FORM THUNK { -- LAY OUT THE OBJECT mod_name <- getModuleName + ; dflags <- getDynFlags ; let (tot_wds, ptr_wds, payload_w_offsets) = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload) - descr = closureDescription mod_name (idName bndr) + descr = closureDescription dflags mod_name (idName bndr) closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -404,9 +407,7 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details do { -- Allocate the global ticky counter, -- and establish the ticky-counter -- label for this block - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ticky_ctr_lbl = closureRednCountsLabel platform cl_info + let ticky_ctr_lbl = closureRednCountsLabel cl_info ; emitTickyCounter cl_info (map stripNV args) ; setTickyCtrLabel ticky_ctr_lbl $ do @@ -463,10 +464,8 @@ mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode () mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do dflags <- getDynFlags - let platform = targetPlatform dflags - slow_lbl = closureSlowEntryLabel platform cl_info - fast_lbl = closureLocalEntryLabel platform cl_info + = do let slow_lbl = closureSlowEntryLabel cl_info + fast_lbl = closureLocalEntryLabel cl_info -- mkDirectJump does not clobber `Node' containing function closure jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) @@ -561,12 +560,15 @@ setupUpdate closure_info node body then do tickyUpdateFrameOmitted; body else do tickyPushUpdateFrame - --dflags <- getDynFlags - let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel] - --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags - -- then pushUpdateFrame es body -- XXX black hole - -- else pushUpdateFrame es body - pushUpdateFrame es body + dflags <- getDynFlags + let + bh = blackHoleOnEntry closure_info && + not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags + + lbl | bh = mkBHUpdInfoLabel + | otherwise = mkUpdInfoLabel + + pushUpdateFrame [CmmReg (CmmLocal node), mkLblExpr lbl] body | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -575,7 +577,7 @@ setupUpdate closure_info node body then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf True ; pushUpdateFrame [CmmReg (CmmLocal upd_closure), - mkLblExpr mkUpdInfoLabel] body } -- XXX black hole + mkLblExpr mkBHUpdInfoLabel] body } else do {tickyUpdateFrameOmitted; body} } @@ -679,13 +681,14 @@ link_caf _is_upd = do -- name of the data constructor itself. Otherwise it is determined by -- @closureDescription@ from the let binding information. -closureDescription :: Module -- Module +closureDescription :: DynFlags + -> Module -- Module -> Name -- Id of closure binding -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.lhs with a description generated from the data constructor -closureDescription mod_name name - = showSDocDump (char '<' <> +closureDescription dflags mod_name name + = showSDocDump dflags (char '<' <> (if isExternalName name then ppr name -- ppr will include the module name prefix else pprModule mod_name <> char '.' <> ppr name) <> diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 487c94daaa..8023abddec 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -21,8 +21,8 @@ module StgCmmClosure ( DynTag, tagForCon, isSmallFamily, ConTagZ, dataConTagZ, - isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, + idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, + argPrimRep, -- * LambdaFormInfo LambdaFormInfo, -- Abstract @@ -87,9 +87,9 @@ import TcType import TyCon import BasicTypes import Outputable -import Platform import Constants import DynFlags +import Util ----------------------------------------------------------------------------- -- Representations @@ -97,6 +97,10 @@ import DynFlags -- Why are these here? +-- NB: this is reliable because by StgCmm no Ids have unboxed tuple type +idPrimRep :: Id -> PrimRep +idPrimRep id = typePrimRep (idType id) + addIdReps :: [Id] -> [(PrimRep, Id)] addIdReps ids = [(idPrimRep id, id) | id <- ids] @@ -127,7 +131,7 @@ isGcPtrRep _ = False data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity. Invariant: always > 0 + !RepArity -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should really be in ClosureInfo) @@ -188,7 +192,7 @@ data StandardFormInfo -- The code for the thunk just pushes x2..xn on the stack and enters x1. -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled -- in the RTS to save space. - Int -- Arity, n + RepArity -- Arity, n ------------------------------------------------------ @@ -231,9 +235,12 @@ might_be_a_function :: Type -> Bool -- Return False only if we are *sure* it's a data type -- Look through newtypes etc as much as poss might_be_a_function ty - = case tyConAppTyCon_maybe (repType ty) of - Just tc -> not (isDataTyCon tc) - Nothing -> True + | UnaryRep rep <- repType ty + , Just tc <- tyConAppTyCon_maybe rep + , isDataTyCon tc + = False + | otherwise + = True ------------- mkConLFInfo :: DataCon -> LambdaFormInfo @@ -266,7 +273,7 @@ mkLFImported id | otherwise = mkLFArgument id -- Not sure of exact arity where - arity = idArity id + arity = idRepArity id ------------ mkLFBlackHole :: LambdaFormInfo @@ -309,7 +316,7 @@ tagForCon con con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) -tagForArity :: Int -> DynTag +tagForArity :: RepArity -> DynTag tagForArity arity | isSmallFamily arity = arity | otherwise = 0 @@ -458,17 +465,17 @@ data CallMethod | DirectEntry -- Jump directly, with args in regs CLabel -- The code label - Int -- Its arity + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? -> LambdaFormInfo -- Its info - -> Int -- Number of available arguments + -> RepArity -- Number of available arguments -> CallMethod -getCallMethod _ _name _ lf_info _n_args - | nodeMustPointToIt lf_info && opt_Parallel +getCallMethod dflags _name _ lf_info _n_args + | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. @@ -717,7 +724,7 @@ blackHoleOnEntry cl_info = case closureLFInfo cl_info of LFReEntrant _ _ _ _ -> False LFLetNoEscape -> False - LFThunk _ no_fvs _updatable _ _ -> not no_fvs -- to plug space-leaks. + LFThunk _ _no_fvs _updatable _ _ -> True _other -> panic "blackHoleOnEntry" -- Should never happen isStaticClosure :: ClosureInfo -> Bool @@ -741,10 +748,10 @@ closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True closureReEntrant _ = False -closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) +closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info -lfFunInfo :: LambdaFormInfo -> Maybe (Int, ArgDescr) +lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing @@ -762,19 +769,19 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) -- Label generation -------------------------------------- -staticClosureLabel :: Platform -> ClosureInfo -> CLabel -staticClosureLabel platform = toClosureLbl platform . closureInfoLabel +staticClosureLabel :: ClosureInfo -> CLabel +staticClosureLabel = toClosureLbl . closureInfoLabel -closureRednCountsLabel :: Platform -> ClosureInfo -> CLabel -closureRednCountsLabel platform = toRednCountsLbl platform . closureInfoLabel +closureRednCountsLabel :: ClosureInfo -> CLabel +closureRednCountsLabel = toRednCountsLbl . closureInfoLabel -closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel -closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel +closureSlowEntryLabel :: ClosureInfo -> CLabel +closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel -closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel -closureLocalEntryLabel platform - | tablesNextToCode = toInfoLbl platform . closureInfoLabel - | otherwise = toEntryLbl platform . closureInfoLabel +closureLocalEntryLabel :: ClosureInfo -> CLabel +closureLocalEntryLabel + | tablesNextToCode = toInfoLbl . closureInfoLabel + | otherwise = toEntryLbl . closureInfoLabel mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel id lf_info @@ -861,11 +868,18 @@ getTyDescription ty FunTy _ res -> '-' : '>' : fun_result res TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty + LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res fun_result other = getTyDescription other +getTyLitDescription :: TyLit -> String +getTyLitDescription l = + case l of + NumTyLit n -> show n + StrTyLit n -> show n + -------------------------------------- -- CmmInfoTable-related things -------------------------------------- diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 1a40a4273f..c348570a54 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -41,7 +41,7 @@ import PrelInfo import Outputable import Platform import StaticFlags -import Util ( lengthIs ) +import Util import Control.Monad import Data.Char @@ -62,7 +62,7 @@ cgTopRhsCon id con args ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. ASSERT( not (isDllConApp dflags con args) ) return () - ; ASSERT( args `lengthIs` dataConRepArity con ) return () + ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT ; let diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 3b56e2feb6..2edd09da12 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -201,7 +201,6 @@ getArgAmode :: NonVoid StgArg -> FCode CmmExpr getArgAmode (NonVoid (StgVarArg var)) = do { info <- getCgIdInfo var; return (idInfoToAmode info) } getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit -getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg" getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index e682af0ced..4db1dffdfc 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -590,7 +590,7 @@ cgConApp con stg_args ; emitReturn arg_exprs } | otherwise -- Boxed constructors; allocate and return - = ASSERT( stg_args `lengthIs` dataConRepArity con ) + = ASSERT( stg_args `lengthIs` dataConRepRepArity con ) do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args -- The first "con" says that the name bound to this closure is -- is "con", which is a bit of a fudge, but it only affects profiling diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index d5c9600b38..c67e0e0c95 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -58,7 +58,9 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of - StaticTarget lbl mPkgId + StaticTarget _ _ False -> + panic "cgForeignCall: unexpected FFI value import" + StaticTarget lbl mPkgId True -> let labelSource = case mPkgId of Nothing -> ForeignLabelInThisPackage @@ -390,5 +392,6 @@ add_shim arg_ty expr | otherwise = expr where - tycon = tyConAppTyCon (repType arg_ty) + UnaryRep rep_ty = repType arg_ty + tycon = tyConAppTyCon rep_ty -- should be a tycon app, since this is a foreign call diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs index 232c7c6b58..2abca3fe16 100644 --- a/compiler/codeGen/StgCmmGran.hs +++ b/compiler/codeGen/StgCmmGran.hs @@ -3,22 +3,15 @@ -- (c) The University of Glasgow -2006 -- -- Code generation relaed to GpH --- (a) parallel --- (b) GranSim +-- (a) parallel +-- (b) GranSim -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module StgCmmGran ( - staticGranHdr,staticParHdr, - granThunk, granYield, - doGranAllocate + staticGranHdr,staticParHdr, + granThunk, granYield, + doGranAllocate ) where -- This entire module consists of no-op stubs at the moment @@ -57,11 +50,11 @@ staticGranHdr :: [CmmLit] -- Gransim header words in a static closure staticGranHdr = [] -doGranAllocate :: CmmExpr -> Code +doGranAllocate :: CmmExpr -> Code -- macro DO_GRAN_ALLOCATE -doGranAllocate hp +doGranAllocate hp | not opt_GranMacros = nopC - | otherwise = panic "doGranAllocate" + | otherwise = panic "doGranAllocate" @@ -69,13 +62,13 @@ doGranAllocate hp granThunk :: Bool -> FCode () -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node -- (we prefer fetchAndReschedule-style context switches to yield ones) -granThunk node_points - | node_points = granFetchAndReschedule [] node_points - | otherwise = granYield [] node_points +granThunk node_points + | node_points = granFetchAndReschedule [] node_points + | otherwise = granYield [] node_points granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code + -> Bool -- Node reqd? + -> Code -- Emit code for simulating a fetch and then reschedule. granFetchAndReschedule regs node_reqd | opt_GranMacros && (node `elem` map snd regs || node_reqd) @@ -87,15 +80,15 @@ granFetchAndReschedule regs node_reqd liveness = mkRegLiveness regs 0 0 fetch = panic "granFetch" - -- Was: absC (CMacroStmt GRAN_FETCH []) - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai + -- Was: absC (CMacroStmt GRAN_FETCH []) + --HWL: generate GRAN_FETCH macro for GrAnSim + -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai reschedule liveness node_reqd = panic "granReschedule" - -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ - -- mkIntCLit (I# (word2Int# liveness_mask)), - -- mkIntCLit (if node_reqd then 1 else 0)]) - + -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ + -- mkIntCLit (I# (word2Int# liveness_mask)), + -- mkIntCLit (if node_reqd then 1 else 0)]) + ------------------------- -- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It @@ -103,25 +96,25 @@ reschedule liveness node_reqd = panic "granReschedule" -- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit -- this kind of macro at the beginning of the following kinds of basic bocks: -- \begin{itemize} --- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally +-- \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally -- we use @fetchAndReschedule@ at a slow entry code. -- \item Fast entry code (see @CgClosure.lhs@). -- \item Alternatives in case expressions (@CLabelledCode@ structures), provided --- that they are not inlined (see @CgCases.lhs@). These alternatives will +-- that they are not inlined (see @CgCases.lhs@). These alternatives will -- be turned into separate functions. granYield :: [(Id,GlobalReg)] -- Live registers -> Bool -- Node reqd? - -> Code + -> Code granYield regs node_reqd | opt_GranMacros && node_reqd = yield liveness - | otherwise = nopC + | otherwise = nopC where liveness = mkRegLiveness regs 0 0 yield liveness = panic "granYield" - -- Was : absC (CMacroStmt GRAN_YIELD + -- Was : absC (CMacroStmt GRAN_YIELD -- [mkIntCLit (I# (word2Int# liveness_mask))]) -} diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 37dc467862..856b04367d 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -43,7 +43,7 @@ import IdInfo( CafInfo(..), mayHaveCafRefs ) import Module import FastString( mkFastString, fsLit ) import Constants -import DynFlags +import Util ----------------------------------------------------------- -- Initialise dynamic heap objects @@ -331,11 +331,7 @@ entryHeapCheck :: ClosureInfo -> FCode () entryHeapCheck cl_info offset nodeSet arity args code - = do dflags <- getDynFlags - - let platform = targetPlatform dflags - - is_thunk = arity == 0 + = do let is_thunk = arity == 0 is_fastf = case closureFunInfo cl_info of Just (_, ArgGen _) -> False _otherwise -> True @@ -345,7 +341,7 @@ entryHeapCheck cl_info offset nodeSet arity args code Just n -> mkNop -- No need to assign R1, it already -- points to the closure Nothing -> mkAssign nodeReg $ - CmmLit (CmmLabel $ staticClosureLabel platform cl_info) + CmmLit (CmmLabel $ staticClosureLabel cl_info) {- Thunks: jump GCEnter1 Function (fast): Set R1 = node, jump GCFun diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 16b33d1faf..9593af1f50 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -52,8 +52,7 @@ import StgSyn import Id import Name import TyCon ( PrimRep(..) ) -import BasicTypes ( Arity ) -import DynFlags +import BasicTypes ( RepArity ) import StaticFlags import Module @@ -61,7 +60,7 @@ import Constants import Util import Data.List import Outputable -import FastString ( mkFastString, FastString, fsLit ) +import FastString ------------------------------------------------------------------------ -- Call and return sequences @@ -166,7 +165,7 @@ adjustHpBackwards -- call f() return to Nothing updfr_off: 32 -directCall :: CLabel -> Arity -> [StgArg] -> FCode () +directCall :: CLabel -> RepArity -> [StgArg] -> FCode () -- (directCall f n args) -- calls f(arg1, ..., argn), and applies the result to the remaining args -- The function f has arity n, and there are guaranteed at least n args @@ -182,27 +181,24 @@ slowCall fun stg_args = do { dflags <- getDynFlags ; argsreps <- getArgRepsAmodes stg_args ; let (rts_fun, arity) = slowCallPattern (map fst argsreps) - ; let platform = targetPlatform dflags ; call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity argsreps ; emitComment $ mkFastString ("slow_call for " ++ - showSDoc (pprPlatform platform fun) ++ - " with pat " ++ showSDoc (ftext rts_fun)) + showSDoc dflags (ppr fun) ++ + " with pat " ++ unpackFS rts_fun) ; emit (mkAssign nodeReg fun <*> call) } -------------- -direct_call :: String -> CLabel -> Arity -> [(ArgRep,Maybe CmmExpr)] -> FCode () +direct_call :: String -> CLabel -> RepArity -> [(ArgRep,Maybe CmmExpr)] -> FCode () direct_call caller lbl arity args | debugIsOn && arity > length args -- Too few args = do -- Caller should ensure that there enough args! - dflags <- getDynFlags - let platform = targetPlatform dflags pprPanic "direct_call" $ text caller <+> ppr arity <+> - pprPlatform platform lbl <+> ppr (length args) <+> - pprPlatform platform (map snd args) <+> ppr (map fst args) + ppr lbl <+> ppr (length args) <+> + ppr (map snd args) <+> ppr (map fst args) | null rest_args -- Precisely the right number of arguments = emitCall (NativeDirectCall, NativeReturn) target (nonVArgs args) @@ -289,7 +285,7 @@ slowArgs args -- careful: reps contains voids (V), but args does not -- These cases were found to cover about 99% of all slow calls: -slowCallPattern :: [ArgRep] -> (FastString, Arity) +slowCallPattern :: [ArgRep] -> (FastString, RepArity) -- Returns the generic apply function and arity slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6) slowCallPattern (P: P: P: P: P: _) = (fsLit "stg_ap_ppppp", 5) @@ -532,9 +528,8 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body emitClosureAndInfoTable :: CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode () emitClosureAndInfoTable info_tbl conv args body - = do { dflags <- getDynFlags - ; blks <- getCode body - ; let entry_lbl = toEntryLbl (targetPlatform dflags) (cit_lbl info_tbl) + = do { blks <- getCode body + ; let entry_lbl = toEntryLbl (cit_lbl info_tbl) ; emitProcWithConvention conv info_tbl entry_lbl args blks } diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 240469c3f2..cc9919a4a0 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -203,13 +203,13 @@ data CgLoc -- To tail-call it, assign to these locals, -- and branch to the block id -instance PlatformOutputable CgIdInfo where - pprPlatform platform (CgIdInfo { cg_id = id, cg_loc = loc }) - = ppr id <+> ptext (sLit "-->") <+> pprPlatform platform loc +instance Outputable CgIdInfo where + ppr (CgIdInfo { cg_id = id, cg_loc = loc }) + = ppr id <+> ptext (sLit "-->") <+> ppr loc -instance PlatformOutputable CgLoc where - pprPlatform platform (CmmLoc e) = ptext (sLit "cmm") <+> pprPlatform platform e - pprPlatform _ (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs +instance Outputable CgLoc where + ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e + ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs -- Sequel tells what to do with the result of this expression diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 9f87271fba..bd783a3b30 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -45,6 +45,7 @@ import Module import FastString import Outputable import StaticFlags +import Util ------------------------------------------------------------------------ -- Primitive operations and foreign calls @@ -475,11 +476,13 @@ emitPrimOp res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_Wor emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args --- Copying byte arrays +-- Copying and setting byte arrays emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = doCopyByteArrayOp src src_off dst dst_off n emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableByteArrayOp src src_off dst dst_off n +emitPrimOp [] SetByteArrayOp [ba,off,len,c] = + doSetByteArrayOp ba off len c -- Population count emitPrimOp [res] PopCnt8Op [w] = emitPopCntCall res w W8 @@ -811,6 +814,18 @@ emitCopyByteArray copy src src_off dst dst_off n = do copy src dst dst_p src_p n -- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- character. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetByteArrayOp ba off len c + = do p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off + emitMemsetCall p c len (CmmLit (mkIntCLit 1)) + +-- ---------------------------------------------------------------------------- -- Copying pointer arrays -- EZY: This code has an unusually high amount of assignTemp calls, seen diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index c147708cef..9ff4d0be07 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -218,7 +218,8 @@ emitCostCentreDecl cc = do ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS $ Module.moduleName $ cc_mod cc) - ; loc <- newStringCLit (showSDoc (ppr (costCentreSrcSpan cc))) + ; dflags <- getDynFlags + ; loc <- newStringCLit (showPpr dflags (costCentreSrcSpan cc)) -- XXX should UTF-8 encode -- All cost centres will be in the main package, since we -- don't normally use -auto-all or add SCCs to other packages. diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index ea74a03e1e..698bf32709 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -97,10 +97,9 @@ emitTickyCounter cl_info args = ifTicky $ do { dflags <- getDynFlags ; mod_name <- getModuleName - ; let platform = targetPlatform dflags - ticky_ctr_label = closureRednCountsLabel platform cl_info + ; let ticky_ctr_label = closureRednCountsLabel cl_info arg_descr = map (showTypeCategory . idType) args - fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info) + fun_descr mod_name = ppr_for_ticky_name dflags mod_name (closureName cl_info) ; fun_descr_lit <- newStringCLit (fun_descr mod_name) ; arg_descr_lit <- newStringCLit arg_descr ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter @@ -120,10 +119,10 @@ emitTickyCounter cl_info args -- When printing the name of a thing in a ticky file, we want to -- give the module name even for *local* things. We print -- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name :: Module -> Name -> String -ppr_for_ticky_name mod_name name - | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug (ppr name) +ppr_for_ticky_name :: DynFlags -> Module -> Name -> String +ppr_for_ticky_name dflags mod_name name + | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name))) + | otherwise = showSDocDebug dflags (ppr name) -- ----------------------------------------------------------------------------- -- Ticky stack frames @@ -197,7 +196,7 @@ registerTickyCtr ctr_lbl (CmmLit (mkIntCLit 1)) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) -tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode () +tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") ; bumpHistogram (fsLit "RET_OLD_hst") arity } @@ -205,7 +204,7 @@ tickyReturnNewCon arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") ; bumpHistogram (fsLit "RET_NEW_hst") arity } -tickyUnboxedTupleReturn :: Int -> FCode () +tickyUnboxedTupleReturn :: RepArity -> FCode () tickyUnboxedTupleReturn arity = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } @@ -219,7 +218,7 @@ tickyVectoredReturn family_size -- Ticky calls -- Ticks at a *call site*: -tickyDirectCall :: Arity -> [StgArg] -> FCode () +tickyDirectCall :: RepArity -> [StgArg] -> FCode () tickyDirectCall arity args | arity == length args = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 246d57cda9..7609cfe38d 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -79,6 +79,8 @@ import FastString import Outputable import Data.Char +import Data.List +import Data.Ord import Data.Word import Data.Maybe @@ -458,7 +460,7 @@ newUnboxedTupleRegs res_ty ; ASSERT( regs `equalLength` reps ) return (regs, map primRepForeignHint reps) } where - ty_args = tyConAppArgs (repType res_ty) + UbxTupleRep ty_args = repType res_ty reps = [ rep | ty <- ty_args , let rep = typePrimRep ty @@ -573,16 +575,13 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do branches_lbls <- label_branches join_lbl branches tag_expr' <- assignTemp' tag_expr - emit =<< mk_switch tag_expr' (sortLe le branches_lbls) mb_deflt_lbl + emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches) mb_deflt_lbl lo_tag hi_tag via_C -- Sort the branches before calling mk_switch emitLabel join_lbl - where - (t1,_) `le` (t2,_) = t1 <= t2 - mk_switch :: CmmExpr -> [(ConTagZ, BlockId)] -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool @@ -736,10 +735,9 @@ emitCmmLitSwitch scrut branches deflt = do join_lbl <- newLabelC deflt_lbl <- label_code join_lbl deflt branches_lbls <- label_branches join_lbl branches - emit =<< mk_lit_switch scrut' deflt_lbl (sortLe le branches_lbls) + emit =<< mk_lit_switch scrut' deflt_lbl + (sortBy (comparing fst) branches_lbls) emitLabel join_lbl - where - le (t1,_) (t2,_) = t1 <= t2 mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,BlockId)] |