diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Cmm/CLabel.hs | 13 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/TagCheck.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/StgToCmm/Utils.hs | 6 |
4 files changed, 15 insertions, 13 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index c12ecff5eb..5b9c10fc38 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -64,6 +64,7 @@ module GHC.Cmm.CLabel ( mkSMAP_FROZEN_DIRTY_infoLabel, mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, + mkTagInferenceCheckFailureLabel, mkOutOfBoundsAccessLabel, mkArrWords_infoLabel, mkSRTInfoLabel, @@ -637,8 +638,9 @@ mkDirty_MUT_VAR_Label, mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, - mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, - mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel + mkSMAP_DIRTY_infoLabel, mkMUT_VAR_CLEAN_infoLabel, + mkBadAlignmentLabel, mkTagInferenceCheckFailureLabel, mkOutOfBoundsAccessLabel + :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData @@ -655,9 +657,10 @@ mkArrWords_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsL mkSMAP_FROZEN_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo -mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry -mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction -mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo +mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo +mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmPrimCall +mkOutOfBoundsAccessLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_outOfBoundsAccess") CmmPrimCall +mkTagInferenceCheckFailureLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_tagInferenceCheckFailure") CmmPrimCall mkSRTInfoLabel :: Int -> CLabel mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 1d482b0143..a044b7076f 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -3211,7 +3211,7 @@ doBoundsCheck idx sz = do when do_bounds_check (doCheck platform) where doCheck platform = do - boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + boundsCheckFailed <- getCode $ emitCall (NativeNodeCall, NativeReturn) (mkLblExpr mkOutOfBoundsAccessLabel) [idx, sz] emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) where uGE = cmmUGeWord platform diff --git a/compiler/GHC/StgToCmm/TagCheck.hs b/compiler/GHC/StgToCmm/TagCheck.hs index afa3fef426..d41bc356fb 100644 --- a/compiler/GHC/StgToCmm/TagCheck.hs +++ b/compiler/GHC/StgToCmm/TagCheck.hs @@ -19,9 +19,13 @@ import GHC.Prelude import GHC.StgToCmm.Env import GHC.StgToCmm.Monad import GHC.StgToCmm.Utils +import GHC.StgToCmm.Layout (emitCall) +import GHC.StgToCmm.Lit (newStringCLit) import GHC.Cmm import GHC.Cmm.BlockId +import GHC.Cmm.CLabel (mkTagInferenceCheckFailureLabel) import GHC.Cmm.Graph as CmmGraph +import GHC.Cmm.Utils import GHC.Core.Type import GHC.Types.Id @@ -95,7 +99,8 @@ emitTagAssertion onWhat fun = do ; needsArgTag fun lbarf lret ; emitLabel lbarf - ; emitBarf ("Tag inference failed on:" ++ onWhat) + ; onWhat_str <- newStringCLit onWhat + ; _ <- emitCall (NativeNodeCall, NativeReturn) (mkLblExpr mkTagInferenceCheckFailureLabel) [CmmLit onWhat_str] ; emitLabel lret } diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index ddda97ab2a..0656d6f971 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -12,7 +12,6 @@ module GHC.StgToCmm.Utils ( emitDataLits, emitRODataLits, emitDataCon, emitRtsCall, emitRtsCallWithResult, emitRtsCallGen, - emitBarf, assignTemp, newTemp, newUnboxedTupleRegs, @@ -158,11 +157,6 @@ tagToClosure platform tycon tag -- ------------------------------------------------------------------------- -emitBarf :: String -> FCode () -emitBarf msg = do - strLbl <- newStringCLit msg - emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False - emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) |