summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/Cmm.hs29
-rw-r--r--compiler/cmm/CmmBrokenBlock.hs4
-rw-r--r--compiler/cmm/CmmCPS.hs22
-rw-r--r--compiler/cmm/CmmLive.hs10
-rw-r--r--compiler/cmm/CmmOpt.hs12
-rw-r--r--compiler/cmm/CmmParse.y45
-rw-r--r--compiler/cmm/PprC.hs26
-rw-r--r--compiler/cmm/PprCmm.hs12
8 files changed, 94 insertions, 66 deletions
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 986f486cc7..cae1633366 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -10,13 +10,13 @@ module Cmm (
GenCmm(..), Cmm,
GenCmmTop(..), CmmTop,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
- CmmStmt(..), CmmActuals, CmmFormals,
+ CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmCallTarget(..),
CmmStatic(..), Section(..),
CmmExpr(..), cmmExprRep,
CmmReg(..), cmmRegRep,
CmmLit(..), cmmLitRep,
- LocalReg(..), localRegRep,
+ LocalReg(..), localRegRep, Kind(..),
BlockId(..), BlockEnv,
GlobalReg(..), globalRegRep,
@@ -114,7 +114,7 @@ data CmmStmt
| CmmCall -- A foreign call, with
CmmCallTarget
- CmmFormals -- zero or more results
+ CmmHintFormals -- zero or more results
CmmActuals -- zero or more arguments
| CmmBranch BlockId -- branch to another BB in this fn
@@ -133,8 +133,11 @@ data CmmStmt
| CmmReturn -- Return from a function,
CmmActuals -- with these return values.
-type CmmActuals = [(CmmExpr,MachHint)]
-type CmmFormals = [(CmmReg,MachHint)]
+type CmmActual = CmmExpr
+type CmmActuals = [(CmmActual,MachHint)]
+type CmmFormal = LocalReg
+type CmmHintFormals = [(CmmFormal,MachHint)]
+type CmmFormals = [CmmFormal]
{-
Discussion
@@ -221,17 +224,25 @@ cmmRegRep :: CmmReg -> MachRep
cmmRegRep (CmmLocal reg) = localRegRep reg
cmmRegRep (CmmGlobal reg) = globalRegRep reg
+-- | Whether a 'LocalReg' is a GC followable pointer
+data Kind = KindPtr | KindNonPtr deriving (Eq)
+
data LocalReg
- = LocalReg !Unique MachRep
+ = LocalReg
+ !Unique -- ^ Identifier
+ MachRep -- ^ Type
+ Kind -- ^ Should the GC follow as a pointer
instance Eq LocalReg where
- (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+ (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
instance Uniquable LocalReg where
- getUnique (LocalReg uniq _) = uniq
+ getUnique (LocalReg uniq _ _) = uniq
localRegRep :: LocalReg -> MachRep
-localRegRep (LocalReg _ rep) = rep
+localRegRep (LocalReg _ rep _) = rep
+
+localRegGCFollow (LocalReg _ _ p) = p
data CmmLit
= CmmInt Integer MachRep
diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs
index 49c41bb7bc..1d07631755 100644
--- a/compiler/cmm/CmmBrokenBlock.hs
+++ b/compiler/cmm/CmmBrokenBlock.hs
@@ -78,7 +78,7 @@ data FinalStmt
BlockId -- ^ Target of the 'CmmGoto'
-- (must be a 'ContinuationEntry')
CmmCallTarget -- ^ The function to call
- CmmFormals -- ^ Results from call
+ CmmHintFormals -- ^ Results from call
-- (redundant with ContinuationEntry)
CmmActuals -- ^ Arguments to call
@@ -142,7 +142,7 @@ breakBlock uniques (BasicBlock ident stmts) entry =
block = do_call current_id entry accum_stmts exits next_id
target results arguments
rest = breakBlock' (tail uniques) next_id
- (ContinuationEntry results) [] [] stmts
+ (ContinuationEntry (map fst results)) [] [] stmts
(s:stmts) ->
breakBlock' uniques current_id entry
(cond_branch_target s++exits)
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index 4d90a4d432..9a9f8a9fb2 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -157,7 +157,7 @@ data StackFormat
= StackFormat {
stack_label :: Maybe CLabel, -- The label occupying the top slot
stack_frame_size :: WordOff, -- Total frame size in words (not including arguments)
- stack_live :: [(CmmReg, WordOff)] -- local reg offsets from stack top
+ stack_live :: [(LocalReg, WordOff)] -- local reg offsets from stack top
-- TODO: see if the above can be LocalReg
}
@@ -230,11 +230,11 @@ selectStackFormat live continuations =
live_to_format label formals live =
foldl extend_format
(StackFormat (Just label) retAddrSizeW [])
- (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
+ (uniqSetToList (live `minusUniqSet` mkUniqSet formals))
extend_format :: StackFormat -> LocalReg -> StackFormat
extend_format (StackFormat label size offsets) reg =
- StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
+ StackFormat label (slot_size reg + size) ((reg, size) : offsets)
slot_size :: LocalReg -> Int
slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
@@ -315,7 +315,7 @@ pack_continuation (StackFormat curr_id curr_frame_size _)
= store_live_values ++ set_stack_header where
-- TODO: only save variables when actually needed (may be handled by latter pass)
store_live_values =
- [stack_put spRel (CmmReg reg) offset
+ [stack_put spRel (CmmReg (CmmLocal reg)) offset
| (reg, offset) <- cont_offsets]
set_stack_header =
if not needs_header
@@ -342,11 +342,11 @@ function_entry formals (StackFormat _ _ curr_offsets)
| (reg, offset) <- curr_offsets]
load_args =
[stack_get 0 reg offset
- | ((reg, _), StackParam offset) <- argument_formats] ++
+ | (reg, StackParam offset) <- argument_formats] ++
[global_get reg global
- | ((reg, _), RegisterParam global) <- argument_formats]
+ | (reg, RegisterParam global) <- argument_formats]
- argument_formats = assignArguments (cmmRegRep . fst) formals
+ argument_formats = assignArguments (localRegRep) formals
-----------------------------------------------------------------------------
-- Section: Stack and argument register puts and gets
@@ -366,13 +366,13 @@ stack_put spRel expr offset =
--------------------------------
-- |Construct a
stack_get :: WordOff
- -> CmmReg
+ -> LocalReg
-> WordOff
-> CmmStmt
stack_get spRel reg offset =
- CmmAssign reg (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (cmmRegRep reg))
+ CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (localRegRep reg))
global_put :: CmmExpr -> GlobalReg -> CmmStmt
global_put expr global = CmmAssign (CmmGlobal global) expr
-global_get :: CmmReg -> GlobalReg -> CmmStmt
-global_get reg global = CmmAssign reg (CmmReg (CmmGlobal global))
+global_get :: LocalReg -> GlobalReg -> CmmStmt
+global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index b379f2db3c..40d7b7c82e 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -2,7 +2,7 @@ module CmmLive (
CmmLive,
BlockEntryLiveness,
cmmLiveness,
- cmmFormalsToLiveLocals,
+ cmmHintFormalsToLiveLocals,
) where
#include "HsVersions.h"
@@ -156,10 +156,8 @@ addKilled new_killed live = live `minusUniqSet` new_killed
--------------------------------
-- Liveness of a CmmStmt
--------------------------------
-cmmFormalsToLiveLocals :: CmmFormals -> [LocalReg]
-cmmFormalsToLiveLocals [] = []
-cmmFormalsToLiveLocals ((CmmGlobal _,_):args) = cmmFormalsToLiveLocals args
-cmmFormalsToLiveLocals ((CmmLocal r,_):args) = r:cmmFormalsToLiveLocals args
+cmmHintFormalsToLiveLocals :: CmmHintFormals -> [LocalReg]
+cmmHintFormalsToLiveLocals formals = map fst formals
cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer
cmmStmtLive _ (CmmNop) = id
@@ -175,7 +173,7 @@ cmmStmtLive _ (CmmStore expr1 expr2) =
cmmStmtLive _ (CmmCall target results arguments) =
target_liveness .
foldr ((.) . cmmExprLive) id (map fst arguments) .
- addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where
+ addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where
target_liveness =
case target of
(CmmForeignCall target _) -> cmmExprLive target
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index aa5a788d5e..aa0c821809 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -93,7 +93,7 @@ cmmMiniInline blocks = map do_inline blocks
cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
cmmMiniInlineStmts uses [] = []
-cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
+cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _ _)) expr) : stmts)
| Just 1 <- lookupUFM uses u,
Just stmts' <- lookForInline u expr stmts
=
@@ -109,7 +109,7 @@ cmmMiniInlineStmts uses (stmt:stmts)
-- Try to inline a temporary assignment. We can skip over assignments to
-- other tempoararies, because we know that expressions aren't side-effecting
-- and temporaries are single-assignment.
-lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
+lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest)
| u /= u'
= case lookupUFM (getExprUses rhs) u of
Just 1 -> Just (inlineStmt u expr stmt : rest)
@@ -150,8 +150,8 @@ getStmtUses (CmmJump e _) = getExprUses e
getStmtUses _ = emptyUFM
getExprUses :: CmmExpr -> UniqFM Int
-getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
-getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
+getExprUses (CmmReg (CmmLocal (LocalReg u _ _))) = unitUFM u 1
+getExprUses (CmmRegOff (CmmLocal (LocalReg u _ _)) _) = unitUFM u 1
getExprUses (CmmLoad e _) = getExprUses e
getExprUses (CmmMachOp _ es) = getExprsUses es
getExprUses _other = emptyUFM
@@ -172,10 +172,10 @@ inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
inlineStmt u a other_stmt = other_stmt
inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
-inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
+inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _ _)))
| u == u' = a
| otherwise = e
-inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
+inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep _)) off)
| u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
| otherwise = e
inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 6048c44d12..567dd606ad 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -244,7 +244,10 @@ body :: { ExtCode }
| stmt body { do $1; $2 }
decl :: { ExtCode }
- : type names ';' { mapM_ (newLocal $1) $2 }
+ : type names ';' { mapM_ (newLocal defaultKind $1) $2 }
+ | STRING type names ';' {% do k <- parseKind $1;
+ return $ mapM_ (newLocal k $2) $3 }
+
| 'import' names ';' { return () } -- ignore imports
| 'export' names ';' { return () } -- ignore exports
@@ -401,21 +404,32 @@ reg :: { ExtFCode CmmExpr }
: NAME { lookupName $1 }
| GLOBALREG { return (CmmReg (CmmGlobal $1)) }
-maybe_results :: { [ExtFCode (CmmReg, MachHint)] }
+maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
: {- empty -} { [] }
| hint_lregs '=' { $1 }
-hint_lregs :: { [ExtFCode (CmmReg, MachHint)] }
+hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] }
+ : {- empty -} { [] }
+ | hint_lregs { $1 }
+
+hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
: hint_lreg ',' { [$1] }
| hint_lreg { [$1] }
| hint_lreg ',' hint_lregs { $1 : $3 }
-hint_lreg :: { ExtFCode (CmmReg, MachHint) }
- : lreg { do e <- $1; return (e, inferHint (CmmReg e)) }
- | STRING lreg {% do h <- parseHint $1;
+hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
+ : local_lreg { do e <- $1; return (e, inferHint (CmmReg (CmmLocal e))) }
+ | STRING local_lreg {% do h <- parseHint $1;
return $ do
e <- $2; return (e,h) }
+local_lreg :: { ExtFCode LocalReg }
+ : NAME { do e <- lookupName $1;
+ return $
+ case e of
+ CmmReg (CmmLocal r) -> r
+ other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
+
lreg :: { ExtFCode CmmReg }
: NAME { do e <- lookupName $1;
return $
@@ -580,6 +594,13 @@ parseHint "signed" = return SignedHint
parseHint "float" = return FloatHint
parseHint str = fail ("unrecognised hint: " ++ str)
+parseKind :: String -> P Kind
+parseKind "ptr" = return KindPtr
+parseKind str = fail ("unrecognized kin: " ++ str)
+
+defaultKind :: Kind
+defaultKind = KindNonPtr
+
-- labels are always pointers, so we might as well infer the hint
inferHint :: CmmExpr -> MachHint
inferHint (CmmLit (CmmLabel _)) = PtrHint
@@ -694,10 +715,12 @@ addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
addLabel :: FastString -> BlockId -> ExtCode
addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
-newLocal :: MachRep -> FastString -> ExtCode
-newLocal ty name = do
+newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
+newLocal kind ty name = do
u <- code newUnique
- addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
+ let reg = LocalReg u ty kind
+ addVarDecl name (CmmReg (CmmLocal reg))
+ return reg
newLabel :: FastString -> ExtFCode BlockId
newLabel name = do
@@ -792,7 +815,7 @@ staticClosure cl_label info payload
foreignCall
:: String
- -> [ExtFCode (CmmReg,MachHint)]
+ -> [ExtFCode (CmmFormal,MachHint)]
-> ExtFCode CmmExpr
-> [ExtFCode (CmmExpr,MachHint)]
-> Maybe [GlobalReg] -> P ExtCode
@@ -809,7 +832,7 @@ foreignCall conv_string results_code expr_code args_code vols
(CmmForeignCall expr convention) args vols) where
primCall
- :: [ExtFCode (CmmReg,MachHint)]
+ :: [ExtFCode (CmmFormal,MachHint)]
-> FastString
-> [ExtFCode (CmmExpr,MachHint)]
-> Maybe [GlobalReg] -> P ExtCode
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index d9bdca5b83..bda191cb5f 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -206,7 +206,7 @@ pprStmt stmt = case stmt of
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
- _other -> parens (cCast (pprCFunType cconv results args) fn)
+ _ -> parens (cCast (pprCFunType cconv results args) fn)
-- for a dynamic call, cast the expression to
-- a function of the right type (we hope).
@@ -229,7 +229,7 @@ pprStmt stmt = case stmt of
CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi
CmmSwitch arg ids -> pprSwitch arg ids
-pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType :: CCallConv -> CmmHintFormals -> CmmActuals -> SDoc
pprCFunType cconv ress args
= hcat [
res_type ress,
@@ -238,7 +238,7 @@ pprCFunType cconv ress args
]
where
res_type [] = ptext SLIT("void")
- res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
+ res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
@@ -713,12 +713,12 @@ pprGlobalReg gr = case gr of
GCFun -> ptext SLIT("stg_gc_fun")
pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq
+pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals
-> SDoc
pprCall ppr_fn cconv results args
@@ -741,17 +741,9 @@ pprCall ppr_fn cconv results args
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
- ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
- | Just ty <- strangeRegType reg
- = ptext SLIT("ASSIGN_BaseReg") <> parens (parens ty <> rhs)
- -- BaseReg is special, sometimes it isn't an lvalue and we
- -- can't assign to it.
ppr_assign [(one,hint)] rhs
- | Just ty <- strangeRegType one
- = pprReg one <> ptext SLIT(" = ") <> parens ty <> rhs
- | otherwise
- = pprReg one <> ptext SLIT(" = ")
- <> pprUnHint hint (cmmRegRep one) <> rhs
+ = pprLocalReg one <> ptext SLIT(" = ")
+ <> pprUnHint hint (localRegRep one) <> rhs
ppr_assign _other _rhs = panic "pprCall: multiple results"
pprArg (expr, PtrHint)
@@ -792,7 +784,7 @@ pprDataExterns statics
where (_, lbls) = runTE (mapM_ te_Static statics)
pprTempDecl :: LocalReg -> SDoc
-pprTempDecl l@(LocalReg _uniq rep)
+pprTempDecl l@(LocalReg _ rep _)
= hcat [ machRepCType rep, space, pprLocalReg l, semi ]
pprExternDecl :: Bool -> CLabel -> SDoc
@@ -847,7 +839,7 @@ 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_Reg.fst) rs >>
+te_Stmt (CmmCall _ rs es) = mapM_ (te_temp.fst) rs >>
mapM_ (te_Expr.fst) es
te_Stmt (CmmCondBranch e _) = te_Expr e
te_Stmt (CmmSwitch e _) = te_Expr e
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 4ade7a4028..ee8f0f3040 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -425,10 +425,14 @@ pprReg r
-- We only print the type of the local reg if it isn't wordRep
--
pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq rep)
- = hcat [ char '_', ppr uniq,
- (if rep == wordRep
- then empty else dcolon <> ppr rep) ]
+pprLocalReg (LocalReg uniq rep follow)
+ = hcat [ char '_', ppr uniq, ty ] where
+ ty = if rep == wordRep && follow == KindNonPtr
+ then empty
+ else dcolon <> ptr <> ppr rep
+ ptr = if follow == KindNonPtr
+ then empty
+ else doubleQuotes (text "ptr")
-- needs to be kept in syn with Cmm.hs.GlobalReg
--
View Lorry Controller Status