Commit d31dfb32 authored by Michael D. Adams's avatar Michael D. Adams

Implemented and fixed bugs in CmmInfo handling

parent c9c4951c
......@@ -521,6 +521,8 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel HpcModuleNameLabel = False
externallyVisibleCLabel (LargeBitmapLabel _) = False
externallyVisibleCLabel (LargeSRTLabel _) = False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
......@@ -702,7 +704,11 @@ pprCLbl (CaseLabel u CaseDefault)
= hcat [pprUnique u, ptext SLIT("_dflt")]
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")
pprCLbl (LargeBitmapLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("btm")
pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext SLIT("btm")
-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
-- until that gets resolved we'll just force them to start
-- with a letter so the label will be legal assmbly code.
pprCLbl (RtsLabel (RtsCode str)) = ptext str
pprCLbl (RtsLabel (RtsData str)) = ptext str
......
......@@ -9,9 +9,10 @@
module Cmm (
GenCmm(..), Cmm, RawCmm,
GenCmmTop(..), CmmTop, RawCmmTop,
CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..),
CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmSafety(..),
CmmCallTarget(..),
CmmStatic(..), Section(..),
CmmExpr(..), cmmExprRep,
......@@ -133,12 +134,14 @@ data ClosureTypeInfo
-- TODO: These types may need refinement
data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
type ClosureTypeTag = StgHalfWord
type ClosureLayout = (StgHalfWord, StgHalfWord) -- pts, nptrs
type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
type ConstrTag = StgHalfWord
type ConstrDescription = CmmLit
type FunType = StgHalfWord
type FunArity = StgHalfWord
type SlowEntry = CLabel
type SlowEntry = CmmLit
-- ^We would like this to be a CLabel but
-- for now the parser sets this to zero on an INFO_TABLE_FUN.
type SelectorOffset = StgWord
-----------------------------------------------------------------------------
......@@ -161,7 +164,7 @@ data CmmStmt
CmmCallTarget
CmmHintFormals -- zero or more results
CmmActuals -- zero or more arguments
C_SRT -- SRT for the continuation of the call
CmmSafety -- whether to build a continuation
| CmmBranch BlockId -- branch to another BB in this fn
......@@ -184,6 +187,7 @@ type CmmActuals = [(CmmActual,MachHint)]
type CmmFormal = LocalReg
type CmmHintFormals = [(CmmFormal,MachHint)]
type CmmFormals = [CmmFormal]
data CmmSafety = CmmUnsafe | CmmSafe C_SRT
{-
Discussion
......
......@@ -70,9 +70,9 @@ cmmCPS dflags abstractC = do
return continuationC
stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
make_gc_block block_id fun_label formals srt = BasicBlock block_id stmts
make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
where
stmts = [CmmCall stg_gc_gen_target [] [] srt,
stmts = [CmmCall stg_gc_gen_target [] [] safety,
CmmJump fun_expr actuals]
stg_gc_gen_target =
CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
......@@ -85,10 +85,10 @@ force_gc_block old_info block_id fun_label formals blocks =
CmmInfo _ (Just _) _ _ -> (old_info, [])
CmmNonInfo Nothing
-> (CmmNonInfo (Just block_id),
[make_gc_block block_id fun_label formals NoC_SRT])
[make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)])
CmmInfo prof Nothing type_tag type_info
-> (CmmInfo prof (Just block_id) type_tag type_info,
[make_gc_block block_id fun_label formals srt])
[make_gc_block block_id fun_label formals (CmmSafe srt)])
where
srt = case type_info of
ConstrInfo _ _ _ -> NoC_SRT
......@@ -361,9 +361,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) =
-- TODO prof: this is the same as the current implementation
-- but I think it could be improved
prof = ProfilingInfo zeroCLit zeroCLit
tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE
then rET_BIG
else rET_SMALL
tag = rET_SMALL -- cmmToRawCmm will convert this to rET_BIG if needed
format = maybe unknown_block id $ lookup label formats
unknown_block = panic "unknown BlockId in applyStackFormat"
......
This diff is collapsed.
......@@ -231,7 +231,9 @@ info :: { ExtFCode (CLabel, CmmInfo) }
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $9)
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) }
(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
(ArgSpec 0)
zeroCLit)) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
......@@ -258,7 +260,7 @@ info :: { ExtFCode (CLabel, CmmInfo) }
CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
(ContInfo [] NoC_SRT)) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')'
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
{ do live <- sequence (map (liftM Just) $7)
return (mkRtsInfoLabelFS $3,
......@@ -792,48 +794,6 @@ forkLabelledCodeEC ec = do
stmts <- getCgStmtsEC ec
code (forkCgStmts stmts)
retInfo name size live_bits cl_type = do
let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
info_lbl = mkRtsRetInfoLabelFS name
(info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
(fromIntegral cl_type)
return (info_lbl, info1, info2)
stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
basicInfo name (packHalfWordsCLit ptrs nptrs)
srt_bitmap cl_type desc_str ty_str
conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
(lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs)
srt_bitmap cl_type desc_str ty_str
desc_lit <- code $ mkStringCLit desc_str
let desc_field = makeRelativeRefTo lbl desc_lit
return (lbl, info1, [desc_field])
basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
let info_lbl = mkRtsInfoLabelFS name
lit1 <- if opt_SccProfilingOn
then code $ do lit <- mkStringCLit desc_str
return (makeRelativeRefTo info_lbl lit)
else return (mkIntCLit 0)
lit2 <- if opt_SccProfilingOn
then code $ do lit <- mkStringCLit ty_str
return (makeRelativeRefTo info_lbl lit)
else return (mkIntCLit 0)
let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
(fromIntegral srt_bitmap)
layout
return (info_lbl, info1, [])
funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
(label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
cl_type desc_str ty_str
let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
return (label,info1,info2)
where
zero = mkIntCLit 0
profilingInfo desc_str ty_str = do
lit1 <- if opt_SccProfilingOn
......@@ -907,6 +867,7 @@ emitRetUT args = do
emitStmts stmts
when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
-- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
......
......@@ -199,11 +199,11 @@ pprStmt stmt = case stmt of
where
rep = cmmExprRep src
CmmCall (CmmForeignCall fn cconv) results args srt ->
CmmCall (CmmForeignCall fn cconv) results args safety ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
pprCall ppr_fn cconv results args srt
pprCall ppr_fn cconv results args safety
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
......@@ -220,8 +220,8 @@ pprStmt stmt = case stmt of
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
CmmCall (CmmPrim op) results args srt ->
pprCall ppr_fn CCallConv results args srt
CmmCall (CmmPrim op) results args safety ->
pprCall ppr_fn CCallConv results args safety
where
ppr_fn = pprCallishMachOp_for_C op
......@@ -719,7 +719,7 @@ pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT
pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
-> SDoc
pprCall ppr_fn cconv results args _
......
......@@ -117,7 +117,10 @@ pprTop (CmmData section ds) =
(hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
$$ rbrace
-- --------------------------------------------------------------------------
instance Outputable CmmSafety where
ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
ppr (CmmSafe srt) = ppr srt
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
......@@ -128,13 +131,15 @@ pprTop (CmmData section ds) =
-- and were labelled with the procedure name ++ "_info".
pprInfo (CmmNonInfo gc_target) =
ptext SLIT("gc_target: ") <>
maybe (ptext SLIT("<none>")) pprBlockId gc_target
ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target
-- ^ gc_target is currently unused and wired to a panic
pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
gc_target tag info) =
vcat [ptext SLIT("type: ") <> pprLit closure_type,
ptext SLIT("desc: ") <> pprLit closure_desc,
ptext SLIT("gc_target: ") <>
maybe (ptext SLIT("<none>")) pprBlockId gc_target,
ptext SLIT("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target,
-- ^ gc_target is currently unused and wired to a panic
ptext SLIT("tag: ") <> integer (toInteger tag),
pprTypeInfo info]
......@@ -192,7 +197,7 @@ pprStmt stmt = case stmt of
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
CmmCall (CmmForeignCall fn cconv) results args srt ->
CmmCall (CmmForeignCall fn cconv) results args safety ->
hcat [ if null results
then empty
else parens (commafy $ map ppr results) <>
......@@ -200,14 +205,14 @@ pprStmt stmt = case stmt of
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
brackets (ppr srt), semi ]
brackets (ppr safety), semi ]
where
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
CmmCall (CmmPrim op) results args srt ->
CmmCall (CmmPrim op) results args safety ->
pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
results args srt)
results args safety)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
......
......@@ -19,6 +19,7 @@ module CgBindery (
nukeVolatileBinds,
nukeDeadBindings,
getLiveStackSlots,
getLiveStackBindings,
bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
......@@ -494,3 +495,14 @@ getLiveStackSlots
cg_rep = rep } <- varEnvElts binds,
isFollowableArg rep] }
\end{code}
\begin{code}
getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
getLiveStackBindings
= do { binds <- getBinds
; return [(off, bind) |
bind <- varEnvElts binds,
CgIdInfo { cg_stb = VirStkLoc off,
cg_rep = rep} <- [bind],
isFollowableArg rep] }
\end{code}
......@@ -15,7 +15,7 @@ module CgCallConv (
mkArgDescr, argDescrType,
-- Liveness
isBigLiveness, buildContLiveness, mkRegLiveness,
isBigLiveness, mkRegLiveness,
smallLiveness, mkLivenessCLit,
-- Register assignment
......@@ -71,7 +71,7 @@ import Data.Bits
#include "../includes/StgFun.h"
-------------------------
argDescrType :: ArgDescr -> Int
argDescrType :: ArgDescr -> StgHalfWord
-- The "argument type" RTS field type
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
......@@ -98,7 +98,7 @@ argBits [] = []
argBits (PtrArg : args) = False : argBits args
argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
stdPattern :: [CgRep] -> Maybe Int
stdPattern :: [CgRep] -> Maybe StgHalfWord
stdPattern [] = Just ARG_NONE -- just void args, probably
stdPattern [PtrArg] = Just ARG_P
......@@ -133,6 +133,14 @@ stdPattern other = Nothing
--
-------------------------------------------------------------------------
-- TODO: This along with 'mkArgDescr' should be unified
-- with 'CmmInfo.mkLiveness'. However that would require
-- potentially invasive changes to the 'ClosureInfo' type.
-- For now, 'CmmInfo.mkLiveness' handles only continuations and
-- this one handles liveness everything else. Another distinction
-- between these two is that 'CmmInfo.mkLiveness' information
-- about the stack layout, and this one is information about
-- the heap layout of PAPs.
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
......@@ -282,56 +290,6 @@ getSequelAmode
CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl))
}
-------------------------------------------------------------------------
--
-- Build a liveness mask for the current stack
--
-------------------------------------------------------------------------
-- There are four kinds of things on the stack:
--
-- - pointer variables (bound in the environment)
-- - non-pointer variables (bound in the environment)
-- - free slots (recorded in the stack free list)
-- - non-pointer data slots (recorded in the stack free list)
--
-- We build up a bitmap of non-pointer slots by searching the environment
-- for all the pointer variables, and subtracting these from a bitmap
-- with initially all bits set (up to the size of the stack frame).
buildContLiveness :: Name -- Basis for label (only)
-> [VirtualSpOffset] -- Live stack slots
-> FCode Liveness
buildContLiveness name live_slots
= do { stk_usg <- getStkUsage
; let StackUsage { realSp = real_sp,
frameSp = frame_sp } = stk_usg
start_sp :: VirtualSpOffset
start_sp = real_sp - retAddrSizeW
-- In a continuation, we want a liveness mask that
-- starts from just after the return address, which is
-- on the stack at real_sp.
frame_size :: WordOff
frame_size = start_sp - frame_sp
-- real_sp points to the frame-header for the current
-- stack frame, and the end of this frame is frame_sp.
-- The size is therefore real_sp - frame_sp - retAddrSizeW
-- (subtract one for the frame-header = return address).
rel_slots :: [WordOff]
rel_slots = sortLe (<=)
[ start_sp - ofs -- Get slots relative to top of frame
| ofs <- live_slots ]
bitmap = intsToReverseBitmap frame_size rel_slots
; WARN( not (all (>=0) rel_slots),
ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
mkLiveness name frame_size bitmap }
-------------------------------------------------------------------------
--
-- Register assignment
......
......@@ -533,7 +533,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]
; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
......
......@@ -116,7 +116,7 @@ emitForeignCall' safety results target args vols srt
temp_args <- load_args_into_temps args
let (caller_save, caller_load) = callerSaveVolatileRegs vols
stmtsC caller_save
stmtC (CmmCall target results temp_args srt)
stmtC (CmmCall target results temp_args CmmUnsafe)
stmtsC caller_load
| otherwise = do
......@@ -129,17 +129,20 @@ emitForeignCall' safety results target args vols srt
let (caller_save, caller_load) = callerSaveVolatileRegs vols
emitSaveThreadState
stmtsC caller_save
-- Using the same SRT for each of these is a little bit conservative
-- but it should work for now.
-- The CmmUnsafe arguments are only correct because this part
-- of the code hasn't been moved into the CPS pass yet.
-- Once that happens, this function will just emit a (CmmSafe srt) call,
-- and the CPS will will be the one to convert that
-- to this sequence of three CmmUnsafe calls.
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
srt)
stmtC (CmmCall temp_target results temp_args srt)
CmmUnsafe)
stmtC (CmmCall temp_target results temp_args CmmUnsafe)
stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
[ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ]
srt)
CmmUnsafe)
-- Assign the result to BaseReg: we
-- might now have a different Capability!
stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
......
This diff is collapsed.
......@@ -257,7 +257,7 @@ enterCostCentreThunk closure =
ifProfiling $ do
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False
-- ToDo: vols
enter_ccs_fsub = enteringPAP 0
......@@ -407,6 +407,7 @@ pushCostCentre result ccs cc
= emitRtsCallWithResult result PtrHint
SLIT("PushCostCentre") [(ccs,PtrHint),
(CmmLit (mkCCostCentre cc), PtrHint)]
False
bumpSccCount :: CmmExpr -> CmmStmt
bumpSccCount ccs
......
......@@ -269,18 +269,18 @@ emitIfThenElse cond then_part else_part
; labelC join_id
}
emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code
emitRtsCall fun args = emitRtsCall' [] fun args Nothing
emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
-- The 'Nothing' says "save all global registers"
emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code
emitRtsCallWithVols fun args vols
= emitRtsCall' [] fun args (Just vols)
emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
emitRtsCallWithVols fun args vols safe
= emitRtsCall' [] fun args (Just vols) safe
emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
-> [(CmmExpr,MachHint)] -> Code
emitRtsCallWithResult res hint fun args
= emitRtsCall' [(res,hint)] fun args Nothing
-> [(CmmExpr,MachHint)] -> Bool -> Code
emitRtsCallWithResult res hint fun args safe
= emitRtsCall' [(res,hint)] fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
......@@ -288,12 +288,15 @@ emitRtsCall'
-> LitString
-> [(CmmExpr,MachHint)]
-> Maybe [GlobalReg]
-> Bool -- True <=> CmmSafe call
-> Code
emitRtsCall' res fun args vols = do
srt <- getSRTInfo
stmtsC caller_save
stmtC (CmmCall target res args srt)
stmtsC caller_load
emitRtsCall' res fun args vols safe = do
safety <- if safe
then getSRTInfo >>= (return . CmmSafe)
else return CmmUnsafe
stmtsC caller_save
stmtC (CmmCall target res args safety)
stmtsC caller_load
where
(caller_save, caller_load) = callerSaveVolatileRegs vols
target = CmmForeignCall fun_expr CCallConv
......
......@@ -13,8 +13,9 @@ the STG paper.
\begin{code}
module ClosureInfo (
ClosureInfo, LambdaFormInfo, SMRep, -- all abstract
StandardFormInfo,
ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but
StandardFormInfo(..), -- mkCmmInfo looks inside
SMRep,
ArgDescr(..), Liveness(..),
C_SRT(..), needsSRT,
......@@ -188,7 +189,7 @@ data LambdaFormInfo
data ArgDescr
= ArgSpec -- Fits one of the standard patterns
!Int -- RTS type identifier ARG_P, ARG_N, ...
!StgHalfWord -- RTS type identifier ARG_P, ARG_N, ...
| ArgGen -- General case
Liveness -- Details about the arguments
......@@ -957,5 +958,3 @@ getTyDescription ty
getPredTyDescription (ClassP cl tys) = getOccString cl
getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
......@@ -76,6 +76,7 @@ import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import CmmParse ( parseCmmFile )
import CmmCPS
import CmmInfo
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
......@@ -605,7 +606,8 @@ hscCompile cgguts
foreign_stubs dir_imps cost_centre_info
stg_binds hpc_info
------------------ Convert to CPS --------------------
continuationC <- {-return abstractC-} cmmCPS dflags abstractC
--continuationC <- cmmCPS dflags abstractC
continuationC <- cmmToRawCmm abstractC
------------------ Code output -----------------------
(stub_h_exists,stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
......@@ -721,7 +723,8 @@ hscCmmFile dflags filename = do
case maybe_cmm of
Nothing -> return False
Just cmm -> do
continuationC <- {-return [cmm]-} cmmCPS dflags [cmm]
--continuationC <- cmmCPS dflags [cmm]
continuationC <- cmmToRawCmm [cmm]
codeOutput dflags no_mod no_loc NoStubs [] continuationC
return True
where
......
......@@ -429,9 +429,6 @@ fixAssigns stmts =
returnUs (concat stmtss)
fixAssign :: CmmStmt -> UniqSM [CmmStmt]
fixAssign (CmmAssign (CmmGlobal BaseReg) src)
= panic "cmmStmtConFold: assignment to BaseReg";
fixAssign (CmmAssign (CmmGlobal reg) src)
| Left realreg <- reg_or_addr
= returnUs [CmmAssign (CmmGlobal reg) src]
......@@ -444,24 +441,6 @@ fixAssign (CmmAssign (CmmGlobal reg) src)
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
{-
fixAssign (CmmCall target results args)
= mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
returnUs (CmmCall target results' args :
concat stores)
where
fixResult g@(CmmGlobal reg,hint) =
case get_GlobalReg_reg_or_addr reg of
Left realreg -> returnUs (g, [])
Right baseRegAddr ->
getUniqueUs `thenUs` \ uq ->
let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
returnUs ((local,hint),
[CmmStore baseRegAddr (CmmReg local)])
fixResult other =
returnUs (other,[])
-}
fixAssign other_stmt = returnUs [other_stmt]
-- -----------------------------------------------------------------------------
......
......@@ -3182,13 +3182,13 @@ outOfLineFloatOp mop res args
if localRegRep res == F64
then
stmtToInstrs (CmmCall target [(res,FloatHint)] args NoC_SRT)
stmtToInstrs (CmmCall target [(res,FloatHint)] args CmmUnsafe)
else do
uq <- getUniqueNat
let
tmp = LocalReg uq F64 KindNonPtr
-- in
code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args NoC_SRT)
code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args CmmUnsafe)
code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
return (code1 `appOL` code2)
where
......
......@@ -524,7 +524,7 @@
__bd = W_[mut_list]; \
if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) { \
W_ __new_bd; \
"ptr" __new_bd = foreign "C" allocBlock_lock() [regs]; \
("ptr" __new_bd) = foreign "C" allocBlock_lock() [regs]; \
bdescr_link(__new_bd) = __bd; \
__bd = __new_bd; \
W_[mut_list] = __bd; \
......
......@@ -47,8 +47,7 @@
-------------------------------------------------------------------------- */
INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
0/*framesize*/, 0/*bitmap*/, RET_SMALL )
INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, RET_SMALL )
{
CInt r;
......@@ -73,7 +72,7 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
Sp_adj(1);
#endif
SAVE_THREAD_STATE();
r = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
(r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
CurrentTSO "ptr") [R1];
if (r != 0::CInt) {
......@@ -106,8 +105,7 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
#endif
}
INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret,
0/*framesize*/, 0/*bitmap*/, RET_SMALL )
INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret, RET_SMALL )
{
StgTSO_flags(CurrentTSO) =
StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
......@@ -165,7 +163,7 @@ unblockAsyncExceptionszh_fast
* thread, which might result in the thread being killed.
*/
SAVE_THREAD_STATE();
r = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
(r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
CurrentTSO "ptr") [R1];
if (r != 0::CInt) {
......@@ -229,7 +227,7 @@ killThreadzh_fast
W_ retcode;
out = BaseReg + OFFSET_StgRegTable_rmp_tmp_w;
retcode = foreign "C" throwTo(MyCapability() "ptr",
(retcode) = foreign "C" throwTo(MyCapability() "ptr",
CurrentTSO "ptr",
target "ptr",
exception "ptr",
......@@ -260,22 +258,16 @@ killThreadzh_fast
#define SP_OFF 1
#endif
#if defined(PROFILING)
#define CATCH_FRAME_BITMAP 7
#define CATCH_FRAME_WORDS 4
#else
#define CATCH_FRAME_BITMAP 1
#define CATCH_FRAME_WORDS 2
#endif
/* Catch frames are very similar to update frames, but when entering
* one we just pop the frame off the stack and perform the correct
* kind of return to the activation record underneath us on the stack.
*/
INFO_TABLE_RET(stg_catch_frame,
CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP,
CATCH_FRAME)
INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
#if defined(PROFILING)
W_ unused1, W_ unused2,
#endif
W_ unused3, "ptr" W_ unused4)
#ifdef REG_R1
{
Sp = Sp + SIZEOF_StgCatchFrame;
......@@ -347,7 +339,7 @@ section "data" {
no_break_on_exception: W_[1];
}
INFO_TABLE_RET(stg_raise_ret, 1, 0, RET_SMALL)
INFO_TABLE_RET(stg_raise_ret, RET_SMALL, "ptr" W_ arg1)
{
R1 = Sp(1);
Sp = Sp + WDS(2);
......@@ -377,7 +369,7 @@ raisezh_fast
retry_pop_stack:
StgTSO_sp(CurrentTSO) = Sp;
frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
(frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
Sp = StgTSO_sp(CurrentTSO);
if (frame_type == ATOMICALLY_FRAME) {
/* The exception has reached the edge of a memory transaction. Check that
......@@ -391,8 +383,8 @@ retry_pop_stack:
W_ trec, outer;
W_ r;
trec = StgTSO_trec(CurrentTSO);
r = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
"ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
(r) = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
......@@ -409,7 +401,7 @@ retry_pop_stack:
} else {
// Transaction was not valid: we retry the exception (otherwise continue
// with a further call to raiseExceptionHelper)