From: Isaac Dupree Date: Fri, 4 Jan 2008 10:53:39 +0000 (+0000) Subject: change CmmActual, CmmFormal to use a data CmmHinted rather than tuple (#1405) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d76b6a05ab36066e8aeb67d58e25992d1ef83a8a change CmmActual, CmmFormal to use a data CmmHinted rather than tuple (#1405) This allows the instance of UserOfLocalRegs to be within Haskell98, and IMHO makes the code a little cleaner generally. This is one small (though tedious) step towards making GHC's code more portable... --- diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 790d072..3fd5e44 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -18,6 +18,7 @@ module Cmm ( CmmReturnInfo(..), CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, CmmKind, CmmFormalsWithoutKinds, CmmFormalWithoutKind, + CmmHinted(..), CmmSafety(..), CmmCallTarget(..), CmmStatic(..), Section(..), @@ -240,8 +241,10 @@ data CmmStmt CmmActuals -- with these return values. type CmmKind = MachHint -type CmmActual = (CmmExpr, CmmKind) -type CmmFormal = (LocalReg,CmmKind) +data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: CmmKind } + deriving (Eq) +type CmmActual = CmmHinted CmmExpr +type CmmFormal = CmmHinted LocalReg type CmmActuals = [CmmActual] type CmmFormals = [CmmFormal] type CmmFormalWithoutKind = LocalReg @@ -250,8 +253,8 @@ type CmmFormalsWithoutKinds = [CmmFormalWithoutKind] data CmmSafety = CmmUnsafe | CmmSafe C_SRT -- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals' -instance UserOfLocalRegs a => UserOfLocalRegs (a, CmmKind) where - foldRegsUsed f set (a, _) = foldRegsUsed f set a +instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where + foldRegsUsed f set (CmmHinted a _) = foldRegsUsed f set a instance UserOfLocalRegs CmmStmt where foldRegsUsed f set s = stmt s set @@ -271,6 +274,11 @@ instance UserOfLocalRegs CmmCallTarget where foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e foldRegsUsed _ set (CmmPrim {}) = set +--just look like a tuple, since it was a tuple before +-- ... is that a good idea? --Isaac Dupree +instance (Outputable a) => Outputable (CmmHinted a) where + ppr (CmmHinted a k) = ppr (a, k) + {- Discussion ~~~~~~~~~~ diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs index 98a6c3b..20a4a8c 100644 --- a/compiler/cmm/CmmBrokenBlock.hs +++ b/compiler/cmm/CmmBrokenBlock.hs @@ -348,7 +348,7 @@ makeContinuationEntries formats case lookup ident formats of Nothing -> block Just (ContFormat formals srt is_gc) -> - BrokenBlock ident (ContinuationEntry (map fst formals) srt is_gc) + BrokenBlock ident (ContinuationEntry (map hintlessCmm formals) srt is_gc) stmts targets exit adaptBlockToFormat :: [(BlockId, ContFormat)] @@ -378,7 +378,7 @@ adaptBlockToFormat formats unique target formals actuals srt ret is_gc adaptor_block = mk_adaptor_block adaptor_ident - (ContinuationEntry (map fst formals) srt is_gc) + (ContinuationEntry (map hintlessCmm formals) srt is_gc) next format_formals adaptor_ident = BlockId unique @@ -390,7 +390,8 @@ adaptBlockToFormat formats unique (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next)))) (map formal_to_actual format_formals) - formal_to_actual (reg, hint) = ((CmmReg (CmmLocal reg)), hint) + formal_to_actual (CmmHinted reg hint) + = (CmmHinted (CmmReg (CmmLocal reg)) hint) -- TODO: Check if NoHint is right. We're -- jumping to a C-- function not a foreign one -- so it might always be right. diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 25f30a8..5a79981 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -359,14 +359,14 @@ continuationMaxStack formats (Continuation _ label _ False blocks) = map stmt_arg_size (brokenBlockStmts block)) final_arg_size (FinalReturn args) = - argumentsSize (cmmExprRep . fst) args + argumentsSize (cmmExprRep . hintlessCmm) args final_arg_size (FinalJump _ args) = - argumentsSize (cmmExprRep . fst) args + argumentsSize (cmmExprRep . hintlessCmm) args final_arg_size (FinalCall next _ _ args _ _ True) = 0 final_arg_size (FinalCall next _ _ args _ _ False) = -- We have to account for the stack used when we build a frame -- for the *next* continuation from *this* continuation - argumentsSize (cmmExprRep . fst) args + + argumentsSize (cmmExprRep . hintlessCmm) args + continuation_frame_size next_format where next_format = maybe unknown_format id $ lookup next' formats @@ -375,7 +375,7 @@ continuationMaxStack formats (Continuation _ label _ False blocks) = final_arg_size _ = 0 stmt_arg_size (CmmJump _ args) = - argumentsSize (cmmExprRep . fst) args + argumentsSize (cmmExprRep . hintlessCmm) args stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) = panic "Safe call in processFormats" stmt_arg_size (CmmReturn _) = diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs index 94d4b7b..55a7397 100644 --- a/compiler/cmm/CmmCPSGen.hs +++ b/compiler/cmm/CmmCPSGen.hs @@ -228,7 +228,7 @@ continuationToProc (max_stack, update_frame_size, formats) stack_use uniques foreignCall call_uniques (CmmPrim target) results arguments -formal_to_actual reg = (CmmReg (CmmLocal reg), NoHint) +formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint foreignCall :: [Unique] -> CmmCallTarget -> CmmFormals -> CmmActuals -> [CmmStmt] foreignCall uniques call results arguments = @@ -236,14 +236,14 @@ foreignCall uniques call results arguments = saveThreadState ++ caller_save ++ [CmmCall (CmmCallee suspendThread CCallConv) - [ (id,PtrHint) ] - [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] + [ CmmHinted id PtrHint ] + [ CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint ] CmmUnsafe CmmMayReturn, CmmCall call results new_args CmmUnsafe CmmMayReturn, CmmCall (CmmCallee resumeThread CCallConv) - [ (new_base, PtrHint) ] - [ (CmmReg (CmmLocal id), PtrHint) ] + [ CmmHinted new_base PtrHint ] + [ CmmHinted (CmmReg (CmmLocal id)) PtrHint ] CmmUnsafe CmmMayReturn, -- Assign the result to BaseReg: we @@ -251,7 +251,7 @@ foreignCall uniques call results arguments = CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++ caller_load ++ loadThreadState tso_unique ++ - [CmmJump (CmmReg spReg) (map (formal_to_actual . fst) results)] + [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)] where (_, arg_stmts, new_args) = loadArgsIntoTemps argument_uniques arguments @@ -363,12 +363,12 @@ tail_call spRel target arguments = store_arguments ++ adjust_sp_reg spRel ++ jump where store_arguments = [stack_put spRel expr offset - | ((expr, _), StackParam offset) <- argument_formats] ++ + | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++ [global_put expr global - | ((expr, _), RegisterParam global) <- argument_formats] + | ((CmmHinted expr _), RegisterParam global) <- argument_formats] jump = [CmmJump target arguments] - argument_formats = assignArguments (cmmExprRep . fst) arguments + argument_formats = assignArguments (cmmExprRep . hintlessCmm) arguments adjust_sp_reg spRel = if spRel == 0 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index b1922d0..e376e56 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -137,7 +137,7 @@ lintCmmStmt labels = lint lintCmmExpr r return () lint (CmmCall target _res args _ _) = - lintTarget target >> mapM_ (lintCmmExpr.fst) args + lintTarget target >> mapM_ (lintCmmExpr . hintlessCmm) args lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches @@ -145,8 +145,8 @@ lintCmmStmt labels = lint if (erep == wordRep) then return () else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e) - lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr.fst) args - lint (CmmReturn ress) = mapM_ (lintCmmExpr.fst) ress + lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args + lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress lint (CmmBranch id) = checkTarget id checkTarget id = if elemBlockSet id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index 4450192..f9973de 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -164,7 +164,7 @@ addKilled new_killed live = live `minusUniqSet` new_killed -- Liveness of a CmmStmt -------------------------------- cmmFormalsToLiveLocals :: CmmFormals -> [LocalReg] -cmmFormalsToLiveLocals formals = map fst formals +cmmFormalsToLiveLocals formals = map hintlessCmm formals cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer cmmStmtLive _ (CmmNop) = id @@ -179,7 +179,7 @@ cmmStmtLive _ (CmmStore expr1 expr2) = cmmExprLive expr2 . cmmExprLive expr1 cmmStmtLive _ (CmmCall target results arguments _ _) = target_liveness . - foldr ((.) . cmmExprLive) id (map fst arguments) . + foldr ((.) . cmmExprLive) id (map hintlessCmm arguments) . addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where target_liveness = case target of @@ -197,9 +197,9 @@ cmmStmtLive other_live (CmmSwitch expr targets) = id (mapCatMaybes id targets)) cmmStmtLive _ (CmmJump expr params) = - const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet) + const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet) cmmStmtLive _ (CmmReturn params) = - const (foldr ((.) . cmmExprLive) id (map fst params) $ emptyUniqSet) + const (foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet) -------------------------------- -- Liveness of a CmmExpr diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index b96aa4a..c906050 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -156,7 +156,7 @@ inlineStmt u a (CmmCall target regs es srt ret) = CmmCall (infn target) regs es' srt ret where infn (CmmCallee fn cconv) = CmmCallee fn cconv infn (CmmPrim p) = CmmPrim p - es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ] + es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 2d74aee..70cd7c4 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -470,10 +470,10 @@ cmm_kind_exprs :: { [ExtFCode CmmActual] } | cmm_kind_expr ',' cmm_kind_exprs { $1 : $3 } cmm_kind_expr :: { ExtFCode CmmActual } - : expr { do e <- $1; return (e, inferCmmKind e) } + : expr { do e <- $1; return (CmmHinted e (inferCmmKind e)) } | expr STRING {% do h <- parseCmmKind $2; return $ do - e <- $1; return (e,h) } + e <- $1; return (CmmHinted e h) } exprs0 :: { [ExtFCode CmmExpr] } : {- empty -} { [] } @@ -497,10 +497,10 @@ cmm_formals :: { [ExtFCode CmmFormal] } | cmm_formal ',' cmm_formals { $1 : $3 } cmm_formal :: { ExtFCode CmmFormal } - : local_lreg { do e <- $1; return (e, inferCmmKind (CmmReg (CmmLocal e))) } + : local_lreg { do e <- $1; return (CmmHinted e (inferCmmKind (CmmReg (CmmLocal e)))) } | STRING local_lreg {% do h <- parseCmmKind $1; return $ do - e <- $2; return (e,h) } + e <- $2; return (CmmHinted e h) } local_lreg :: { ExtFCode LocalReg } : NAME { do e <- lookupName $1; @@ -921,13 +921,13 @@ foreignCall conv_string results_code expr_code args_code vols safety ret (CmmCallee expr' convention) args vols NoC_SRT ret) where unused = panic "not used by emitForeignCall'" -adjCallTarget :: CCallConv -> CmmExpr -> [(CmmExpr,MachHint)] -> CmmExpr +adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr #ifdef mingw32_TARGET_OS -- On Windows, we have to add the '@N' suffix to the label when making -- a call with the stdcall calling convention. adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (e,_) = max wORD_SIZE (machRepByteWidth (cmmExprRep e)) + where size (CmmHinted e _) = max wORD_SIZE (machRepByteWidth (cmmExprRep e)) -- c.f. CgForeignCall.emitForeignCall #endif adjCallTarget _ expr _ diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index b2dbd87..059b5f2 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -256,7 +256,7 @@ addProcPointProtocols procPoints formals g = maybe_add_proto (Block id _) env | id == lg_entry g = extendBlockEnv env id (Protocol stdArgConvention hinted_formals) maybe_add_proto _ env = env - hinted_formals = map (\x -> (x, NoHint)) formals + hinted_formals = map (\x -> CmmHinted x NoHint) formals stdArgConvention = ConventionStandard CmmCallConv Arguments -- | For now, following a suggestion by Ben Lippmeier, we pass all @@ -279,7 +279,7 @@ pass_live_vars_as_args procPoints (protos, g) = (protos', g') Nothing -> let live = lookupBlockEnv liveness id `orElse` emptyRegSet -- XXX there's a bug lurking! -- panic ("no liveness at block " ++ show id) - formals = map (\x->(x,NoHint)) $ uniqSetToList live + formals = map (\x -> CmmHinted x NoHint) $ uniqSetToList live in extendBlockEnv protos id (Protocol ConventionPrivate formals) g' = g { lg_blocks = add_CopyIns protos' (lg_blocks g) } diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 68c2eda..675d44b 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -196,10 +196,10 @@ loadArgsIntoTemps :: [Unique] -> CmmActuals -> ([Unique], [CmmStmt], CmmActuals) loadArgsIntoTemps uniques [] = (uniques, [], []) -loadArgsIntoTemps uniques ((e, hint):args) = +loadArgsIntoTemps uniques ((CmmHinted e hint):args) = (uniques'', new_stmts ++ remaining_stmts, - (new_e, hint) : remaining_e) + (CmmHinted new_e hint) : remaining_e) where (uniques', new_stmts, new_e) = maybeAssignTemp uniques e (uniques'', remaining_stmts, remaining_e) = diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index c7d0cf1..ec70d04 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -245,9 +245,9 @@ pprCFunType cconv ress args ] where res_type [] = ptext SLIT("void") - res_type [(one,hint)] = machRepHintCType (localRegRep one) hint + res_type [CmmHinted one hint] = machRepHintCType (localRegRep one) hint - arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint + arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprRep expr) hint -- --------------------------------------------------------------------- -- unconditional branches @@ -755,17 +755,17 @@ pprCall ppr_fn cconv results args _ ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where ppr_assign [] rhs = rhs - ppr_assign [(one,hint)] rhs + ppr_assign [CmmHinted one hint] rhs = pprLocalReg one <> ptext SLIT(" = ") <> pprUnHint hint (localRegRep one) <> rhs ppr_assign _other _rhs = panic "pprCall: multiple results" - pprArg (expr, PtrHint) + pprArg (CmmHinted expr PtrHint) = cCast (ptext SLIT("void *")) expr -- see comment by machRepHintCType below - pprArg (expr, SignedHint) + pprArg (CmmHinted expr SignedHint) = cCast (machRepSignedCType (cmmExprRep expr)) expr - pprArg (expr, _other) + pprArg (CmmHinted expr _other) = pprExpr expr pprUnHint PtrHint rep = parens (machRepCType rep) @@ -849,8 +849,8 @@ te_Lit _ = return () te_Stmt :: CmmStmt -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r -te_Stmt (CmmCall _ rs es _ _) = mapM_ (te_temp.fst) rs >> - mapM_ (te_Expr.fst) es +te_Stmt (CmmCall _ rs es _ _) = mapM_ (te_temp.hintlessCmm) rs >> + mapM_ (te_Expr.hintlessCmm) es te_Stmt (CmmCondBranch e _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e te_Stmt (CmmJump e _) = te_Expr e diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 2aca16e..43f3935 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -284,7 +284,7 @@ genCondBranch expr ident = -- -- jump foo(a, b, c); -- -genJump :: CmmExpr -> [(CmmExpr, MachHint)] -> SDoc +genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc genJump expr args = hcat [ ptext SLIT("jump") @@ -298,18 +298,18 @@ genJump expr args = , parens ( commafy $ map pprHinted args ) , semi ] -pprHinted :: Outputable a => (a, MachHint) -> SDoc -pprHinted (a, NoHint) = ppr a -pprHinted (a, PtrHint) = quotes(text "address") <+> ppr a -pprHinted (a, SignedHint) = quotes(text "signed") <+> ppr a -pprHinted (a, FloatHint) = quotes(text "float") <+> ppr a +pprHinted :: Outputable a => (CmmHinted a) -> SDoc +pprHinted (CmmHinted a NoHint) = ppr a +pprHinted (CmmHinted a PtrHint) = quotes(text "address") <+> ppr a +pprHinted (CmmHinted a SignedHint) = quotes(text "signed") <+> ppr a +pprHinted (CmmHinted a FloatHint) = quotes(text "float") <+> ppr a -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 -- -- return (a, b, c); -- -genReturn :: [(CmmExpr, MachHint)] -> SDoc +genReturn :: [CmmHinted CmmExpr] -> SDoc genReturn args = hcat [ ptext SLIT("return") diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 0667b7e..8c1b461 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -15,7 +15,7 @@ where import CmmExpr import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmCallTarget(..), CmmActuals, CmmFormals + , CmmCallTarget(..), CmmActuals, CmmFormals, CmmHinted(..) , CmmStmt(CmmSwitch) -- imported in order to call ppr ) import PprCmm() @@ -262,11 +262,11 @@ ppr_target t@(CmmLit _) = ppr t ppr_target fn' = parens (ppr fn') -pprHinted :: Outputable a => (a, MachHint) -> SDoc -pprHinted (a, NoHint) = ppr a -pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a -pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a -pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a +pprHinted :: Outputable a => CmmHinted a -> SDoc +pprHinted (CmmHinted a NoHint) = ppr a +pprHinted (CmmHinted a PtrHint) = doubleQuotes (text "address") <+> ppr a +pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a +pprHinted (CmmHinted a FloatHint) = doubleQuotes (text "float") <+> ppr a pprLast :: Last -> SDoc pprLast stmt = (case stmt of diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 398441e..beecceb 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -165,7 +165,7 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _) -- exactly like the cgInlinePrimOp case for unboxed tuple alts.. { res_tmps <- mapFCs bindNewToTemp non_void_res_ids ; let res_hints = map (typeHint.idType) non_void_res_ids - ; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts + ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts ; cgExpr rhs } where (_, res_ids, _, rhs) = head alts diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 499442f..b7360c8 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -560,7 +560,7 @@ link_caf cl_info is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] False + ; emitRtsCallWithVols SLIT("newCAF") [CmmHinted (CmmReg nodeReg) PtrHint] [node] False -- node is live, so save it. -- Overwrite the closure with a (static) indirection diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index bc91bef..3f1ec45 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -133,13 +133,13 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do then assignPtrTemp arg else assignNonPtrTemp arg | (arg, stg_arg) <- arg_exprs] - let arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args) + let arg_hints = zipWith CmmHinted arg_tmps (map (typeHint.stgArgType) stg_args) {- Now, allocate some result regs. -} (res_reps,res_regs,res_hints) <- newUnboxedTupleRegs res_ty ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $ - emitForeignCall (zip res_regs res_hints) fcall + emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall arg_hints emptyVarSet{-no live vars-} -- tagToEnum# is special: we need to pull the constructor out of the table, diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index fec1a8f..8e1be19 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -64,7 +64,8 @@ cgForeignCall results fcall stg_args live | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, nonVoidArg rep] - arg_hints = zip arg_exprs (map (typeHint.stgArgType) stg_args) + arg_hints = zipWith CmmHinted + arg_exprs (map (typeHint.stgArgType) stg_args) -- in emitForeignCall results fcall arg_hints live @@ -72,7 +73,7 @@ cgForeignCall results fcall stg_args live emitForeignCall :: CmmFormals -- where to put the results -> ForeignCall -- the op - -> [(CmmExpr,MachHint)] -- arguments + -> [CmmHinted CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them -> Code @@ -86,14 +87,14 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live = case target of StaticTarget lbl -> (args, CmmLit (CmmLabel (mkForeignLabel lbl call_size False))) - DynamicTarget -> case args of (fn,_):rest -> (rest, fn) + DynamicTarget -> case args of (CmmHinted fn _):rest -> (rest, fn) -- in the stdcall calling convention, the symbol needs @size appended -- to it, where size is the total number of bytes of arguments. We -- attach this info to the CLabel here, and the CLabel pretty printer -- will generate the suffix when the label is printed. call_size - | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.fst) args)) + | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprRep.hintlessCmm) args)) | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API @@ -108,7 +109,7 @@ emitForeignCall' :: Safety -> CmmFormals -- where to put the results -> CmmCallTarget -- the op - -> [(CmmExpr,MachHint)] -- arguments + -> [CmmHinted CmmExpr] -- arguments -> Maybe [GlobalReg] -- live vars, in case we need to save them -> C_SRT -- the SRT of the calls continuation -> CmmReturnInfo @@ -137,13 +138,13 @@ emitForeignCall' safety results target args vols srt ret -- and the CPS will will be the one to convert that -- to this sequence of three CmmUnsafe calls. stmtC (CmmCall (CmmCallee suspendThread CCallConv) - [ (id,PtrHint) ] - [ (CmmReg (CmmGlobal BaseReg), PtrHint) ] + [ CmmHinted id PtrHint ] + [ CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint ] CmmUnsafe ret) stmtC (CmmCall temp_target results temp_args CmmUnsafe ret) stmtC (CmmCall (CmmCallee resumeThread CCallConv) - [ (new_base, PtrHint) ] - [ (CmmReg (CmmLocal id), PtrHint) ] + [ CmmHinted new_base PtrHint ] + [ CmmHinted (CmmReg (CmmLocal id)) PtrHint ] CmmUnsafe ret) -- Assign the result to BaseReg: we -- might now have a different Capability! @@ -163,9 +164,9 @@ resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread"))) -- This is a HACK; really it should be done in the back end, but -- it's easier to generate the temporaries here. load_args_into_temps = mapM arg_assign_temp - where arg_assign_temp (e,hint) = do + where arg_assign_temp (CmmHinted e hint) = do tmp <- maybe_assign_temp e - return (tmp,hint) + return (CmmHinted tmp hint) load_target_into_temp (CmmCallee expr conv) = do tmp <- maybe_assign_temp expr diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 516a9c7..cb9c7ba 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -73,15 +73,15 @@ initHpc this_mod (HpcInfo tickCount hashNo) = do { id <- newNonPtrTemp wordRep -- TODO FIXME NOW ; emitForeignCall' PlayRisky - [(id,NoHint)] + [CmmHinted id NoHint] (CmmCallee (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False) CCallConv ) - [ (mkLblExpr mkHpcModuleNameLabel,PtrHint) - , (word32 tickCount, NoHint) - , (word32 hashNo, NoHint) - , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint) + [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) PtrHint + , CmmHinted (word32 tickCount) NoHint + , CmmHinted (word32 hashNo) NoHint + , CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) PtrHint ] (Just []) NoC_SRT -- No SRT b/c we PlayRisky diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index a73000c..c77e8e5 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -123,9 +123,10 @@ emitPrimOp [res] ParOp [arg] live -- later, we might want to inline it. vols <- getVolatileRegs live emitForeignCall' PlayRisky - [(res,NoHint)] + [CmmHinted res NoHint] (CmmCallee newspark CCallConv) - [(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)] + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint) + , (CmmHinted arg PtrHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn @@ -143,7 +144,8 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live [{-no results-}] (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) CCallConv) - [(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)] + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint) + , (CmmHinted mutv PtrHint) ] (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn @@ -348,9 +350,9 @@ emitPrimOp [res] op args live | Just prim <- callishOp op = do vols <- getVolatileRegs live emitForeignCall' PlayRisky - [(res,NoHint)] + [CmmHinted res NoHint] (CmmPrim prim) - [(a,NoHint) | a<-args] -- ToDo: hints? + [CmmHinted a NoHint | a<-args] -- ToDo: hints? (Just vols) NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 6fd6e01..c9b82a4 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -267,7 +267,7 @@ enterCostCentreThunk closure = ifProfiling $ do stmtC $ CmmStore curCCSAddr (costCentreFrom closure) -enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False +enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [CmmHinted stack PtrHint] False -- ToDo: vols enter_ccs_fsub = enteringPAP 0 @@ -415,8 +415,8 @@ emitSetCCC cc pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code pushCostCentre result ccs cc = emitRtsCallWithResult result PtrHint - SLIT("PushCostCentre") [(ccs,PtrHint), - (CmmLit (mkCCostCentre cc), PtrHint)] + SLIT("PushCostCentre") [CmmHinted ccs PtrHint, + CmmHinted (CmmLit (mkCCostCentre cc)) PtrHint] False bumpSccCount :: CmmExpr -> CmmStmt diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 13add6c..adb48cd 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -333,24 +333,24 @@ emitIfThenElse cond then_part else_part ; labelC join_id } -emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code +emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code +emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code emitRtsCallWithVols fun args vols safe = emitRtsCall' [] fun args (Just vols) safe emitRtsCallWithResult :: LocalReg -> MachHint -> LitString - -> [(CmmExpr,MachHint)] -> Bool -> Code + -> [CmmHinted CmmExpr] -> Bool -> Code emitRtsCallWithResult res hint fun args safe - = emitRtsCall' [(res,hint)] fun args Nothing safe + = emitRtsCall' [CmmHinted res hint] fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' :: CmmFormals -> LitString - -> [(CmmExpr,MachHint)] + -> [CmmHinted CmmExpr] -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> Code diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 7981a40..6d3bf7c 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -719,9 +719,9 @@ cmmStmtConFold stmt e' <- cmmExprConFold CallReference e return $ CmmCallee e' conv other -> return other - args' <- mapM (\(arg, hint) -> do + args' <- mapM (\(CmmHinted arg hint) -> do arg' <- cmmExprConFold DataReference arg - return (arg', hint)) args + return (CmmHinted arg' hint)) args return $ CmmCall target' regs args' srt returns CmmCondBranch test dest diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index 4692f06..8f6cfcb 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -3054,7 +3054,7 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- we keep it this long in order to prevent earlier optimisations. -- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [(r,_)] args = do +genCCall (CmmPrim op) [CmmHinted r _] args = do case op of MO_F32_Sqrt -> actuallyInlineFloatOp F32 (GSQRT F32) args MO_F64_Sqrt -> actuallyInlineFloatOp F64 (GSQRT F64) args @@ -3070,14 +3070,14 @@ genCCall (CmmPrim op) [(r,_)] args = do other_op -> outOfLineFloatOp op r args where - actuallyInlineFloatOp rep instr [(x,_)] + actuallyInlineFloatOp rep instr [CmmHinted x _] = do res <- trivialUFCode rep instr x any <- anyReg res return (any (getRegisterReg (CmmLocal r))) genCCall target dest_regs args = do let - sizes = map (arg_size . cmmExprRep . fst) (reverse args) + sizes = map (arg_size . cmmExprRep . hintlessCmm) (reverse args) #if !darwin_TARGET_OS tot_arg_size = sum sizes #else @@ -3129,7 +3129,7 @@ genCCall target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [(dest,_hint)] = + assign_code [CmmHinted dest _hint] = case rep of I64 -> toOL [MOV I32 (OpReg eax) (OpReg r_dest), MOV I32 (OpReg edx) (OpReg r_dest_hi)] @@ -3156,10 +3156,10 @@ genCCall target dest_regs args = do | otherwise = x + a - (x `mod` a) - push_arg :: (CmmExpr,MachHint){-current argument-} + push_arg :: (CmmHinted CmmExpr){-current argument-} -> NatM InstrBlock -- code - push_arg (arg,_hint) -- we don't need the hints on x86 + push_arg (CmmHinted arg _hint) -- we don't need the hints on x86 | arg_rep == I64 = do ChildCode64 code r_lo <- iselExpr64 arg delta <- getDeltaNat @@ -3213,13 +3213,13 @@ outOfLineFloatOp mop res args if localRegRep res == F64 then - stmtToInstrs (CmmCall target [(res,FloatHint)] args CmmUnsafe CmmMayReturn) + stmtToInstrs (CmmCall target [CmmHinted res FloatHint] args CmmUnsafe CmmMayReturn) else do uq <- getUniqueNat let tmp = LocalReg uq F64 GCKindNonPtr -- in - code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args CmmUnsafe CmmMayReturn) + code1 <- stmtToInstrs (CmmCall target [CmmHinted tmp FloatHint] args CmmUnsafe CmmMayReturn) code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) return (code1 `appOL` code2) where @@ -3268,7 +3268,8 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL -- write barrier compiles to no code on x86/x86-64; -- we keep it this long in order to prevent earlier optimisations. -genCCall (CmmPrim op) [(r,_)] args = + +genCCall (CmmPrim op) [CmmHinted r _] args = outOfLineFloatOp op r args genCCall target dest_regs args = do @@ -3348,7 +3349,7 @@ genCCall target dest_regs args = do let -- assign the results, if necessary assign_code [] = nilOL - assign_code [(dest,_hint)] = + assign_code [CmmHinted dest _hint] = case rep of F32 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest)) F64 -> unitOL (MOV rep (OpReg xmm0) (OpReg r_dest)) @@ -3368,16 +3369,16 @@ genCCall target dest_regs args = do where arg_size = 8 -- always, at the mo - load_args :: [(CmmExpr,MachHint)] + load_args :: [CmmHinted CmmExpr] -> [Reg] -- int regs avail for args -> [Reg] -- FP regs avail for args -> InstrBlock - -> NatM ([(CmmExpr,MachHint)],[Reg],[Reg],InstrBlock) + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) load_args args [] [] code = return (args, [], [], code) -- no more regs to use load_args [] aregs fregs code = return ([], aregs, fregs, code) -- no more args to push - load_args ((arg,hint) : rest) aregs fregs code + load_args ((CmmHinted arg hint) : rest) aregs fregs code | isFloatingRep arg_rep = case fregs of [] -> push_this_arg @@ -3395,10 +3396,10 @@ genCCall target dest_regs args = do push_this_arg = do (args',ars,frs,code') <- load_args rest aregs fregs code - return ((arg,hint):args', ars, frs, code') + return ((CmmHinted arg hint):args', ars, frs, code') push_args [] code = return code - push_args ((arg,hint):rest) code + push_args ((CmmHinted arg hint):rest) code | isFloatingRep arg_rep = do (arg_reg, arg_code) <- getSomeReg arg delta <- getDeltaNat @@ -3459,7 +3460,7 @@ genCCall target dest_regs args = do genCCall target dest_regs argsAndHints = do let - args = map fst argsAndHints + args = map hintlessCmm argsAndHints argcode_and_vregs <- mapM arg_to_int_vregs args let (argcodes, vregss) = unzip argcode_and_vregs @@ -3694,7 +3695,7 @@ genCCall target dest_regs argsAndHints initialStackOffset = 8 stackDelta finalStack = roundTo 16 finalStack #endif - args = map fst argsAndHints + args = map hintlessCmm argsAndHints argReps = map cmmExprRep args roundTo a x | x `mod` a == 0 = x @@ -3809,7 +3810,7 @@ genCCall target dest_regs argsAndHints moveResult reduceToF32 = case dest_regs of [] -> nilOL - [(dest, _hint)] + [CmmHinted dest _hint] | reduceToF32 && rep == F32 -> unitOL (FRSP r_dest f1) | rep == F32 || rep == F64 -> unitOL (MR r_dest f1) | rep == I64 -> toOL [MR (getHiVRegFromLo r_dest) r3,