module GHC.StgToCmm.TagCheck
( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,
checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where
#include "ClosureTypes.h"
import GHC.Prelude
import GHC.StgToCmm.Env
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Graph as CmmGraph
import GHC.Core.Type
import GHC.Types.Id
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Core.DataCon
import Control.Monad
import GHC.StgToCmm.Types
import GHC.Utils.Panic (pprPanic)
import GHC.Utils.Panic.Plain (panic)
import GHC.Stg.Syntax
import GHC.StgToCmm.Closure
import GHC.Cmm.Switch (mkSwitchTargets)
import GHC.Cmm.Info (cmmGetClosureType)
import GHC.Types.RepType (dataConRuntimeRepStrictness)
import GHC.Types.Basic
import GHC.Data.FastString (mkFastString)
import qualified Data.Map as M
checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode ()
checkFunctionArgTags msg f args = whenCheckTags $ do
onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do
let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args
arg_infos <- mapM getCgIdInfo cbv_args
let arg_cmms = map idInfoToAmode arg_infos
mapM_ (emitTagAssertion (showPprUnsafe msg)) (arg_cmms)
checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode ()
checkConArgsStatic msg con args = whenCheckTags $ do
let marks = dataConRuntimeRepStrictness con
zipWithM_ (checkArgStatic msg) marks args
checkConArgsDyn :: SDoc -> DataCon -> [StgArg] -> FCode ()
checkConArgsDyn msg con args = whenCheckTags $ do
let marks = dataConRuntimeRepStrictness con
zipWithM_ (checkArg msg) (map cbvFromStrictMark marks) args
whenCheckTags :: FCode () -> FCode ()
whenCheckTags act = do
check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
when check_tags act
emitTagAssertion :: String -> CmmExpr -> FCode ()
emitTagAssertion onWhat fun = do
{ platform <- getPlatform
; lret <- newBlockId
; lno_tag <- newBlockId
; lbarf <- newBlockId
; emit $ mkCbranch (cmmIsTagged platform fun)
lret lno_tag (Just True)
; emitLabel lno_tag
; emitComment (mkFastString "closereTypeCheck")
; needsArgTag fun lbarf lret
; emitLabel lbarf
; emitBarf ("Tag inference failed on:" ++ onWhat)
; emitLabel lret
}
needsArgTag :: CmmExpr -> BlockId -> BlockId -> FCode ()
needsArgTag closure fail lpass = do
profile <- getProfile
align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
let clo_ty_e = cmmGetClosureType profile align_check closure
let targets = mkSwitchTargets
False
(INVALID_OBJECT, N_CLOSURE_TYPES)
(Just fail)
(M.fromList [(PAP,lpass)
,(BCO,lpass)
,(FUN,lpass)
,(FUN_1_0,lpass)
,(FUN_0_1,lpass)
,(FUN_2_0,lpass)
,(FUN_1_1,lpass)
,(FUN_0_2,lpass)
,(FUN_STATIC,lpass)
])
emit $ mkSwitch clo_ty_e targets
emit $ mkBranch lpass
emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()
emitArgTagCheck info marks args = whenCheckTags $ do
mod <- getModuleName
let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args
arg_infos <- mapM getCgIdInfo cbv_args
let arg_cmms = map idInfoToAmode arg_infos
mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)
zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms)
taggedCgInfo :: CgIdInfo -> Bool
taggedCgInfo cg_info
= case lf of
LFCon {} -> True
LFReEntrant {} -> True
LFUnlifted {} -> True
LFThunk {} -> False
LFUnknown {} -> False
LFLetNoEscape -> panic "Let no escape binding passed to top level con"
where
lf = cg_lf cg_info
checkArg :: SDoc -> CbvMark -> StgArg -> FCode ()
checkArg _ NotMarkedCbv _ = return ()
checkArg msg MarkedCbv arg = whenCheckTags $
case arg of
StgLitArg _ -> return ()
StgVarArg v -> do
info <- getCgIdInfo v
if taggedCgInfo info
then return ()
else case (cg_loc info) of
CmmLoc loc -> emitTagAssertion (showPprUnsafe $ msg <+> text "arg:" <> ppr arg) loc
LneLoc {} -> panic "LNE-arg"
checkArgStatic :: SDoc -> StrictnessMark -> StgArg -> FCode ()
checkArgStatic _ NotMarkedStrict _ = return ()
checkArgStatic msg MarkedStrict arg = whenCheckTags $
case arg of
StgLitArg _ -> return ()
StgVarArg v -> do
info <- getCgIdInfo v
if taggedCgInfo info
then return ()
else pprPanic "Arg not tagged as expectd" (ppr msg <+> ppr arg)