diff options
Diffstat (limited to 'compiler/codeGen/StgCmmBind.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 44 |
1 files changed, 34 insertions, 10 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 8d0a35ff4f..0cd9dd6579 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -130,8 +130,7 @@ cgBind (StgNonRec name rhs) = do { (info, fcode) <- cgRhs name rhs ; addBindC (cg_id info) info ; init <- fcode - ; emit init - } + ; emit init } -- init cannot be used in body, so slightly better to sink it eagerly cgBind (StgRec pairs) @@ -209,9 +208,34 @@ cgRhs id (StgRhsCon cc con args) buildDynCon id True cc con args cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) + | null fvs -- See Note [Nested constant closures] + = do { (info, fcode) <- cgTopRhsClosure Recursive name cc bi upd_flag args body + ; return (info, fcode >> return mkNop) } + | otherwise = do dflags <- getDynFlags mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body +{- Note [Nested constant closures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + f x = let funny = not True + in ... +then 'funny' is a nested closure (compiled with cgRhs) that has no free vars. +This does not happen often, because let-floating takes them all to top +level; but it CAN happen. (Reason: let-floating may make a function f smaller +so it can be inlined, so now (f True) may generate a local no-fv closure. +This actually happened during bootsrapping GHC itself, with f=mkRdrFunBind +in TcGenDeriv.) + +If we have one of these things, AND they allocate, the heap check will +refer to the static funny_closure; but there isn't one! (Why does the +heap check refer to the static closure? Becuase nodeMustPointToIt is +False, which is fair enough.) + +Simple solution: compile the RHS as if it was top level. Then +everything works. A minor benefit is eliminating the allocation code +too. -} + ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ @@ -547,8 +571,9 @@ thunkCode cl_info fv_details _cc node arity body ; entryHeapCheck cl_info node' arity [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check + ; tickyEnterThunk cl_info ; when (blackHoleOnEntry cl_info && node_points) - (blackHoleIt cl_info node) + (blackHoleIt node) -- Push update frame ; setupUpdate cl_info node $ @@ -568,14 +593,14 @@ thunkCode cl_info fv_details _cc node arity body -- Update and black-hole wrappers ------------------------------------------------------------------------ -blackHoleIt :: ClosureInfo -> LocalReg -> FCode () +blackHoleIt :: LocalReg -> FCode () -- Only called for closures with no args -- Node points to the closure -blackHoleIt closure_info node - = emitBlackHoleCode (closureSingleEntry closure_info) (CmmReg (CmmLocal node)) +blackHoleIt node_reg + = emitBlackHoleCode (CmmReg (CmmLocal node_reg)) -emitBlackHoleCode :: Bool -> CmmExpr -> FCode () -emitBlackHoleCode is_single_entry node = do +emitBlackHoleCode :: CmmExpr -> FCode () +emitBlackHoleCode node = do dflags <- getDynFlags -- Eager blackholing is normally disabled, but can be turned on with @@ -603,7 +628,6 @@ emitBlackHoleCode is_single_entry node = do -- work with profiling. when eager_blackholing $ do - tickyBlackHole (not is_single_entry) emitStore (cmmOffsetW dflags node (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] @@ -614,7 +638,7 @@ setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- so that the cost centre in the original closure can still be -- extracted by a subsequent enterCostCentre setupUpdate closure_info node body - | closureReEntrant closure_info + | not (lfUpdatable (closureLFInfo closure_info)) = body | not (isStaticClosure closure_info) |